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 I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#) C----------------------------------------------------------------------- C with Minimal Supersymmetric Standard Model Matrix Elements by C S. Moretti(") and K. Odagiri(^) C----------------------------------------------------------------------- C R parity violating Supersymmetric Decays and Matrix Elements by C P. Richardson(X) C----------------------------------------------------------------------- C matrix element corrections to top decay and Drell-Yan type processes C by G. Corcella(&) C----------------------------------------------------------------------- C Deep Inelastic Scattering and Heavy Flavour Electroproduction by C G. Abbiendi(@) and L. Stanco(%) C----------------------------------------------------------------------- C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~) C----------------------------------------------------------------------- C(*) Department of Physics & Astronomy, University of Edinburgh C(+) Dipartimento di Fisica, Universita di Milano-Bicocca C($) School of Physics & Astronomy, University of Manchester C(&) Theory Physics Group, CERN C(#) Cavendish Laboratory, Cambridge C(") School of Physics & Astronomy, Southampton C(^) Academia Sinica, Taiwan C(X) Institute of Particle Physics Phenomenology, University of Durham C(@) Dipartimento di Fisica, Universita di Bologna C(%) Dipartimento di Fisica, Universita di Padova C(~) Institute of Physics, Prague C----------------------------------------------------------------------- C Version 6.520 - 16th August 2010 C----------------------------------------------------------------------- C Main references: C C G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri, C P.Richardson, M.H.Seymour and B.R.Webber, JHEP 0101 (2001) 010 C C G.Marchesini, B.R.Webber, G.Abbiendi, I.G.Knowles, M.H.Seymour, C and L.Stanco, Computer Physics Communications 67 (1992) 465. C----------------------------------------------------------------------- C Please see the official HERWIG information page: C http://www.hep.phy.cam.ac.uk/theory/webber/Herwig/ C----------------------------------------------------------------------- CDECK ID>, CIRCEE. *CMZ :- -03/07/01 17.07.47 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION CIRCEE (X1, X2) C----------------------------------------------------------------------- C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION CIRCEE, X1, X2 WRITE (6,10) 10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED') CIRCEE = 0.0D0+X1+X2 STOP END CDECK ID>, CIRCES. *CMZ :- -03/07/01 17.07.47 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION XX1M, XX2M, XROOTS INTEGER XACC, XVER, XREV, XCHAT WRITE (6,10) 10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED') IF (XX1M.GT.1D10) WRITE (6,*) XX2M,XROOTS,XACC,XVER,XREV,XCHAT STOP END CDECK ID>, CIRCGG. *CMZ :- -03/07/01 17.07.47 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION CIRCGG (X1, X2) C----------------------------------------------------------------------- C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION CIRCGG, X1, X2 WRITE (6,10) 10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED') CIRCGG = 0.0D0+X1+X2 STOP END CDECK ID>, DECADD. *CMZ :- -28/01/92 12.34.44 by Mike Seymour *-- Author : Luca Stanco C----------------------------------------------------------------------- SUBROUTINE DECADD(LOGI) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO' C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE LOGICAL LOGI WRITE (6,10) 10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED') IF (LOGI) STOP STOP END CDECK ID>, DEXAY. *CMZ :- -17/10/01 10.03.37 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE DEXAY(IMODE,POL) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA' C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE INTEGER IMODE REAL POL(4) WRITE (6,10) 10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED') IF (IMODE.GT.1000) WRITE (6,*) POL STOP END CDECK ID>, EUDINI. *CMZ :- -28/01/92 12.34.44 by Mike Seymour *-- Author : Luca Stanco C----------------------------------------------------------------------- SUBROUTINE EUDINI C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO' C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE WRITE (6,10) 10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED') STOP END CDECK ID>, FILHEP. *CMZ :- -17/10/01 09:42:21 by Peter Richardson *-- Author : Martin W. Gruenewald C----------------------------------------------------------------------- SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG) C ---------------------------------------------------------------------- C this subroutine fills one entry into the HEPEVT common C and updates the information for affected mother entries C used by TAUOLA C C written by Martin W. Gruenewald (91/01/28) C ---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' LOGICAL QEDRAD COMMON /PHORAD/ QEDRAD(NMXHEP) INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP REAL PINV LOGICAL PHFLAG REAL*4 P4(4) C C check address mode IF (N.EQ.0) THEN C append mode IHEP=NHEP+1 ELSE IF (N.GT.0) THEN C absolute position IHEP=N ELSE C relative position IHEP=NHEP+N END IF C check on IHEP IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN C add entry NHEP=IHEP ISTHEP(IHEP)=IST IDHEP(IHEP)=ID JMOHEP(1,IHEP)=JMO1 IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP JMOHEP(2,IHEP)=JMO2 IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP JDAHEP(1,IHEP)=JDA1 JDAHEP(2,IHEP)=JDA2 DO I=1,4 PHEP(I,IHEP)=P4(I) C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations VHEP(I,IHEP)=0.0 END DO PHEP(5,IHEP)=PINV C FLAG FOR PHOTOS... QEDRAD(IHEP)=PHFLAG C update process: DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP) IF(IP.GT.0)THEN C if there is a daughter at IHEP, mother entry at IP has decayed IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2 C and daughter pointers of mother entry must be updated IF(JDAHEP(1,IP).EQ.0)THEN JDAHEP(1,IP)=IHEP JDAHEP(2,IP)=IHEP ELSE JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP)) END IF END IF END DO END CDECK ID>, FRAGMT. *CMZ :- -28/01/92 12.34.44 by Mike Seymour *-- Author : Luca Stanco C----------------------------------------------------------------------- SUBROUTINE FRAGMT(I,J,K) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO' C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE INTEGER I,J,K WRITE (6,10) 10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED') IF (I.GT.1000) WRITE (6,*) J,K STOP END CDECK ID>, HVCBVI. *CMZ :- -28/01/92 12.34.44 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HVCBVI C----------------------------------------------------------------------- C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE WRITE (6,10) 10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED') STOP END CDECK ID>, HVHBVI. *CMZ :- -28/01/92 12.34.44 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HVHBVI C----------------------------------------------------------------------- C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE C----------------------------------------------------------------------- IMPLICIT NONE WRITE (6,10) 10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED') STOP END CDECK ID>, HWBAZF. *CMZ :- -26/04/91 11.11.54 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC) C----------------------------------------------------------------------- C Azimuthal correlation functions for Collins' algorithm, C see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2), & VEC3(2),VEC(2) INTEGER IPAR,JPAR LOGICAL GLUI,GLUJ IF (.NOT.AZSPIN) RETURN Z1=PPAR(4,JPAR)/PPAR(4,IPAR) Z2=1.-Z1 GLUI=IDPAR(IPAR).EQ.13 GLUJ=IDPAR(JPAR).EQ.13 IF (GLUI) THEN IF (GLUJ) THEN C Branching: g--->gg FN(2)=Z2/Z1 FN(3)=1./FN(2) FN(4)=Z1*Z2 FN(1)=FN(2)+FN(3)+FN(4) FN(5)=FN(2)+2.*Z1 FN(6)=FN(3)+2.*Z2 FN(7)=FN(4)-2. ELSE C Branching: g--->qqbar FN(1)=(Z1*Z1+Z2*Z2)/2. FN(2)=0. FN(3)=0. FN(4)=-Z1*Z2 FN(5)=-(2.*Z1-1.)/2. FN(6)=-FN(5) FN(7)=FN(1) ENDIF ELSE IF (GLUJ) THEN C Branching: q--->gq FN(1)=(1.+Z2*Z2)/(2.*Z1) FN(2)=Z2/Z1 FN(3)=0. FN(4)=0. FN(5)=FN(1) FN(6)=(1.+Z2)/2. FN(7)=-FN(6) ELSE C Branching: q--->qg FN(1)=(1.+Z1*Z1)/(2.*Z2) FN(2)=0. FN(3)=Z1/Z2 FN(4)=0. FN(5)=(1.+Z1)/2. FN(6)=FN(1) FN(7)=-FN(5) ENDIF ENDIF DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2) DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2) DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2) TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12) VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1) & +(FN(3)+FN(6)*DOT31)*VEC2(1) & +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2) & +(FN(3)+FN(6)*DOT31)*VEC2(2) & +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR END CDECK ID>, HWBCON. *CMZ :- -11/10/01 12.01.52 by Peter Richardson *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBCON C----------------------------------------------------------------------- C MAKES COLOUR CONNECTIONS BETWEEN JETS C MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES C MODIFIED 11/01/01 BY PR FOR SPIN CORRELATIONS(PROBLEM WITH ORDER C OF DECAYS) C NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP LOGICAL BACK IF (IERROR.NE.0) RETURN IF(.NOT.RPARTY) THEN CALL HWBRCN RETURN ENDIF DO 20 IHEP=1,NHEP BACK = .FALSE. IST=ISTHEP(IHEP) C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS IF (IST.LT.145.OR.IST.GT.152) GOTO 20 51 IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR. & ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN C---FIND COLOUR-CONNECTED PARTON IF(BACK) GOTO 52 IF(JMOHEP(2,IHEP).EQ.0) THEN JC=JMOHEP(1,IHEP) IF (IST.NE.152) JC=JMOHEP(1,JC) JC =JMOHEP(2,JC) ELSE JC = JMOHEP(2,IHEP) JHEP = JC ENDIF IF (JC.EQ.0) THEN CALL HWWARN('HWBCON',51) GOTO 20 ENDIF C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE 52 IF (ISTHEP(JC).EQ.155.OR.BACK) THEN IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN C---DECAYED BEFORE HADRONIZING IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND. & ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53 JHEP=JMOHEP(2,JC) C--new bit to try and fix the problems for spin correlations C--move one step further up the tree and hope this helps IF (JHEP.EQ.0) THEN NTRY = 0 1 NTRY = NTRY+1 JC = JMOHEP(1,JC) JHEP = JMOHEP(2,JC) IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155) & JHEP = JMOHEP(2,JHEP) IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1 IF(NHEP.EQ.NTRY) GOTO 20 ENDIF 53 ID=IDHW(JHEP) IF (ISTHEP(JHEP).EQ.155) THEN C---SPECIAL FOR GLUINO DECAYS IF (ID.EQ.449) THEN ID=IDHW(JC) C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER IF (ID.EQ.449.OR.ID.EQ.13.OR. & (ID.GE.401.AND.ID.LE.406).OR. & (ID.GE.413.AND.ID.LE.418).OR. & ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN C---LOOK FOR ANTI(S)QUARK OR GLUON DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP) ID=IDHW(KC) IF ((ID.GE. 7.AND.ID.LE. 13).OR. & (ID.GE.407.AND.ID.LE.412).OR. & (ID.GE.419.AND.ID.LE.424)) GOTO 5 ENDDO ELSE C---LOOK FOR (S)QUARK OR GLUON DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP) ID=IDHW(KC) IF (ID.LE. 6.OR. ID.EQ. 13.OR. & (ID.GE.401.AND.ID.LE.406).OR. & (ID.GE.413.AND.ID.LE.418)) GOTO 5 ENDDO ENDIF C---COULDNT FIND ONE CALL HWWARN('HWBCON',101) GOTO 999 5 JC=KC ELSE C--PR MOD 30/6/99 should fix HWCFOR 104 errors ID2 = IDHW(IHEP) IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND. & (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR. & (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR. & (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN JC = JDAHEP(1,JHEP) ELSE C--modifcation for top ME correction (modified for additional photon radiation) IF(IDHW(JHEP).EQ.6) THEN JC = JDAHEP(1,JHEP)+1 ELSE JC = JDAHEP(1,JHEP)+1 IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1 ENDIF ENDIF ENDIF ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR. & (ID.GE.209.AND.ID.LE.218).OR. & (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN C Wait for partner heavy quark to decay C RETURN C---N.B. MAY BE A PROBLEM HERE GOTO 20 ELSE JMOHEP(2,IHEP)=JHEP JDAHEP(2,JHEP)=IHEP GOTO 20 ENDIF ELSE JC=JMOHEP(2,JC) ENDIF ENDIF JC=JDAHEP(1,JC) JD=JDAHEP(2,JC) C---SEARCH IN CORRESPONDING JET IF (JD.LT.JC) JD=JC LHEP=0 DO 10 JHEP=JC,JD IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP IF (JDAHEP(2,JHEP).NE.0) GOTO 10 C---JOIN IHEP AND JHEP ID=IDHW(JHEP) JMOHEP(2,IHEP)=JHEP JDAHEP(2,JHEP)=IHEP GOTO 20 10 CONTINUE IF (LHEP.NE.0) THEN JMOHEP(2,IHEP)=LHEP ELSE C--search down the tree DO 50 KHEP=JC,JD IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN JHEP = JDAHEP(1,KHEP) BACK = .TRUE. GOTO 51 ENDIF 50 CONTINUE C---DIDN'T FIND PARTNER OF IHEP YET C CALL HWWARN('HWBCON',52) C GOTO 20 ENDIF ENDIF 20 CONTINUE C---BREAK COLOUR CONNECTIONS WITH PHOTONS IHEP=1 30 IF (IHEP.LE.NHEP) THEN IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN C BRW FIX 13/03/99 IF (JMOHEP(2,IHEP).NE.0) THEN IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP) & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP) ENDIF C END FIX IF (JDAHEP(2,IHEP).NE.0) THEN IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP) & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP) ENDIF JMOHEP(2,IHEP)=IHEP JDAHEP(2,IHEP)=IHEP ENDIF IHEP=IHEP+1 GOTO 30 ENDIF 999 RETURN END CDECK ID>, HWBDED. *CMZ :- -22/04/96 13.54.08 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWBDED(IOPT) C FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS C IF (IOPT.EQ.1) SET UP EVENT RECORD C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING C C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE! C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM, & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3), & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3), & I,NDEL,LHEP,IP,JP,KP,IDUN EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR SAVE X,WMAX,P1,P2 SAVE WSUM, X1MIN,X1MAX,EMIT,ICMF,IEVT DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/ LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A) IF (IOPT.EQ.1) THEN C---FIND AN UNTREATED CMF IF (IEVT.EQ.NEVHEP+NWGTS) RETURN IEVT=0 ICMF=0 5 IDUN=ICMF DO 10 IHEP=IDUN+1,NHEP 10 IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND. & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP IF (ICMF.EQ.IDUN) RETURN EM=PHEP(5,ICMF) IF (EM.LT.2*HWBVMC(1)) GOTO 5 C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5 C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2)) 100 CONTINUE C---CHOOSE X1 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0) C---CHOOSE X2 X2MIN=MAX(X(1),1-X(1)) X2MAX=(4*X(1)-3+2*DREAL( DCMPLX( X(1)**3+135*(X(1)-1)**3, & 3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))* & (X(1)-1) )**(1./3) ))/3 IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100 X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1) C---CALCULATE WEIGHT W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) * & (X(1)**2+X(2)**2) C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%) IF (WMAX*HWRGEN(2).GT.W) GOTO 100 C---SYMMETRIZE X1,X2 X(3)=2-X(1)-X(2) IF (HWRGEN(5).GT.HALF) THEN X(1)=X(2) X(2)=2-X(3)-X(1) ENDIF C---CHOOSE WHICH PARTON WILL EMIT EMIT=1 IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2 NOEMIT=3-EMIT IHEP=JDAHEP( EMIT,ICMF) JHEP=JDAHEP(NOEMIT,ICMF) C---PREFACTORS FOR GAMMA AND GLUON CASES QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT) ID=IDHW(JDAHEP(1,ICMF)) GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC) GLUFAC=0 IF (QSCALE.GT.HWBVMC(13)) & GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE) C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE) IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0 C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON IF (GAMFAC*WSUM .GT. HWRGEN(3)) THEN ID3=59 ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN ID3=13 ELSE EMIT=0 GOTO 5 ENDIF C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON M(EMIT)=PHEP(5,IHEP)+VQCUT M(NOEMIT)=PHEP(5,JHEP)+VQCUT M(3)=HWBVMC(ID3) E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2) E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2) E(3)=EM-E(1)-E(2) PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2, & E(EMIT)**2-M(EMIT)**2) IF (PTSQ.LE.ZERO .OR. $ E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN EMIT=0 GOTO 5 ENDIF C---CALCULATE MASS-DEPENDENT SUPRESSION IF (MOD(IPROC,10).GT.0) THEN EPS=(RMASS(ID)/EM)**2 MASDEP=X(1)**2+X(2)**2 $ -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2))) $ -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2))) IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN EMIT=0 GOTO 5 ENDIF ENDIF C---STORE OLD MOMENTA CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1) CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2) C---GET THE NON-EMITTING PARTON'S CMF DIRECTION CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWRAZM(ONE,CS,SN) CALL HWUROT(PHEP(1,JHEP),CS,SN,R) M(EMIT)=PHEP(5,IHEP) M(NOEMIT)=PHEP(5,JHEP) M(3)=RMASS(ID3) KHEP=JDAHEP(2,ICMF) LHEP=KHEP+1 IF (NHEP.GT.KHEP) THEN C---MOVE UP REST OF EVENT DO IP=NHEP,LHEP,-1 JP=IP+1 ISTHEP(JP)= ISTHEP(IP) IDHW(JP)=IDHW(IP) IDHEP(JP)=IDHEP(IP) KP=JMOHEP(1,IP) IF (KP.GT.KHEP) THEN KP=KP+1 ELSE IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP ENDIF JMOHEP(1,JP)=KP KP=JMOHEP(2,IP) IF (KP.GT.KHEP) KP=KP+1 JMOHEP(2,JP)=KP KP=JDAHEP(1,IP) IF (KP.GT.KHEP) KP=KP+1 JDAHEP(1,JP)=KP KP=JDAHEP(2,IP) IF (KP.GT.KHEP) KP=KP+1 JDAHEP(2,JP)=KP CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP)) CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP)) ENDDO ENDIF C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED NHEP=NHEP+1 IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN IHEP=JDAHEP(1,ICMF) JHEP=LHEP ELSE IHEP=LHEP JHEP=JDAHEP(1,ICMF) ENDIF C---SET UP MOMENTA PHEP(5,JHEP)=M(NOEMIT) PHEP(5,IHEP)=M(EMIT) PHEP(5,KHEP)=M(3) PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+ & (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2) PHEP(4,IHEP)=HALF*EM*(X(EMIT)+ & (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2) PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP) PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2) PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) - & (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) - & (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP) PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP) PHEP(2,JHEP)=0 PHEP(2,IHEP)=0 PHEP(2,KHEP)=0 PHEP(1,JHEP)=0 PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2- & PHEP(3,IHEP)**2-PHEP(5,IHEP)**2) PHEP(1,KHEP)=-PHEP(1,IHEP) C---ORIENT IN CMF, THEN BOOST TO LAB CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP)) CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP)) C---CALCULATE PRODUCTION VERTICES CALL HWVZRO(4,VHEP(1,JHEP)) CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT) CALL HWUDKL(ID,PVRT,VHEP(1,KHEP)) CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP)) C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED IF (IHEP.EQ.LHEP) THEN IHEP=JHEP JHEP=LHEP ENDIF C---STATUS, ID AND POINTERS ISTHEP(JHEP)=114 IDHW(JHEP)=IDHW(KHEP) IDHEP(JHEP)=IDHEP(KHEP) IDHW(KHEP)=ID3 IDHEP(KHEP)=IDPDG(ID3) JDAHEP(2,ICMF)=JHEP JMOHEP(1,JHEP)=ICMF JDAHEP(1,JHEP)=0 C---COLOUR CONNECTIONS AND GLUON POLARIZATION JMOHEP(2,JHEP)=IHEP JDAHEP(2,IHEP)=JHEP IF (ID3.EQ.13) THEN JMOHEP(2,IHEP)=KHEP JMOHEP(2,KHEP)=JHEP JDAHEP(2,JHEP)=KHEP JDAHEP(2,KHEP)=IHEP GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3))) GPOLN=1/(1+GPOLN) ELSE JMOHEP(2,IHEP)=JHEP JMOHEP(2,KHEP)=KHEP JDAHEP(2,JHEP)=IHEP JDAHEP(2,KHEP)=KHEP ENDIF IEVT=NEVHEP+NWGTS GOTO 5 ELSEIF (IOPT.EQ.2) THEN C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN RETURN ELSEIF (EMIT.EQ.1) THEN IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1) JHEP=JDAHEP(1,JDAHEP(1,ICMF)) ELSE IHEP=JDAHEP(1,JDAHEP(2,ICMF)) JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1) JDAHEP(1,JDAHEP(2,ICMF))=JHEP IDHW(JHEP)=IDHW(IHEP) IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100) & CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1)) ENDIF JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF) JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF) JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF) JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF) CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF))) CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF))) CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWUMAS(PHEP(1,JHEP)) JDAHEP(2,JHEP)=JDAHEP(2,IHEP) IEDT(1)=JDAHEP(1,ICMF)+1 IEDT(2)=IHEP IEDT(3)=IHEP+1 NDEL=3 IF (ISTHEP(IHEP+1).NE.100) NDEL=2 CALL HWUEDT(NDEL,IEDT) DO 410 I=1,2 IHEP=JDAHEP(1,JDAHEP(I,ICMF)) JMOHEP(1,IHEP)=JDAHEP(I,ICMF) IF (ISTHEP(IHEP+1).EQ.100) THEN JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP) JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP)) ENDIF DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP) JMOHEP(1,JHEP)=IHEP 400 CONTINUE CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF))) CALL HWVZRO(4,VHEP(1,IHEP)) IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1)) 410 CONTINUE EMIT=0 IEVT=0 ELSE CALL HWWARN('HWBDED',500) ENDIF END CDECK ID>, HWBDIS. *CMZ :- -17/05/94 09.33.08 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWBDIS(IOPT) C----------------------------------------------------------------------- C FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS C IF (IOPT.EQ.1) SET UP EVENT RECORD C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5), & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC, & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13), & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT, & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4) INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW, & IEDT(3),NDEL,NTRY,ITEMP LOGICAL BGF EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ SAVE EMIT,COMINT,BGFINT,COMWGT,C1,C2,CM,B1,B2,BM DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/ DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/ IF (IERROR.NE.0) RETURN IF (IOPT.EQ.1) THEN C---FIND AN UNTREATED CMF IF (EMIT.EQ.NEVHEP+NWGTS) RETURN ICMF=0 DO 10 IHEP=1,NHEP 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND. & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP IF (ICMF.EQ.0) RETURN IIN=JMOHEP(2,ICMF) IOUT=JDAHEP(2,ICMF) ILEP=JMOHEP(1,ICMF) CALL HWVEQU(5,PHEP(1,IIN),P1) CALL HWVEQU(5,PHEP(1,IOUT),P2) CALL HWVEQU(5,PHEP(1,ILEP),L) IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) ID=IDHW(IIN) C---STORE OLD MOMENTA CALL HWVEQU(5,P1,Q1) CALL HWVEQU(5,P2,Q2) C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME CALL HWVDIF(4,P2,P1,PCMF) CALL HWUMAS(PCMF) CALL HWVEQU(5,PHEP(1,IHAD),PM) Q=-PCMF(5) XBJ=HALF*Q**2/HWULDO(PM,PCMF) CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF) CALL HWVSUM(4,PM,PCMF,PCMF) CALL HWUMAS(PCMF) CALL HWULOF(PCMF,L,L) CALL HWULOF(PCMF,PM,PM) CALL HWUROT(PM,ONE,ZERO,R) CALL HWUROF(R,L,L) PHI=ATAN2(L(2),L(1)) CALL HWUROT(PM,COS(PHI),SIN(PHI),R) C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP IF (HWRGEN(0).LT.COMWGT) THEN C-----CONSIDER GENERATING A QCD COMPTON EVENT BGF=.FALSE. P3(5)=RMASS(13) 100 RN=HWRGEN(1) IF (RN.LT.C1) THEN ZP=HWRGEN(2) XPMAX=MIN(ZP,1-ZP) XP=HWRGEN(3)*XPMAX FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))* $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) IF (HWRGEN(4).LT.HALF) THEN ZPMAX=ZP ZP=XP XP=ZPMAX ENDIF ELSEIF (RN.LT.C1+C2) THEN XPMAX=0.83 XP=XPMAX*HWRGEN(2) ZPMIN=MAX(XP,1-XP) ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT( $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6))) $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) )) ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX) FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)* $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) ELSE ZPMAX=0.85 ZP=ZPMAX*HWRGEN(2) XPMIN=MAX(ZP,1-ZP) XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP)) XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX) FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)* $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) ENDIF XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP)) ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT( $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6))) $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) )) IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC) $ GOTO 100 ELSE C-----CONSIDER GENERATING A BGF EVENT BGF=.TRUE. P3(5)=P1(5) P1(5)=RMASS(13) 110 RN=HWRGEN(1) IF (RN.LT.B1) THEN ZP=HWRGEN(2) XPMAX=MIN(ZP,1-ZP) XP=HWRGEN(3)*XPMAX FAC=1/B1*2*XPMAX/(1-ZP)* $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) IF (HWRGEN(4).LT.HALF) XP=1-XP ELSEIF (RN.LT.B1+B2) THEN XPMAX=0.83 XP=XPMAX*HWRGEN(2) ZPMIN=MAX(XP,1-XP) ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT( $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6))) $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) )) ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX) FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))* $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) ELSE XPMAX=0.83 XP=XPMAX*HWRGEN(2) ZPMAX=MIN(XP,1-XP) ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT( $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6))) $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) )) ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)* $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP) ENDIF ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT( $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6))) $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) )) IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC) $ GOTO 110 ENDIF C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT IF (BGF) THEN IDNEW=13 CFAC=1./2 FAC=BGFINT/(1-COMWGT) ELSE IDNEW=ID CFAC=4./3 FAC=COMINT/COMWGT ENDIF SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1) ITEMP=ISTAT ISTAT=7 CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2) ISTAT=ITEMP IF (PDFOLD(ID).LE.ZERO) THEN CALL HWWARN('HWBDIS',100) GOTO 999 ENDIF IF (XP.GT.XBJ) THEN CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2) FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC * $ PDFNEW(IDNEW)/PDFOLD(ID) ELSE FAC=0 ENDIF C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING IF (IDHW(IHAD).EQ.59) THEN ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT( $ 3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5 $ -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) )) ZPMAX=1-ZPMIN DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN)) DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN) DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ $ *(DIR1+DIR2) ELSE DIR=0 ENDIF C---DECIDE WHETHER TO MAKE AN EVENT HERE IF (HWRGEN(4).GT.FAC+DIR) RETURN C---FOR DIRECT COUPLING, CHOOSE ZP VALUE IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN NTRY=0 120 NTRY=NTRY+2 ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2) $ GOTO 120 ELSE ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2) ENDIF XP=XBJ BGF=.TRUE. P3(5)=P2(5) P1(5)=0 ENDIF X1=1- ZP /XP X2=1-(1-ZP)/XP XTSQ=4*(1-XP)*(1-ZP)*ZP/XP XT=SQRT(XTSQ) SIN1=XT/SQRT(X1**2+XTSQ) SIN2=XT/SQRT(X2**2+XTSQ) C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES IF (BGF) THEN W1=XP**2*(X1**2+1.5*XTSQ) ELSE W1=1 ENDIF W2=XP**2*(X2**2+1.5*XTSQ) IF (HWRGEN(5)*(W1+W2).GT.W2) THEN IF (BGF) THEN C-----WEIGHTED BY (1+SIN1*COS(PHI))**2 200 PHI=(2*HWRGEN(6)-1)*PIFAC IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200 ELSE C-----UNIFORMLY PHI=(2*HWRGEN(6)-1)*PIFAC ENDIF ELSE C-----WEIGHTED BY (1-SIN2*COS(PHI))**2 210 PHI=(2*HWRGEN(6)-1)*PIFAC IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210 ENDIF C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB P1(1)=0 P1(2)=0 P1(3)=HALF*Q/XP P1(4)=SQRT(P1(3)**2+P1(5)**2) PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q) $ -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q) C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN P2(1)=SQRT(PTSQ)*COS(PHI) P2(2)=SQRT(PTSQ)*SIN(PHI) P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q)) P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q)) P3(1)=P1(1)-P2(1) P3(2)=P1(2)-P2(2) P3(3)=P1(3)-P2(3)-Q P3(4)=P1(4)-P2(4) CALL HWUROB(R,P1,P1) CALL HWUROB(R,P2,P2) CALL HWUROB(R,P3,P3) CALL HWULOB(PCMF,P1,P1) CALL HWULOB(PCMF,P2,P2) CALL HWULOB(PCMF,P3,P3) C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS C---AND PUT THEM BACK ON SHELL IF (XP.EQ.XBJ) THEN CALL HWVDIF(4,PHEP(1,IHAD),P1,PM) CALL HWVSCA(4,HALF,PM,PM) CALL HWVSUM(4,PM,P2,P2) CALL HWVSUM(4,PM,P3,P3) CALL HWUMAS(P2) CALL HWUMAS(P3) CALL HWVEQU(5,PHEP(1,IHAD),P1) CALL HWVSUM(4,P2,P3,PCMF) CALL HWUMAS(PCMF) POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5)) PNEW=PCMF(5)**2/4-RMASS(ID)**2 IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2) CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM) CALL HWVSUM(4,PM,P2,P2) CALL HWUMAS(P2) CALL HWVDIF(4,PCMF,P2,P3) CALL HWUMAS(P3) ENDIF NHEP=NHEP+1 CALL HWVEQU(5,P1,PHEP(1,IIN)) IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN CALL HWVEQU(5,P2,PHEP(1,IOUT)) CALL HWVEQU(5,P3,PHEP(1,NHEP)) ELSE CALL HWVEQU(5,P3,PHEP(1,IOUT)) CALL HWVEQU(5,P2,PHEP(1,NHEP)) ENDIF CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) C Decide which quark radiated and assign production vertices IF (BGF) THEN C Boson-Gluon fusion case IF (1-ZP.LT.HWRGEN(0)) THEN C Gluon splitting to quark CALL HWVZRO(4,VHEP(1,NHEP-1)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT) CALL HWUDKL(ID,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4)) ELSE C Gluon splitting to antiquark CALL HWVZRO(4,VHEP(1,NHEP)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT) CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1)) CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4)) ENDIF ELSE C QCD Compton case IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN C Incoming quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP-1)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT) CALL HWUDKL(ID,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4)) ELSE C Outgoing quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP-4)) CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT) CALL HWUDKL(ID,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1)) ENDIF ENDIF C---STATUS, ID AND POINTERS ISTHEP(NHEP)=114 IF (BGF) THEN IF (XP.EQ.XBJ) THEN IDHW(IIN)=59 IDHEP(IIN)=IDPDG(59) ELSE IDHW(IIN)=13 IDHEP(IIN)=IDPDG(13) ENDIF IF (ID.LT.7) THEN IDHW(NHEP)=IDHW(IOUT) IDHEP(NHEP)=IDHEP(IOUT) IDHW(IOUT)=MOD(ID,6)+6 IDHEP(IOUT)=IDPDG(IDHW(IOUT)) ELSE IDHW(NHEP)=MOD(ID,6) IDHEP(NHEP)=IDPDG(IDHW(NHEP)) ENDIF ELSEIF (ID.LT.7) THEN IDHW(NHEP)=13 IDHEP(NHEP)=IDPDG(13) ELSE IDHW(NHEP)=IDHW(IOUT) IDHEP(NHEP)=IDHEP(IOUT) IDHW(IOUT)=13 IDHEP(IOUT)=IDPDG(13) ENDIF JDAHEP(2,ICMF)=NHEP JMOHEP(1,NHEP)=ICMF C---COLOUR CONNECTIONS IF (XP.EQ.XBJ) THEN JMOHEP(2,IIN)=IIN JDAHEP(2,IIN)=IIN JMOHEP(2,IOUT)=NHEP JDAHEP(2,IOUT)=NHEP JMOHEP(2,NHEP)=IOUT JDAHEP(2,NHEP)=IOUT ELSE JDAHEP(2,IIN)=NHEP JDAHEP(2,NHEP)=IOUT JMOHEP(2,IOUT)=NHEP JMOHEP(2,NHEP)=IIN ENDIF C---FACTORISATION SCALE EMSCA=SCALE EMIT=NEVHEP+NWGTS ELSEIF (IOPT.EQ.2) THEN C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN IF (.NOT.BGF) THEN CALL HWVEQU(5,Q1,PHEP(1,IIN)) CALL HWVEQU(5,Q2,PHEP(1,IOUT)) JMOHEP(2,IIN)=IOUT JDAHEP(2,IIN)=IOUT JMOHEP(2,IOUT)=IIN JDAHEP(2,IOUT)=IIN JDAHEP(2,ICMF)=IOUT IHEP=JDAHEP(1,IOUT) JHEP=JDAHEP(1,IOUT+1) CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP)) CALL HWUMAS(PHEP(1,IHEP)) JDAHEP(2,IHEP)=JDAHEP(2,JHEP) IEDT(1)=IOUT+1 IEDT(2)=JHEP IEDT(3)=JHEP+1 NDEL=3 IF (ISTHEP(JHEP+1).NE.100) NDEL=2 IHEP=JDAHEP(1,IOUT) JMOHEP(1,IHEP)=IOUT IF (ISTHEP(IHEP+1).EQ.100) THEN JMOHEP(1,IHEP+1)=IOUT JMOHEP(2,IHEP+1)=IIN ENDIF DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP) JMOHEP(1,JHEP)=IHEP 300 CONTINUE IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1) IDHEP(IOUT)=IDPDG(IDHW(IOUT)) IDHW(IHEP)=IDHW(IOUT) CALL HWUEDT(NDEL,IEDT) ELSEIF (ID.LT.7) THEN CALL HWVEQU(5,Q1,PHEP(1,IIN)) CALL HWVEQU(5,Q2,PHEP(1,IOUT+1)) JMOHEP(2,IIN)=IOUT+1 JDAHEP(2,IIN)=IOUT+1 JMOHEP(2,IOUT+1)=IIN JDAHEP(2,IOUT+1)=IIN JDAHEP(2,ICMF)=IOUT+1 IHEP=JDAHEP(1,IIN) JHEP=JDAHEP(1,IOUT) CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP)) CALL HWUMAS(PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1, $ JDAHEP(1,JHEP),JDAHEP(2,IHEP)) JHEP=JDAHEP(1,IOUT) JDAHEP(2,IHEP)=JDAHEP(2,JHEP) IEDT(1)=IOUT IEDT(2)=JHEP IEDT(3)=JHEP+1 NDEL=3 IF (ISTHEP(JHEP+1).NE.100) NDEL=2 CALL HWUEDT(NDEL,IEDT) IHEP=JDAHEP(1,IIN) DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP) JMOHEP(1,JHEP)=IHEP 400 CONTINUE IDHW(IIN)=ID IDHEP(IIN)=IDPDG(ID) IDHW(IHEP)=ID ELSE CALL HWVEQU(5,Q1,PHEP(1,IIN)) CALL HWVEQU(5,Q2,PHEP(1,IOUT)) JMOHEP(2,IIN)=IOUT JDAHEP(2,IIN)=IOUT JMOHEP(2,IOUT)=IIN JDAHEP(2,IOUT)=IIN JDAHEP(2,ICMF)=IOUT IHEP=JDAHEP(1,IIN) JHEP=JDAHEP(1,IOUT+1) CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP)) CALL HWUMAS(PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1, $ JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1) JHEP=JDAHEP(1,IOUT+1) JDAHEP(1,IHEP)=JDAHEP(1,JHEP) IEDT(1)=IOUT+1 IEDT(2)=JHEP IEDT(3)=JHEP+1 NDEL=3 IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2 CALL HWUEDT(NDEL,IEDT) IHEP=JDAHEP(1,IIN) DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP) JMOHEP(1,JHEP)=IHEP 500 CONTINUE IDHW(IIN)=ID IDHEP(IIN)=IDPDG(ID) IDHW(IHEP)=ID ENDIF CALL HWVZRO(4,VHEP(1,IIN)) CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN))) IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100) $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1)) CALL HWVZRO(4,VHEP(1,IOUT)) CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT))) IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100) $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1)) EMIT=0 ELSE CALL HWWARN('HWBDIS',500) ENDIF 999 RETURN END CDECK ID>, HWBDYP. *CMZ :- -02/10/08 14.45.41 by Mike Seymour *-- Author : Gennaro Corcella C----------------------------------------------------------------------- SUBROUTINE HWBDYP(IOPT) C MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ, & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST, & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2, & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y, & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1, & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM, & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5), & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(3),PS(5),PD(5),P2N(5), & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN,PM1(4),PM2(4),HWULDO, & PPDOT,GAM,PMDOT,PTMP(4),EMSQ1,EMSQ2 LOGICAL GLUIN,GP INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP, & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR SAVE PS,PF,ICMF,ID4,ID5 SAVE EMIT,NTMP DATA EMIT,NTMP/2*0/ IF (IOPT.EQ.1) THEN EMIT=0 NTMP=0 C-----CHOOSE WEIGHTS COMWGT1=0.1 COMWGT2=0.55 C---FIND AN UNTREATED CMF ICMF=0 DO 10 IHEP=1,NHEP 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND. & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP IF (ICMF.EQ.0) RETURN EM=PHEP(5,ICMF) C-----SET THE VECTOR BOSON RAPIDITY Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/ & (PHEP(4,ICMF)-PHEP(3,ICMF))) C------SET PARTICLE IDENTIES c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY IDBOS=IDHW(ICMF) ID1=IDHW(JMOHEP(1,ICMF)) ID2=IDHW(JMOHEP(2,ICMF)) ID4=IDHW(JDAHEP(1,ICMF)) ID5=IDHW(JDAHEP(2,ICMF)) M1=RMASS(ID1) M2=RMASS(ID2) M3=RMASS(13) C---STORE OLD MOMENTA C------VECTOR BOSON MOMENTUM CALL HWVEQU(5,PHEP(1,ICMF),PBOS) C----QUARK MOMENTUM CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1) C------ANTIQUARK MOMENTUM CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2) C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3) CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4) C------LEPTON MOMENTA IN THE BOSON REST FRAME CALL HWULOF(PHEP(1,ICMF),P2,P2N) CALL HWULOF(PHEP(1,ICMF),P3,P3N) C------AZ=AZIMUTHAL ANGLE OF P3N AZ=ATAN2(P3N(2),P3N(1)) CZ=COS(AZ) SZ=SIN(AZ) C------PHI=ANGLE BETWEEN P2N AND P3N SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3) PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2) PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2) CPHI=SCAPR/(PMOD3*PMOD2) SPHI=SQRT(1-CPHI**2) C------HADRON MOMENTA IHAD1=1 IHAD2=2 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1) CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2) CALL HWVSUM(4,PHAD1,PHAD2,PTOT) CALL HWUMAS(PTOT) C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS) c---minorimprovement---mhs---4/8/04---include mass effects correctly ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3)) ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3)) C------ PDFs FOR THE BORN PROCESS CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1) CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2) C-------CONSIDER Q(QBAR) IN THE INITIAL STATE RN=HWRGEN(9) IF (RN.LT.COMWGT1) THEN C-------NO GLUON IN THE INITIAL STATE GLUIN=.FALSE. C---CHOOSE S ACCORDING TO 1/S**2 SVNTN=17 SMIN=HALF*EM**2*(7-SQRT(SVNTN)) SMAX=PTOT(5)**2 IF (SMAX.LE.SMIN) RETURN S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN)) JAC=S**2*(1/SMIN-1/SMAX) C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S)) TMIN=EM**2-S-TMAX IF (TMAX.LE.TMIN) RETURN T=TMAX*(TMIN/TMAX)**HWRGEN(1) IF (HWRGEN(2).GT.HALF) T=EM**2-S-T U=EM**2-S-T JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX) SCALE=SQRT(U*T/S) SCALE1=SQRT(U*T/S+EM**2) GLUFAC=0 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC) C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U)) XI2=S/(4*XI1*PHAD1(4)*PHAD2(4)) c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN C-----PDFs WITH AN EMITTED GLUON CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1) CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2) C------CALCULATE WEIGHT W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U) W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)* & PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2)) C-------CHOOSE WHICH PARTON WILL EMIT EMIT=1 IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2)) & EMIT=2 NOEMIT=3-EMIT ELSE C--------GLUON IN THE INITIAL STATE GLUIN=.TRUE. C---CHOOSE S ACCORDING TO 1/S**2 SMIN=EM**2 SMAX=PTOT(5)**2 IF (SMAX.LE.SMIN) RETURN S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN)) JAC=S**2*(1/SMIN-1/SMAX) C---CHOOSE T ACCORDING TO 1/T TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S)) TMIN=EM**2-S IF (TMAX.LE.TMIN) RETURN T=TMAX*(TMIN/TMAX)**HWRGEN(1) JAC=JAC*T*LOG(TMAX/TMIN) U=EM**2-S-T SCALE=SQRT(U*T/S) SCALE1=SQRT(U*T/S+EM**2) GLUFAC=0 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC) C--------INITIAL STATE GLUON COMING FROM HADRON 1 IF (RN.LE.COMWGT2) THEN GP=.TRUE. C--------ENERGY FRACTIONS and PDFs c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U)) XI2=S/(4*XI1*PHAD1(4)*PHAD2(4)) c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1) CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2) WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)* & PDFOLD1(ID1)*PDFOLD2(ID2)) ELSE C-------INITIAL STATE GLUON COMING FROM HADRON 2 GP=.FALSE. C-------ENERGY FRACTIONS AND PDFs c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T)) XI2=S/(4*XI1*PHAD1(4)*PHAD2(4)) c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN IF ((1-XI2)*SCALE.LT.HWBVMC(13)) RETURN CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1) CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2) WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)* & PDFOLD1(ID1)*PDFOLD2(ID2)) ENDIF W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T) C-------CHOOSE WHICH PARTON WILL EMIT c---bug fix---mhs---4/8/04---swap emitter and nonemitter EMIT=2 IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2)) & EMIT=1 NOEMIT=3-EMIT C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2) ENDIF C--------ADD ONE MORE GLUON IF (W1.GT.HWRGEN(4)) THEN NTMP=NEVHEP+NWGTS ELSE RETURN ENDIF C---------INCLUDE MASSES S=S+M1**2+M2**2+M3**2 IF (.NOT.GLUIN) THEN TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2 $ -((S-M1**2-M2**2)**2-4*M1**2*M2**2)* $ ((S-M3**2-EM**2)**2-4*M3**2*EM**2) ELSEIF (GP) THEN TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2 $ -((S-M3**2-M2**2)**2-4*M3**2*M2**2)* $ ((S-M1**2-EM**2)**2-4*M1**2*EM**2) ELSE TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2 $ -((S-M3**2-M1**2)**2-4*M3**2*M1**2)* $ ((S-M2**2-EM**2)**2-4*M2**2*EM**2) ENDIF IF (TEST.GE.0) THEN EMIT=0 RETURN ENDIF M(1)=M1 M(2)=M2 M(3)=M3 C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER PV(1)=0 PV(2)=0 PV(3)=0 PV(4)=EM PV(5)=EM PNE(2)=0 PNE(1)=0 IF (.NOT.GLUIN) THEN PK(4)=(S-M(3)**2-EM**2)/(2*EM) PMODK=SQRT(PK(4)**2-M(3)**2) IF (EMIT.EQ.1) THEN MM=M(1) X1=T X2=U X3=-1 ELSE MM=M(2) X1=U X2=T X3=+1 ENDIF PNE(4)=(EM**2+MM**2-X1)/(2*EM) PNE(3)=X3*SQRT(PNE(4)**2-MM**2) COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK) ELSE PK(4)=(EM**2+M(3)**2-U)/(2*EM) PMODK=SQRT(PK(4)**2-M(3)**2) IF (EMIT.EQ.1) THEN IF (GP) THEN MM=M(1) X3=+1 ELSE MM=M(2) X3=-1 ENDIF PNE(4)=(S-MM**2-EM**2)/(2*EM) PNE(3)=X3*SQRT(PNE(4)**2-MM**2) COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK) ELSE IF (GP) THEN MM=M(2) X3=-1 ELSE MM=M(1) X3=+1 ENDIF PNE(4)=(EM**2+MM**2-T)/(2*EM) PNE(3)=X3*SQRT(PNE(4)**2-MM**2) COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK) ENDIF ENDIF CALL HWUMAS(PNE) SIN3=SQRT(1-COS3**2) C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS CALL HWRAZM(PMODK*SIN3,PK(1),PK(2)) PK(3)=PMODK*COS3 CALL HWUMAS(PK) DO K=1,4 IF (.NOT.GLUIN) THEN PE(K)=PV(K)+PK(K)-PNE(K) ELSE IF (EMIT.EQ.1) THEN PE(K)=PV(K)+PNE(K)-PK(K) ELSE PE(K)=PNE(K)+PK(K)-PV(K) ENDIF ENDIF ENDDO CALL HWUMAS(PE) c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION C------TAKEN FROM THE BORN PROCESS PS(5)=P3(5) PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM) PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ PF(5)=P4(5) PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM) PF(3)=-PS(3) PF(2)=-PS(2) PF(1)=-PS(1) C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME IF (.NOT.GLUIN) THEN IF (EMIT.EQ.1) THEN CALL HWVEQU(5,PE,PP1) CALL HWVEQU(5,PNE,PP2) ELSE CALL HWVEQU(5,PNE,PP1) CALL HWVEQU(5,PE,PP2) ENDIF ELSE IF (GP) THEN CALL HWVEQU(5,PK,PP1) IF (EMIT.EQ.1) THEN CALL HWVEQU(5,PE,PP2) ELSE CALL HWVEQU(5,PNE,PP2) ENDIF ELSE CALL HWVEQU(5,PK,PP2) IF (EMIT.EQ.1) THEN CALL HWVEQU(5,PE,PP1) ELSE CALL HWVEQU(5,PNE,PP1) ENDIF ENDIF ENDIF CALL HWVSCA(4,1/XI1,PP1,PP1) CALL HWVSCA(4,1/XI2,PP2,PP2) CALL HWUMAS(PP1) CALL HWUMAS(PP2) C---SUBTRACT A LITTLE EXTRA TO PUT THEM BACK ON MASS-SHELL PPDOT=HWULDO(PP1,PP2) GAM=PPDOT**2-(PP1(5)*PP2(5))**2 IF (GAM.LT.0.OR.PP1(5).LE.0.OR.PP2(5).LE.0) THEN CALL HWWARN('HWBDYP',100) GOTO 999 ENDIF GAM=PPDOT-SQRT(GAM) CALL HWVSCA(4,GAM/PP2(5)**2,PP2,PM1) CALL HWVDIF(4,PP1,PM1,PM1) CALL HWVSCA(4,GAM/PP1(5)**2,PP1,PM2) CALL HWVDIF(4,PP2,PM2,PM2) PMDOT=HWULDO(PM1,PM2) EMSQ1=SIGN(PHEP(5,IHAD1)**2,PHEP(5,IHAD1)) CALL HWVSCA(4,(PP1(5)**2-EMSQ1)/(2*HWULDO(PP1,PM2)),PM2,PTMP) CALL HWVDIF(4,PP1,PTMP,PP1) EMSQ2=SIGN(PHEP(5,IHAD2)**2,PHEP(5,IHAD2)) CALL HWVSCA(4,(PP2(5)**2-EMSQ2)/(2*HWULDO(PP2,PM1)),PM1,PTMP) CALL HWVDIF(4,PP2,PTMP,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) CALL HWULOF(PLAB,PP1,PP1) C----PUT HADRON 1 ON THE Z-AXIS CALL HWVEQU(3,PP1,PZ) MODP=SQRT(PZ(1)**2+PZ(2)**2) IF (MODP.EQ.0) THEN CALL HWWARN('HWBDYP',101) GOTO 999 ENDIF CTH=PZ(1)/MODP STH=PZ(2)/MODP CALL HWUROT(PZ,CTH,STH,R3) C-----ROTATE EVERYTHING BY R3 CALL HWUROF(R3,PE,PE) CALL HWUROF(R3,PNE,PNE) CALL HWUROF(R3,PV,PV) CALL HWUROF(R3,PK,PK) CALL HWUROF(R3,PS,PS) CALL HWUROF(R3,PF,PF) C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED IF (.NOT.GLUIN) THEN IHEP=JMOHEP(EMIT,ICMF) JHEP=JMOHEP(NOEMIT,ICMF) ENDIF CHEP=ICMF IDHW(CHEP)=15 IDHEP(CHEP)=IDPDG(15) ICMF=ICMF+1 IDHW(ICMF)=IDBOS IDHEP(ICMF)=IDPDG(IDBOS) C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON IF (.NOT.GLUIN) THEN KHEP=ICMF+1 ISTHEP(KHEP)=114 C---STATUS OF EMITTER/NON EMITTER ISTHEP(IHEP)=110+EMIT ISTHEP(JHEP)=110+NOEMIT ELSE C-----GLUON COMING FROM THE 1ST HADRON IF (GP) THEN KHEP=CHEP-2 ISTHEP(KHEP)=111 C----EMIT=1 IF (EMIT.EQ.1) THEN IHEP=KHEP+1 ISTHEP(IHEP)=112 JHEP=ICMF+1 ISTHEP(JHEP)=114 IDHW(IHEP)=ID2 IF (ID1.LE.6) THEN IDHW(JHEP)=ID1+6 ELSE IDHW(JHEP)=ID1-6 ENDIF ELSE C-------EMIT=2 JHEP=KHEP+1 ISTHEP(JHEP)=112 IDHW(JHEP)=ID2 IHEP=ICMF+1 ISTHEP(IHEP)=114 IF (ID1.LE.6) THEN IDHW(IHEP)=ID1+6 ELSE IDHW(IHEP)=ID1-6 ENDIF ENDIF ENDIF C------GLUON COMING FROM THE HADRON 2 IF (.NOT.GP) THEN KHEP=CHEP-1 ISTHEP(KHEP)=112 C-------EMIT=1 IF (EMIT.EQ.1) THEN IHEP=KHEP-1 ISTHEP(IHEP)=111 IDHW(IHEP)=ID1 JHEP=ICMF+1 ISTHEP(JHEP)=114 IF (ID2.LE.6) THEN IDHW(JHEP)=ID2+6 ELSE IDHW(JHEP)=ID2-6 ENDIF ELSE C-------EMIT=2 JHEP=KHEP-1 ISTHEP(JHEP)=111 IDHW(JHEP)=ID1 IHEP=ICMF+1 ISTHEP(IHEP)=114 IF (ID2.LE.6) THEN IDHW(IHEP)=ID2+6 ELSE IDHW(IHEP)=ID2-6 ENDIF ENDIF ENDIF ENDIF IDHEP(IHEP)=IDPDG(IDHW(IHEP)) IDHEP(JHEP)=IDPDG(IDHW(JHEP)) ISTHEP(ICMF)=113 ISTHEP(CHEP)=110 IDHW(KHEP)=13 IDHEP(KHEP)=IDPDG(13) C---------DEFINE MOMENTA IN THE LAB FRAME CALL HWVEQU(5,PV,PHEP(1,ICMF)) CALL HWVEQU(5,PK,PHEP(1,KHEP)) CALL HWVEQU(5,PNE,PHEP(1,JHEP)) CALL HWVEQU(5,PE,PHEP(1,IHEP)) IF (.NOT.GLUIN) THEN CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP)) ELSE IF (EMIT.EQ.1) THEN CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP)) ELSE CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP)) ENDIF ENDIF CALL HWUMAS(PHEP(1,CHEP)) IF (.NOT.GLUIN) THEN JMOHEP(1,JHEP)=CHEP JMOHEP(1,IHEP)=CHEP JDAHEP(1,JHEP)=CHEP JDAHEP(1,IHEP)=CHEP JMOHEP(1,KHEP)=CHEP JDAHEP(1,KHEP)=0 JMOHEP(1,ICMF)=CHEP JMOHEP(2,ICMF)=ICMF JDAHEP(1,ICMF)=0 JDAHEP(2,ICMF)=ICMF ENDIF IF (GLUIN) THEN JMOHEP(2,ICMF)=ICMF JDAHEP(2,ICMF)=ICMF JMOHEP(1,KHEP)=CHEP JDAHEP(1,KHEP)=CHEP JMOHEP(1,IHEP)=CHEP JMOHEP(1,JHEP)=CHEP IF (EMIT.EQ.1) THEN JDAHEP(1,IHEP)=CHEP JDAHEP(1,JHEP)=0 ELSE JDAHEP(1,JHEP)=CHEP JDAHEP(1,IHEP)=0 ENDIF ENDIF C---COLOUR CONNECTIONS IF (.NOT.GLUIN) THEN IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN JMOHEP(2,KHEP)=IHEP JDAHEP(2,KHEP)=JHEP JMOHEP(2,IHEP)=JHEP JDAHEP(2,IHEP)=KHEP JDAHEP(2,JHEP)=IHEP JMOHEP(2,JHEP)=KHEP ELSE JMOHEP(2,KHEP)=JHEP JDAHEP(2,KHEP)=IHEP JMOHEP(2,JHEP)=IHEP JDAHEP(2,JHEP)=KHEP JDAHEP(2,IHEP)=JHEP JMOHEP(2,IHEP)=KHEP ENDIF ENDIF IF (GLUIN) THEN IF (EMIT.EQ.1) THEN IF (IDHEP(IHEP).GT.0) THEN JMOHEP(2,IHEP)=JHEP JDAHEP(2,IHEP)=KHEP JMOHEP(2,JHEP)=KHEP JDAHEP(2,JHEP)=IHEP JMOHEP(2,KHEP)=IHEP JDAHEP(2,KHEP)=JHEP ELSE JMOHEP(2,IHEP)=KHEP JDAHEP(2,IHEP)=JHEP JMOHEP(2,JHEP)=IHEP JDAHEP(2,JHEP)=KHEP JMOHEP(2,KHEP)=JHEP JDAHEP(2,KHEP)=IHEP ENDIF ELSE IF (IDHEP(JHEP).GT.0) THEN JMOHEP(2,JHEP)=IHEP JDAHEP(2,JHEP)=KHEP JMOHEP(2,IHEP)=KHEP JDAHEP(2,IHEP)=JHEP JMOHEP(2,KHEP)=JHEP JDAHEP(2,KHEP)=IHEP ELSE JMOHEP(2,JHEP)=KHEP JDAHEP(2,JHEP)=IHEP JMOHEP(2,IHEP)=JHEP JDAHEP(2,IHEP)=KHEP JMOHEP(2,KHEP)=IHEP JDAHEP(2,KHEP)=JHEP ENDIF ENDIF ENDIF EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2) C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER ELSEIF (IOPT.EQ.2) THEN IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN ISTHEP(JDAHEP(1,ICMF))=195 IDHW(NHEP+1)=ID4 IDHW(NHEP+2)=ID5 IDHEP(NHEP+1)=IDPDG(ID4) IDHEP(NHEP+2)=IDPDG(ID5) ISTHEP(NHEP+1)=113 ISTHEP(NHEP+2)=114 CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+ & PHEP(3,ICMF)**2) SW=SQRT(1-CW**2) CALL HWUROT(PHEP(1,ICMF),CW,SW,R4) CALL HWUROF(R4,PHEP(1,ICMF),PR) PR(4)=PHEP(4,ICMF) CALL HWUMAS(PR) CALL HWUROF(R4,PS,PS) CALL HWUROF(R4,PF,PF) CALL HWUMAS(PS) CALL HWUMAS(PF) CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5) CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD) PD(4)=PHEP(4,JDAHEP(1,ICMF)) CALL HWUMAS(PD) BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+ & PD(3)**4))/(PD(3)**2+PR(4)**2) GAMMA1=1/SQRT(1-BETA1**2) PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3) PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3) PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3) PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3) PHEP(1,NHEP+1)=PS(1) PHEP(2,NHEP+1)=PS(2) PHEP(1,NHEP+2)=PF(1) PHEP(2,NHEP+2)=PF(2) CALL HWUMAS(PHEP(1,NHEP+1)) CALL HWUMAS(PHEP(1,NHEP+2)) CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1)) CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2)) JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1 JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2 JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF) JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF) JMOHEP(2,NHEP+1)=NHEP+2 JDAHEP(2,NHEP+1)=NHEP+2 JMOHEP(2,NHEP+2)=NHEP+1 JDAHEP(2,NHEP+2)=NHEP+1 C--special for spin correlations(relabel in spin common block) IF(SYSPIN.AND.NSPN.NE.0) THEN IDSPN(2) = NHEP+1 IDSPN(3) = NHEP+2 ISNHEP(NHEP+1) = 2 ISNHEP(NHEP+2) = 3 ENDIF NHEP=NHEP+2 EMIT=0 ENDIF 999 RETURN END CDECK ID>, HWBFIN. *CMZ :- -26/04/91 10.18.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBFIN(IHEP) C----------------------------------------------------------------------- C DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX C AND COPIES INTO /HEPEVT/ IN COLOUR ORDER. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP IF (IERROR.NE.0) RETURN C---SAVE VIRTUAL PARTON DATA NHEP=NHEP+1 IF(NHEP.GT.NMXHEP) THEN CALL HWWARN('HWBFIN',100) GOTO 999 ENDIF ID=IDPAR(2) IDHW(NHEP)=ID IDHEP(NHEP)=IDPDG(ID) ISTHEP(NHEP)=ISTHEP(IHEP)+20 JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=JMOHEP(1,IHEP) JDAHEP(1,IHEP)=NHEP JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP)) CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP)) C---FINISHED FOR SPECTATOR OR NON-PARTON JETS IF (ISTHEP(NHEP).GT.136) RETURN IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN IF (ID.GT.424.AND.ID.NE.449) RETURN IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN IDHEP(NHEP)=94 IJET=NHEP IF (NPAR.GT.2) THEN C---SAVE CONE DATA NHEP=NHEP+1 IF(NHEP.GT.NMXHEP) THEN CALL HWWARN('HWBFIN',101) GOTO 999 ENDIF IDHW(NHEP)=IDPAR(1) IDHEP(NHEP)=0 ISTHEP(NHEP)=100 JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=JCOPAR(1,1) JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 CALL HWVEQU(5,PPAR,PHEP(1,NHEP)) CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP)) ENDIF KHEP=NHEP C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON IPAR=2 JPAR=JCOPAR(4,IPAR) NXPAR=NPAR/2 DO 20 IP=1,NXPAR DO 10 JP=1,NXPAR IF (JPAR.EQ.0) GOTO 15 IF (JCOPAR(2,JPAR).EQ.IPAR) THEN IPAR=JPAR JPAR=JCOPAR(4,IPAR) ELSE IPAR=JPAR JPAR=JCOPAR(1,IPAR) ENDIF 10 CONTINUE C---COULDN'T FIND COLOUR PARTNER CALL HWWARN('HWBFIN',1) 15 JPAR=JCOPAR(1,IPAR) KHEP=KHEP+1 IF(KHEP.GT.NMXHEP) THEN CALL HWWARN('HWBFIN',102) GOTO 999 ENDIF ID=IDPAR(IPAR) IF (TMPAR(IPAR)) THEN IF (ID.LT.14) THEN ISTHEP(KHEP)=139 ELSEIF (ID.EQ.59) THEN ISTHEP(KHEP)=139 ELSEIF (ID.LT.109) THEN ISTHEP(KHEP)=130 ELSEIF (ID.LT.120) THEN ISTHEP(KHEP)=139 ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN ISTHEP(KHEP)=130 ELSEIF (ID.LT.425) THEN ISTHEP(KHEP)=139 ELSEIF (ID.EQ.449) THEN ISTHEP(KHEP)=139 ELSE ISTHEP(KHEP)=130 ENDIF ELSE ISTHEP(KHEP)=ISTHEP(IHEP)+24 ENDIF IDHW(KHEP)=ID IDHEP(KHEP)=IDPDG(ID) CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP)) CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP)) JMOHEP(1,KHEP)=IJET JMOHEP(2,KHEP)=KHEP+1 JDAHEP(1,KHEP)=0 JDAHEP(2,KHEP)=KHEP-1 20 CONTINUE JMOHEP(2,KHEP)=0 JDAHEP(2,NHEP+1)=0 JDAHEP(1,IJET)=NHEP+1 JDAHEP(2,IJET)=KHEP NHEP=KHEP 999 RETURN END CDECK ID>, HWBGEN. *CMZ :- -14/10/99 18.04.56 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBGEN C----------------------------------------------------------------------- C BRANCHING GENERATOR WITH INTERFERING GLUONS C HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF C G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET), & IRST(NMXJET),JPR LOGICAL HWRLOG EXTERNAL HWULDO,HWRGAU IF (IERROR.NE.0) RETURN IF (IPRO.EQ.80) RETURN C---CHECK THAT EMSCA IS SET IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200) IF (HARDME) THEN C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E- JPR=IPROC/10 C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1) C**********END FIX C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS IF (IPRO.EQ.90) CALL HWBDIS(1) C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1) C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS CALL HWBTOP ENDIF C---GENERATE INTRINSIC PT ONCE AND FOR ALL DO 5 JNHAD=1,2 IF (PTRMS.NE.0.) THEN PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS) PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS) PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2 ELSE CALL HWVZRO(3,PTINT(1,JNHAD)) ENDIF 5 CONTINUE NTRY=0 LASHEP=NHEP 10 NTRY=NTRY+1 IF (NTRY.GT.NETRY) THEN CALL HWWARN('HWBGEN',ISLENT*100) GOTO 999 ENDIF NRHEP=0 NHEP=LASHEP FROST=.FALSE. DO 100 IHEP=1,LASHEP IST=ISTHEP(IHEP) IF (IST.GE.111.AND.IST.LE.115) THEN NRHEP=NRHEP+1 IRHEP(NRHEP)=IHEP IRST(NRHEP)=IST ID=IDHW(IHEP) IF (IST.NE.115) THEN C---FOUND A PARTON TO EVOLVE NEVPAR=IHEP NPAR=2 IDPAR(1)=17 IDPAR(2)=ID TMPAR(1)=.TRUE. PPAR(2,1)=0. PPAR(4,1)=1. DO 15 J=1,2 DO 15 I=1,2 JMOPAR(I,J)=0 15 JCOPAR(I,J)=0 C---SET UP EVOLUTION SCALE AND FRAME JHEP=JMOHEP(2,IHEP) IF (ID.EQ.13) THEN C--BRW mod 15/12/06 for Nason method IF (TRUNSH) THEN C--If truncated shower added, use smaller of 2 scales for gluon jet IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN CALL HWWARN('HWBGEN',101) RETURN ENDIF ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))/PHEP(4,JHEP) JHEP=JDAHEP(2,IHEP) IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN CALL HWWARN('HWBGEN',102) RETURN ENDIF IF (ERTXI.LT.HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))/PHEP(4,JHEP)) & JHEP=JMOHEP(2,IHEP) ELSE IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP) ENDIF C--end mod ELSEIF (IST.GT.112) THEN IF ((ID.GT.6.AND.ID.LT.13).OR. & (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP) ELSE IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP) ENDIF IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN CALL HWWARN('HWBGEN',1) JHEP=IHEP ENDIF JCOPAR(1,1)=JHEP EINHEP=PHEP(4,IHEP) ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP)) IF (ERTXI.LT.ZERO) ERTXI=0. IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0. IF (ISTHEP(JHEP).EQ.155) THEN ERTXI=ERTXI/PHEP(5,JHEP) RTXI=1. ELSE ERTXI=SQRT(ERTXI) RTXI=ERTXI/EINHEP ENDIF IF (RTXI.EQ.ZERO) THEN XF=1. PPAR(1,1)=0. PPAR(3,1)=1. PPAR(1,2)=EINHEP PPAR(2,2)=0. PPAR(4,2)=EINHEP ELSE XF=1./RTXI PPAR(1,1)=1. PPAR(3,1)=0. PPAR(1,2)=ERTXI PPAR(2,2)=1. PPAR(4,2)=ERTXI ENDIF IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP) C---STORE MASS PPAR(5,2)=PHEP(5,IHEP) CALL HWVZRO(4,VPAR(1,1)) CALL HWVZRO(4,VPAR(1,2)) IF (IST.GT.112) THEN TMPAR(2)=.TRUE. INHAD=0 JNHAD=0 XFACT=0. ELSE TMPAR(2)=.FALSE. JNHAD=IST-110 INHAD=JNHAD IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD) XFACT=XF/PHEP(4,INHAD) ANOMSC(1,JNHAD)=ZERO ANOMSC(2,JNHAD)=ZERO ENDIF C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION HARDST=PPAR(4,2) IF (SOFTME.AND.IDHW(IHEP).LT.13.AND. $ ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR. $ ISTHEP(JHEP).EQ.155)) HARDST=0 C---CREATE BRANCHES AND COMPUTE ENERGIES DO 20 KPAR=2,NMXPAR IF (TMPAR(KPAR)) THEN CALL HWBRAN(KPAR) ELSE CALL HWSBRN(KPAR) ENDIF IF (IERROR.NE.0) RETURN IF (FROST) GOTO 100 IF (KPAR.EQ.NPAR) GOTO 30 20 CONTINUE C---COMPUTE MASSES AND 3-MOMENTA 30 CONTINUE CALL HWBMAS IF (AZSPIN) CALL HWBSPN IF (TMPAR(2)) THEN CALL HWBTIM(2,1) ELSE CALL HWBSPA ENDIF C---ENTER PARTON JET IN /HEPEVT/ CALL HWBFIN(IHEP) ELSE C---COPY SPECTATOR NHEP=NHEP+1 IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN ISTHEP(NHEP)=190 ELSE ISTHEP(NHEP)=152 ENDIF IDHW(NHEP)=ID IDHEP(NHEP)=IDPDG(ID) JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=0 JDAHEP(2,NHEP)=0 JDAHEP(1,IHEP)=NHEP CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP)) ENDIF ISTHEP(IHEP)=ISTHEP(IHEP)+10 ENDIF 100 CONTINUE IF (.NOT.FROST) THEN C---COMBINE JETS ISTAT=20 CALL HWBJCO ENDIF IF (.NOT.FROST) THEN C---ATTACH SPECTATORS ISTAT=30 CALL HWSSPC ENDIF IF (FROST) THEN C---BAD JET: RESTORE PARTONS AND RE-EVOLVE DO 120 I=1,NRHEP 120 ISTHEP(IRHEP(I))=IRST(I) GOTO 10 ENDIF C---CONNECT COLOURS CALL HWBCON ISTAT=40 LASHEP=NHEP IF (HARDME) THEN C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E- IF (IPROC/10.EQ.10) CALL HWBDED(2) C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS IF (IPRO.EQ.90) CALL HWBDIS(2) C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2) ENDIF C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD C IT MIGHT NEED RESHOWERING IF (NHEP.GT.LASHEP) THEN LASHEP=NHEP GOTO 10 ENDIF 999 RETURN END CDECK ID>, HWBGUP. *CMZ :- -16/07/02 09.40.25 by Peter Richardson *-- Author : Peter Richardson C---------------------------------------------------------------------- SUBROUTINE HWBGUP(ISTART,ICMF) C---------------------------------------------------------------------- C Makes the colour connections and performs the parton shower C for events read in from the GUPI (Generic User Process Interface) C event common block C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP, & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP), & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP), & SPINUP(MAXNUP) C--Local variables INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL LOGICAL FOUND COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP) INTEGER ILOC,JLOC C--now we need to do the colour connections 20 ISTART = ISTART+1 IF(ISTART.GT.NHEP) GOTO 30 IF(ISTART.EQ.ICMF) ISTART = ISTART+1 IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20 K = ISTART J = ILOC(K) IF(ICOLUP(1,J).NE.0) THEN JCOL = 1 ICOL = ICOLUP(1,J) ELSE JCOL = 2 ICOL = ICOLUP(2,J) ENDIF IF(ICOL.EQ.0) THEN JMOHEP(2,K) = K JDAHEP(2,K) = K GOTO 20 ENDIF C--now search for the partner C--first search for the flavour partner if not looking for colour partner C--search for the flavour partner of the particle C--this must be set or HERWIG won't work 10 IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20 IF(ICOL.EQ.0) THEN FOUND = .FALSE. C--look for unpaired particle DO 15 I=1,NUP IF(JLOC(I).EQ.0) GOTO 15 IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15 IF(JLOC(I).EQ.ISTART) GOTO 15 IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15 C--antiflavour partner IF(JDAHEP(2,JLOC(I)).EQ.0) THEN C--pair incoming particle with outgoing particle C-- or outgoing antiparticle with outgoing particle IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND. & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR. & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN FOUND = .TRUE. JCOL = 1 C--pair incoming particle with incoming antiparticle C-- or outgoing antiparticle with incoming antiparticle ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND. & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR. & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN FOUND = .TRUE. JCOL = 2 ENDIF C--make the connection IF(FOUND) THEN JMOHEP(2,K) = JLOC(I) JDAHEP(2,JLOC(I)) = K ENDIF ENDIF C--flavour partner IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN C--pair incoming antiparticle with outgoing antiparticle C-- or outgoing particle with outgoing antiparticle IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND. & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR. & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN FOUND = .TRUE. JCOL = 2 C--pair incoming antiparticle with incoming particle C-- or outgoing particle with incoming particle ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND. & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR. & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN FOUND = .TRUE. JCOL = 1 ENDIF C--make the connection IF(FOUND) THEN JDAHEP(2,K) = JLOC(I) JMOHEP(2,JLOC(I)) = K ENDIF ENDIF C--set up the search for the next partner IF(FOUND) THEN FOUND = .FALSE. ICOL = ICOLUP(JCOL,I) K = JLOC(I) J = I GOTO 10 ENDIF 15 CONTINUE C--if no other choice then connect to the first particle in the loop IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN JDAHEP(2,K) = ISTART JMOHEP(2,ISTART) = K ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN JMOHEP(2,K) = ISTART JDAHEP(2,ISTART) = K ELSE CALL HWWARN('HWBGUP',100) GOTO 999 ENDIF GOTO 20 ENDIF C--now the bit to find colour partners FOUND = .FALSE. C--special for particle from a decaying coloured particle IF(MOTHUP(1,J).NE.0) THEN IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN JDAHEP(2,K) = JLOC(MOTHUP(1,J)) JMOHEP(2,K) = JLOC(MOTHUP(1,J)) GOTO 20 ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN JDAHEP(2,K) = JLOC(MOTHUP(1,J)) JMOHEP(2,K) = JLOC(MOTHUP(1,J)) GOTO 20 ENDIF ENDIF ENDIF C--search for the partner DO I=1,NUP IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR. & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN JDAHEP(2,K) = JLOC(I) JMOHEP(2,JLOC(I)) = K FOUND = .TRUE. ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR. & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN JMOHEP(2,K) = JLOC(I) JDAHEP(2,JLOC(I)) = K FOUND = .TRUE. ENDIF IF(FOUND) JCOL = 2 ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR. & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN JDAHEP(2,K) = JLOC(I) JMOHEP(2,JLOC(I)) = K FOUND = .TRUE. ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR. & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN JMOHEP(2,K) = JLOC(I) JDAHEP(2,JLOC(I)) = K FOUND = .TRUE. ENDIF IF(FOUND) JCOL = 1 ENDIF IF(FOUND) THEN K = JLOC(I) J = I ICOL = ICOLUP(JCOL,I) GOTO 10 ENDIF ENDDO C--special for self connected gluons IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND. & ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN JMOHEP(2,K) = K JDAHEP(2,K) = K C--options for self connected gluons IF(LHGLSF) THEN CALL HWWARN('HWBGUP',1) ELSE CALL HWWARN('HWBGUP',101) GOTO 999 ENDIF GOTO 20 ENDIF C--perform the shower 30 CALL HWBGEN C--recompute spectator etc if process was direct photoproduction J=JDAHEP(1,1) IF (J.LE.0) RETURN IF (IDHEP(J).NE.22) RETURN DO I=J+1,NHEP IF (IDHEP(I).EQ.22.AND.ISTHEP(I).EQ.3) THEN K=I GOTO 40 ENDIF ENDDO RETURN 40 CALL HWVEQU(4,PHEP(1,K),PHEP(1,J)) CALL HWVSUM(4,PHEP(1,K),PHEP(1,2),PHEP(1,3)) CALL HWUMAS(PHEP(1,3)) J=JDAHEP(2,1) CALL HWVDIF(4,PHEP(1,1),PHEP(1,K),PHEP(1,J)) CALL HWUMAS(PHEP(1,J)) 999 RETURN END CDECK ID>, HWBJCO. *CMZ :- -30/09/02 09.19.58 by Peter Richardson *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBJCO C----------------------------------------------------------------------- C COMBINES JETS WITH REQUIRED KINEMATICS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0, & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2), & PT(3),PA(5),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC, & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5),HWUSQR 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,HWUSQR PARAMETER (EPS=1.D-4) IF (IERROR.NE.0) RETURN AZCOR=AZSOFT.OR.AZSPIN LJET=131 10 IJET(1)=1 20 IJ1=IJET(1) DO 40 IHEP=IJ1,NHEP IST=ISTHEP(IHEP) IF (IST.EQ.137.OR.IST.EQ.138) IST=133 IF (IST.EQ.LJET) THEN C---FOUND AN UNBOOSTED JET - FIND PARTNERS IP=JMOHEP(1,IHEP) ICM=JMOHEP(1,IP) DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15 DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1 IF (IST.EQ.131) THEN IP1=JMOHEP(1,ICM) IP2=JMOHEP(2,ICM) ELSE IP1=JDAHEP(1,ICM) IP2=JDAHEP(2,ICM) ENDIF IF (IP1.NE.IP) THEN CALL HWWARN('HWBJCO',100) GOTO 999 ENDIF NP=0 DO 30 JHEP=IP1,IP2 NP=NP+1 IPAR(NP)=JHEP 30 IJET(NP)=JDAHEP(1,JHEP) GOTO 50 ENDIF 40 CONTINUE C---NO MORE JETS? IF (LJET.EQ.131) THEN LJET=133 GOTO 10 ENDIF RETURN 50 IF (LJET.EQ.131) THEN C---SPACELIKE JETS: FIND SPACELIKE PARTONS IF (NP.NE.2) THEN CALL HWWARN('HWBJCO',103) GOTO 999 ENDIF C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME IF (DISPRO.AND.BREIT) THEN IP=2 IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP) CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB) CALL HWUMAS(PB) C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG IF (PB(5)**2.LT.1.D-2) THEN CALL HWWARN('HWBJCO',102) GOTO 999 ENDIF CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR) CALL HWVSUM(4,PB,PBR,PBR) CALL HWUMAS(PBR) CALL HWULOF(PBR,PB,PB) CALL HWUROT(PB,ONE,ZERO,RBR) ENDIF PTX=0. PTY=0. PF=1.D0 DO 90 IP=1,2 MHEP=IJET(IP) IF (JDAHEP(1,MHEP).EQ.0) THEN C---SPECIAL FOR NON-PARTON JETS IHEP=MHEP GOTO 70 ELSE IST=134+IP DO 60 IHEP=MHEP,NHEP 60 IF (ISTHEP(IHEP).EQ.IST) GOTO 70 C---COULDN'T FIND SPACELIKE PARTON CALL HWWARN('HWBJCO',101) GOTO 999 ENDIF 70 CALL HWVSCA(3,PF,PHEP(1,IHEP),PS) IF (PTINT(3,IP).GT.ZERO) THEN C---ADD INTRINSIC PT PT(1)=PTINT(1,IP) PT(2)=PTINT(2,IP) PT(3)=0. CALL HWUROT(PS, ONE,ZERO,RS) CALL HWUROB(RS,PT,PT) CALL HWVSUM(3,PS,PT,PS) ENDIF JP=IJET(IP)+1 IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN C---ALIGN CONE WITH INTERFERING PARTON CALL HWUROT(PS, ONE,ZERO,RS) CALL HWUROF(RS,PHEP(1,JP),PR) PTCON=PR(1)**2+PR(2)**2 KP=JMOHEP(2,JP) IF (KP.EQ.0) THEN CALL HWWARN('HWBJCO',1) PTINF=0. ELSE CALL HWVEQU(4,PHEP(1,KP),PB) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PB,PB) CALL HWUROF(RBR,PB,PB) ENDIF PTINF=PB(1)**2+PB(2)**2 IF (PTINF.LT.EPS) THEN C---COLLINEAR JETS: ALIGN CONES KP=JDAHEP(1,KP)+1 C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500! IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1).GE.141 $ .AND.ISTHEP(KP-1).LE.144) THEN C---END FIX CALL HWVEQU(4,PHEP(1,KP),PB) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PB,PB) CALL HWUROF(RBR,PB,PB) ENDIF PTINF=PB(1)**2+PB(2)**2 ELSE PTINF=0. ENDIF ENDIF ENDIF IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN CN=1./SQRT(PTINF*PTCON) CP=CN*(PR(1)*PB(1)+PR(2)*PB(2)) SP=CN*(PR(1)*PB(2)-PR(2)*PB(1)) ELSE CALL HWRAZM( ONE,CP,SP) ENDIF ELSE CALL HWRAZM( ONE,CP,SP) ENDIF C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT) CALL HWUROT(PS,CP,SP,RS) IHEP=IJET(IP) KHEP=JDAHEP(2,IHEP) IF (KHEP.LT.IHEP) KHEP=IHEP IEND(IP)=KHEP DO 80 JHEP=IHEP,KHEP CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP)) 80 CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP)) PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP) ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2 C---REDEFINE HARD CM PTX=PTX+PHEP(1,IHEP) PTY=PTY+PHEP(2,IHEP) 90 PF=-PF PHEP(1,ICM)=PTX PHEP(2,ICM)=PTY C---special for DIS: keep lepton momenta fixed IF (DISPRO) THEN IP1=JMOHEP(1,ICM) IP2=JDAHEP(1,ICM) IJT=IJET(1) C---IJT will be used to store lepton momentum transfer CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT)) CALL HWUMAS(PHEP(1,IJT)) IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN IDHW(IJT)=200 ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN IDHW(IJT)=199 ELSE IDHW(IJT)=198 ENDIF IDHEP(IJT)=IDPDG(IDHW(IJT)) ISTHEP(IJT)=3 C---calculate boost for struck parton C PC is momentum of outgoing parton(s) IP2=JDAHEP(2,ICM) IF (.NOT.DISLOW) THEN C---FOR heavy QQbar PQ and PC are old and new QQbar momenta CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ) CALL HWUMAS(PQ) PC(5)=PQ(5) ELSE PC(5)=PHEP(5,JDAHEP(1,IP2)) ENDIF CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC) ET(1)=ET(2) C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY IF (BREIT) THEN ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2 PM0=PHEP(5,IJT) PP0=-PM0 ELSE ET(2)=PC(1)**2+PC(2)**2+PC(5)**2 PP0=PHEP(4,IJT)+PHEP(3,IJT) PM0=PHEP(4,IJT)-PHEP(3,IJT) ENDIF ET0=(PP0*PM0)+ET(1)-ET(2) DET=ET0**2-4.*(PP0*PM0)*ET(1) IF (DET.LT.ZERO) THEN FROST=.TRUE. RETURN ENDIF ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2)) PB(1)=0. PB(2)=0. PB(5)=2.D0 PB(3)=ALF-(1./ALF) PB(4)=ALF+(1./ALF) DO 100 IHEP=IJET(2),IEND(2) CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP)) C---BOOST FROM BREIT FRAME IF NECESSARY IF (BREIT) THEN CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP)) CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP)) ENDIF 100 ISTHEP(IHEP)=ISTHEP(IHEP)+10 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP) DO 110 IHEP=IJET(2),IEND(2) 110 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP)) IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100 CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC) CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM)) CALL HWUMAS(PHEP(1,ICM)) ELSEIF (IPRO/10.EQ.5) THEN C Special to preserve photon momentum ETC=PTX**2+PTY**2+PHEP(5,ICM)**2 ET0=ETC+ET(1)-ET(2) DET=ET0**2-4.*ETC*ET(1) IF (DET.LT.ZERO) THEN FROST=.TRUE. RETURN ENDIF ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2)) PB(1)=0. PB(2)=0. PB(3)=ALF-1./ALF PB(4)=ALF+1./ALF PB(5)=2. IJT=IJET(2) DO 120 IHEP=IJT,IEND(2) CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP)) 120 ISTHEP(IHEP)=ISTHEP(IHEP)+10 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP) DO 130 IHEP=IJT,IEND(2) 130 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP)) IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100 ISTHEP(IJET(1))=ISTHEP(IJET(1))+10 CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM)) ELSE C--change to preserve either long mom or rapidity rather than long mom C--by PR and BRW 30/9/02 C--BRW fix 6/11/08: reset CM pL (may have been rescaled already) PHEP(3,ICM)=PHEP(3,IP1)+PHEP(3,IP2) C--End BRW fix 6/11/08 IF (PRESPL) THEN C--PRESERVE LONG MOM OF CMF PHEP(4,ICM)= & SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2) ELSE C--PRESERVE RAPIDITY OF CMF C--BRW fix 6/11/08: reset CM E (may have been rescaled already) PHEP(4,ICM)=PHEP(4,IP1)+PHEP(4,IP2) C--End BRW fix 6/11/08 DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2 & -PHEP(3,ICM)**2)) CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM)) ENDIF C---NOW BOOST TO REQUIRED Q**2 AND X-F PP0=PHEP(4,ICM)+PHEP(3,ICM) PM0=PHEP(4,ICM)-PHEP(3,ICM) ET0=(PP0*PM0)+ET(1)-ET(2) DET=ET0**2-4.*(PP0*PM0)*ET(1) IF (DET.LT.ZERO) THEN FROST=.TRUE. RETURN ENDIF DET=HWUSQR(DET)+ET0 AL(1)= 2.*PM0*PP(1)/DET AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET) PB(1)=0. PB(2)=0. PB(5)=2. DO 160 IP=1,2 PB(3)=AL(IP)-(1./AL(IP)) PB(4)=AL(IP)+(1./AL(IP)) IJT=IJET(IP) DO 140 IHEP=IJT,IEND(IP) CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP)) 140 ISTHEP(IHEP)=ISTHEP(IHEP)+10 CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP) DO 150 IHEP=IJT,IEND(IP) 150 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP)) IF (IEND(IP).GT.IJT+1) THEN ISTHEP(IJT+1)=100 ELSEIF (IEND(IP).EQ.IJT) THEN C---NON-PARTON JET ISTHEP(IJT)=3 ENDIF 160 CONTINUE ENDIF ISTHEP(ICM)=120 ELSE C---TIMELIKE JETS C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC C RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN CALL HWVEQU(5,PHEP(1,ICM),PLAB) CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM)) CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM)) DO 165 IP=1,NP CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP))) CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP))) 165 CONTINUE ENDIF C special for DIS: preserve outgoing lepton momentum IF (DISPRO) THEN CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1))) ISTHEP(IJET(1))=1 LP=2 ELSE CALL HWVEQU(5,PHEP(1,ICM),PC) C--- PQ AND PC ARE OLD AND NEW PARTON CM CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ) PQ(5)=PHEP(5,ICM) IF (NP.GT.2) THEN DO 170 KP=3,NP 170 CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ) ENDIF LP=1 ENDIF IF (.NOT.DISLOW) THEN C---FIND JET CM MOMENTA ECM=PQ(5) EMS=0. JETRAD=.FALSE. DO 180 KP=LP,NP EMJ=PHEP(5,IJET(KP)) EMP=PHEP(5,IPAR(KP)) JETRAD=JETRAD.OR.EMJ.NE.EMP EMS=EMS+EMJ PM(KP)= EMJ**2 C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2 IF (PJ(KP).LE.ZERO) THEN C--BRW FIX 12/06/08 IF (PJ(KP).GT.-EPS*EPS) THEN PJ(KP)=ZERO ELSE CALL HWWARN('HWBJCO',104) GOTO 999 ENDIF C--END FIX ENDIF 180 CONTINUE PF=1. IF (JETRAD) THEN C---JETS DID RADIATE IF (EMS.GE.ECM) THEN FROST=.TRUE. GOTO 240 ENDIF DO 200 NE=1,NETRY EMS=-ECM DMS=0. DO 190 KP=LP,NP ES=SQRT(PF*PJ(KP)+PM(KP)) EMS=EMS+ES 190 DMS=DMS+PJ(KP)/ES DPF=2.*EMS/DMS IF (DPF.GT.PF) DPF=0.9*PF PF=PF-DPF 200 IF (ABS(DPF).LT.EPS) GOTO 210 CALL HWWARN('HWBJCO',105) GOTO 999 ENDIF 210 CONTINUE ENDIF C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PC,PC) CALL HWUROF(RBR,PC,PC) IF (.NOT.DISLOW) THEN CALL HWULOF(PBR,PQ,PQ) CALL HWUROF(RBR,PQ,PQ) ENDIF ENDIF DO 230 IP=LP,NP C---FIND CM ROTATION FOR JET IP IF (.NOT.DISLOW) THEN CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PR,PR) CALL HWUROF(RBR,PR,PR) ENDIF C--Modified by MHS 17/08/05 to do unboost in 2 stages (trans,long) PA(1)=PQ(1) PA(2)=PQ(2) PA(3)=ZERO PA(5)=SQRT(PQ(3)**2+PQ(5)**2) PA(4)=PQ(4) CALL HWULOF(PA,PR,PR) PA(1)=ZERO PA(2)=ZERO PA(3)=PQ(3) PA(4)=PA(5) PA(5)=PQ(5) CALL HWULOF(PA,PR,PR) C--End mod CALL HWUROT(PR, ONE,ZERO,RR) PR(1)=ZERO PR(2)=ZERO PR(3)=SQRT(PF*PJ(IP)) PR(4)=SQRT(PF*PJ(IP)+PM(IP)) PR(5)=PHEP(5,IJET(IP)) CALL HWUROB(RR,PR,PR) C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans) PA(1)=ZERO PA(2)=ZERO PA(3)=PC(3) PA(5)=PC(5) PA(4)=SQRT(PA(3)**2+PA(5)**2) CALL HWULOB(PA,PR,PR) PA(1)=PC(1) PA(2)=PC(2) PA(3)=ZERO PA(5)=PA(4) PA(4)=PC(4) CALL HWULOB(PA,PR,PR) C--End mod ELSE CALL HWVEQU(5,PC,PR) ENDIF C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP KP=IJET(IP)+1 IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN C---ALIGN CONE WITH INTERFERING PARTON CALL HWUROT(PR, ONE,ZERO,RS) JP=JMOHEP(2,KP) IF (JP.EQ.0) THEN CALL HWWARN('HWBJCO',2) PTINF=0. ELSE CALL HWVEQU(4,PHEP(1,JP),PS) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PS,PS) CALL HWUROF(RBR,PS,PS) ENDIF CALL HWUROF(RS,PS,PS) PTINF=PS(1)**2+PS(2)**2 IF (PTINF.LT.EPS) THEN C---COLLINEAR JETS: ALIGN CONES JP=JDAHEP(1,JP)+1 C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500! IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1).GE.141 $ .AND.ISTHEP(JP-1).LE.144) THEN C---END FIX CALL HWVEQU(4,PHEP(1,JP),PS) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PS,PS) CALL HWUROF(RBR,PS,PS) ENDIF CALL HWUROF(RS,PS,PS) PTINF=PS(1)**2+PS(2)**2 ELSE PTINF=0. ENDIF ENDIF ENDIF CALL HWVEQU(4,PHEP(1,KP),PB) IF (DISPRO.AND.BREIT) THEN CALL HWULOF(PBR,PB,PB) CALL HWUROF(RBR,PB,PB) ENDIF PTCON=PB(1)**2+PB(2)**2 IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN CN=1./SQRT(PTINF*PTCON) CP=CN*(PS(1)*PB(1)+PS(2)*PB(2)) SP=CN*(PS(1)*PB(2)-PS(2)*PB(1)) ELSE CALL HWRAZM( ONE,CP,SP) ENDIF ELSE CALL HWRAZM( ONE,CP,SP) ENDIF CALL HWUROT(PR,CP,SP,RS) C---FIND BOOST FOR JET IP ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/ & (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5)))) PB(1)=0. PB(2)=0. PB(3)=ALF-(1./ALF) PB(4)=ALF+(1./ALF) PB(5)=2. IHEP=IJET(IP) KHEP=JDAHEP(2,IHEP) IF (KHEP.LT.IHEP) KHEP=IHEP DO 220 JHEP=IHEP,KHEP CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP)) CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP)) C---BOOST FROM BREIT FRAME IF NECESSARY IF (DISPRO.AND.BREIT) THEN CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP)) CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP)) CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP)) ENDIF CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP)) C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132 $ .OR.IDHW(JHEP).EQ.59)) $ CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP)) C--END FIX 220 ISTHEP(JHEP)=ISTHEP(JHEP)+10 IF (KHEP.GT.IHEP+1) THEN ISTHEP(IHEP+1)=100 ELSEIF (KHEP.EQ.IHEP) THEN C---NON-PARTON JET ISTHEP(IHEP)=190 ENDIF 230 CONTINUE IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120 C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME 240 IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM)) CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM)) DO 260 IP=1,NP CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP))) CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP))) CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP))) C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX IF (ISTHEP(IJET(IP)).EQ.190) $ CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP))) CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP))) IF (ISTHEP(IJET(IP)).EQ.190) $ CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP))) C---END FIX IF (JDAHEP(1,IJET(IP)).GT.0) THEN IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1)) CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1)) ENDIF DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP)) CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP)) 250 CONTINUE ENDIF 260 CONTINUE ENDIF IF (FROST) RETURN ENDIF GOTO 20 999 RETURN END CDECK ID>, HWBMAS. *CMZ :- -26/04/91 11.11.54 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBMAS C----------------------------------------------------------------------- C Passes backwards through a jet cascade calculating the masses C and magnitudes of the longitudinal and transverse three momenta. C Components given relative to direction of parent for a time-like C vertex and with respect to z-axis for space-like vertices. C C On input PPAR(1-5,*) contains: C (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external)) C C On output PPAR(1-5,*) (if TMPAR(*)), containts: C (P-trans,Xi or Xilast,P-long,E,M) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX, $ EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K EXTERNAL HWUSQR IF (IERROR.NE.0) RETURN IF (NPAR.GT.2) THEN DO 30 MPAR=NPAR-1,3,-2 JPAR=MPAR C Find parent and partner of this branch IPAR=JMOPAR(1,JPAR) KPAR=JPAR+1 C Determine type of branching IF (TMPAR(IPAR)) THEN C Time-like branching C Compute mass of parent EXI=PPAR(1,JPAR)*PPAR(1,KPAR) PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI C Compute three momentum of parent PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR) PPAR(3,IPAR)=HWUSQR(PISQ) C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN Z=PPAR(4,JPAR)/PPAR(4,IPAR) ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN))) $ /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN))) NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR)) EMI=PPAR(5,IPAR) EMJ=PPAR(5,JPAR) EMK=PPAR(5,KPAR) ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)), $ (EMI+EMJ-EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI)) ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)), $ (EMI-EMJ+EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI)) C=2*RMASS(IDPAR(JPAR))**2/EMI Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO) $ +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5 Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5 Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI) PPAR(4,JPAR)=Z*PPAR(4,IPAR) PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR) PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ) PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK) PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR)) IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR) IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR) C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO DO 20 J=JPAR+2,NPAR-1,2 I=J 10 I=JMOPAR(1,I) IF (I.GT.IPAR) GOTO 10 IF (I.EQ.IPAR) THEN I=JMOPAR(1,J) K=J+1 POLD=PPAR(3,J)+PPAR(3,K) EOLD=PPAR(4,J)+PPAR(4,K) PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I)) ENEW=PPAR(4,I) A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I) B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I) PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J) PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A PPAR(3,K)=PNEW-PPAR(3,J) PPAR(4,K)=ENEW-PPAR(4,J) PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K)) $ /(PPAR(4,J)*PPAR(4,K)) IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J) IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J) ENDIF 20 CONTINUE ENDIF C Compute daughter' transverse and longitudinal momenta PJPK=PPAR(3,JPAR)*PPAR(3,KPAR) EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ PPAR(1,JPAR)=HWUSQR(PTSQ) PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ) PPAR(1,KPAR)=-PPAR(1,JPAR) PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR) ELSE C Space-like branching C Re-arrange such that JPAR is time-like IF (TMPAR(KPAR)) THEN KPAR=JPAR JPAR=JPAR+1 ENDIF C Compute time-like branch PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR) & -PPAR(5,JPAR) PPAR(1,JPAR)=HWUSQR(PTSQ) PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR) PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR) PPAR(5,IPAR)=0. PPAR(1,KPAR)=0. ENDIF C Reset Xi to Xilast PPAR(2,KPAR)=PPAR(2,IPAR) 30 CONTINUE ENDIF DO 40 IPAR=2,NPAR 40 PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR)) PPAR(1,2)=0. PPAR(2,2)=0. END CDECK ID>, HWBRAN. *CMZ :- -14/10/99 18.04.56 by Mike Seymour *-- Author : Bryan Webber & Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWBRAN(KPAR) C----------------------------------------------------------------------- C BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS C INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM, & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN, & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL, & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI, & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP, & JHEP,M,NF,NN,IREJ,NREJ,ITOP EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR SAVE BETA0,BETAP,SQRK SAVE ISUD DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/ IF (IERROR.NE.0) RETURN C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A C QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N) IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN DO 100 M=3,6 BETA0(M)=(11.*CAFAC-2.*M)*0.5 100 BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M) & /BETA0(M)*0.25/PIFAC DO 120 N=1,5 DO 110 M=4,6 IF (M.LE.N) THEN SQRK(M,N)=ONE ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN NF=M IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1 SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/ $ (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1)) ELSE SQRK(M,N)=SQRK(M-1,N)* $ ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/ $ (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1)) ENDIF 110 CONTINUE 120 CONTINUE ENDIF ID=IDPAR(KPAR) C--TEST FOR PARTON TYPE IF (ID.LE.13) THEN JD=ID IS=ISUD(ID) ELSEIF (ID.GE.209.AND.ID.LE.220) THEN JD=ID-208 IS=7 ELSE IS=0 END IF QNOW=-1. IF (IS.NE.0) THEN C--TIMELIKE PARTON BRANCHING ENOW=PPAR(4,KPAR) XIPREV=PPAR(2,KPAR) IF (JMOPAR(1,KPAR).EQ.0) THEN EPREV=PPAR(4,KPAR) ELSE EPREV=PPAR(4,JMOPAR(1,KPAR)) ENDIF C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED QMAX=0 QLST=PPAR(1,KPAR) IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY MPAR=KPAR 1 IF (JMOPAR(1,MPAR).NE.0) THEN IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN MPAR=JMOPAR(1,MPAR) GOTO 1 ENDIF ENDIF C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER IF (MPAR.EQ.2) THEN JHEP=0 IF (ID.LT.7) THEN IHEP=JDAHEP(2,JCOPAR(1,1)) IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP) ELSE IHEP=JMOHEP(2,JCOPAR(1,1)) IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP) ENDIF IF (IHEP.GT.0.AND.JHEP.GT.0) THEN QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP)) & *(ENOW/PPAR(4,2))**2 ELSE C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET C (CAN HAPPEN IN SUSY EVENTS) QMAX=EMSCA**2 ENDIF ELSE QMAX=ENOW**2*PPAR(2,MPAR) ENDIF C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING MPAR=KPAR 2 IF (JMOPAR(1,MPAR).NE.0) THEN IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR. & IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN MPAR=JMOPAR(1,MPAR) GOTO 2 ENDIF ENDIF QLST=ENOW**2*PPAR(2,MPAR) QMAX=SQRT(MAX(ZERO,MIN( & QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))) QLST=SQRT(MIN( & QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))) ENDIF NTRY=0 5 NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWBRAN',100) GOTO 999 ENDIF IF (ID.EQ.13) THEN C--GLUON -> QUARK+ANTIQUARK OPTION IF (QLST.GT.QCDL3) THEN DO 8 N=1,NFLAV QKTHR=2.*HWBVMC(N) IF (QLST.GT.QKTHR) THEN RN=HWRGEN(N) IF (SUDORD.NE.1) THEN C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES NF=3 DO 200 M=MAX(3,N),NFLAV 200 IF (QLST.GT.RMASS(M)) NF=M C---CALCULATE THE FORM FACTOR IF (NF.EQ.MAX(3,N)) THEN SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/ $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF)) SLST=SFNL ELSE SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/ $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF)) SLST=SFNL*SQRK(NF,N) ENDIF ENDIF IF (RN.GT.1.E-3) THEN QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF) ELSE QQBAR=QCDL3 ENDIF IF (SUDORD.NE.1) THEN C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES IF (RN.GE.SFNL) THEN NN=NF ELSEIF (RN.GE.SLST) THEN NN=MAX(3,N) DO 210 M=MAX(3,N)+1,NF-1 210 IF (RN.GE.SLST/SQRK(M,N)) NN=M ELSE NN=0 QQBAR=QCDL3 ENDIF IF (NN.GT.0) THEN IF (NN.EQ.NF) THEN TARG=HWUALF(1,QLST) ELSE TARG=HWUALF(1,RMASS(NN+1)) RN=RN/SLST*SQRK(NN+1,N) ENDIF TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN)) C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY 7 QQBAR=MAX(QQBAR,HALF*QKTHR) ALF=HWUALF(1,QQBAR) IF (ABS(ALF-TARG).GT.ACCUR) THEN NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWBRAN',101) GOTO 999 ENDIF QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG) $ /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF))) GOTO 7 ENDIF ENDIF ENDIF IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN QNOW=QQBAR ID2=N ENDIF ELSE GOTO 9 ENDIF 8 CONTINUE ENDIF C--GLUON->DIQUARKS OPTION 9 IF (QLST.LT.QDIQK) THEN IF (PDIQK.NE.ZERO) THEN RN=HWRGEN(0) DQQ=QLST*EXP(-RN/PDIQK) IF (DQQ.GT.QNOW) THEN IF (DQQ.GT.2.*RMASS(115)) THEN QNOW=DQQ ID2=115 ENDIF ENDIF ENDIF ENDIF ENDIF C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH C IS CAPABLE OF BEING THE HARDEST SO FAR NREJ=1 IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2 C--BRANCHING ID->ID+GLUON QGTHR=HWBVMC(ID)+HWBVMC(13) IF (QLST.GT.QGTHR) THEN DO 300 IREJ=1,NREJ RN=HWRGEN(1) SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER) IF (RN.EQ.ZERO) THEN SNOW=2. ELSE SNOW=SLST/RN ENDIF IF (SNOW.LT.ONE) THEN QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER) C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD IF (QSUD.GT.QLST) THEN SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1) IF (QSUD.GT.QLST) THEN CALL HWWARN('HWBRAN',1) QSUD=-1 ENDIF ENDIF IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN ID2=13 QNOW=QSUD ENDIF ENDIF 300 CONTINUE ENDIF C--BRANCHING ID->ID+PHOTON IF (ICHRG(ID).NE.0) THEN QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75)) IF (QMAX.GT.QGTHR) THEN DO 400 IREJ=1,NREJ RN=HWRGEN(2) IF (RN.EQ.ZERO) THEN QGAM=0 ELSE QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2 & +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN) IF (QGAM.GT.ZERO) THEN QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM)) ELSE QGAM=0 ENDIF ENDIF IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN ID2=59 QNOW=QGAM ENDIF 400 CONTINUE ENDIF ENDIF IF (QNOW.GT.ZERO) THEN C--BRANCHING HAS OCCURRED ZMIN=HWBVMC(ID2)/QNOW ZMAX=1.-ZMIN IF (ID.EQ.13) THEN IF (ID2.EQ.13) THEN C--GLUON -> GLUON + GLUON ID1=13 WMIN=ZMIN*ZMAX ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN) ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX)) C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX) C ACCORDING TO GLUON BRANCHING FUNCTION 10 Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0)) Z2=1.-Z1 ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2)) IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10 Z=Z1 ELSEIF (ID2.NE.115) THEN C--GLUON -> QUARKS ID1=ID2+6 ETEST=ZMIN**2+ZMAX**2 20 Z1=HWRUNI(0,ZMIN,ZMAX) Z2=1.-Z1 ZTEST=Z1*Z1+Z2*Z2 IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20 ELSE C--GLUON -> DIQUARKS ID2=HWRINT(115,117) ID1=ID2-6 Z1=HWRUNI(0,ZMIN,ZMAX) Z2=1.-Z1 ENDIF ELSE C--QUARK OR ANTIQUARK BRANCHING IF (ID2.EQ.13) THEN C--TO GLUON ZMAX=1.-HWBVMC(ID)/QNOW WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX)) ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN) ZRAT=ZMAX/ZMIN 30 Z1=ZMIN*ZRAT**HWRGEN(0) Z2=1.-Z1 ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2) IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30 ELSE C--TO PHOTON ZMIN= HWBVMC(59)/QNOW ZMAX=1-HWBVMC(ID)/QNOW ZRAT=ZMAX/ZMIN ETEST=1+(1-ZMIN)**2 40 Z1=ZMIN*ZRAT**HWRGEN(0) Z2=1-Z1 ZTEST=1+Z2*Z2 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40 ENDIF C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE Z=Z1 IF (JD.LE.6) THEN Z1=Z2 Z2=1.-Z2 ID1=ID ELSE ID1=ID2 ID2=ID ENDIF ENDIF C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES XI=(QNOW/ENOW)**2 IF (ID1.NE.59.AND.ID2.NE.59) THEN IF (ID.EQ.13.AND.ID1.NE.13) THEN QLAM=QNOW ELSE QLAM=QNOW*Z1*Z2 ENDIF IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR. & (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN C--BRANCHING REJECTED: REDUCE Q AND REPEAT QMAX=QNOW QLST=QNOW QNOW=-1. GOTO 5 ENDIF ENDIF C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION IF (ID.NE.13.OR.ID1.EQ.13) THEN QLAM=QNOW*Z1*Z2 REJFAC=1 IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS ITOP=JCOPAR(1,1) IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6 $ .OR.IDHW(ITOP).EQ.12)) THEN AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2 FF=0.5*(1-AW)*(1-2*AW+1/AW) CC=0.25*(1-AW)**2 X1=1-2*CC*Z*(1-Z)*XI X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z) & *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW) & /(1-2*Z*(1-Z)*XI))) C-----JACOBIAN FACTOR JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/( $ 4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI) C-----REJECTION FACTOR XCUT=2*GCUTME/PHEP(5,ITOP) IF (X3.GT.XCUT) REJFAC=FF*JJ & *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI) & /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1) & *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2 & +2*X3**2*(1-X1)) ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN C---COLOUR PARTNER IS ALSO OUTGOING X1=1-Z*(1-Z)*XI X2=0.5*(1+Z*(1-Z)*XI + $ (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI)) REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z)) $ *(1+(1-Z)**2)/(Z*XI) $ *(1-X1)*(1-X2)/(X1**2+X2**2) C---CHECK WHETHER IT IS IN THE OVERLAP REGION OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2) IF (OTHXI.LT.ONE) THEN OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2)) REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ)) $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI) $ *(1-X2)*(1-X1)/(X2**2+X1**2) ENDIF ELSE C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP) X1=1/(1+Z*(1-Z)*XI) X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI)) REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z)) $ *(1+(1-Z)**2)/(Z*XI) $ *(1-X1)*(1-X2)/ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2) C---CHECK WHETHER IT IS IN THE OVERLAP REGION OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/ $ (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))) OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2) IF (OTHXI.LT.OTHZ**2) THEN REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2) $ /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ))) $ *(1+OTHZ**2)/((1-OTHZ)*OTHXI) $ *(1-X1)*(1-X2)/ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2) ENDIF ENDIF ENDIF IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN QMAX=QNOW QLST=QNOW QNOW=-1. GOTO 5 ENDIF IF (QLAM.GT.HARDST) HARDST=QLAM ENDIF MPAR=NPAR+1 IDPAR(MPAR)=ID1 TMPAR(MPAR)=.TRUE. PPAR(1,MPAR)=QNOW*Z1 PPAR(2,MPAR)=XI PPAR(4,MPAR)=ENOW*Z1 NPAR=NPAR+2 IDPAR(NPAR)=ID2 TMPAR(NPAR)=.TRUE. PPAR(1,NPAR)=QNOW*Z2 PPAR(2,NPAR)=XI PPAR(4,NPAR)=ENOW*Z2 C---NEW MOTHER-DAUGHTER RELATIONS JDAPAR(1,KPAR)=MPAR JDAPAR(2,KPAR)=NPAR JMOPAR(1,MPAR)=KPAR JMOPAR(1,NPAR)=KPAR C---NEW COLOUR CONNECTIONS JCOPAR(3,KPAR)=NPAR JCOPAR(4,KPAR)=MPAR JCOPAR(1,MPAR)=NPAR JCOPAR(2,MPAR)=KPAR JCOPAR(1,NPAR)=KPAR JCOPAR(2,NPAR)=MPAR C ENDIF ENDIF IF (QNOW.LT.ZERO) THEN C--BRANCHING STOPS IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN PPAR(5,KPAR)=PPAR(5,2)**2 ELSE PPAR(5,KPAR)=RMASS(ID)**2 ENDIF PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR) IF (PMOM.LT.-1E-6) THEN CALL HWWARN('HWBRAN',104) GOTO 999 ENDIF IF (PMOM.LT.ZERO) PMOM=ZERO PPAR(3,KPAR)=SQRT(PMOM) JDAPAR(1,KPAR)=0 JDAPAR(2,KPAR)=0 JCOPAR(3,KPAR)=0 JCOPAR(4,KPAR)=0 ENDIF 999 RETURN END CDECK ID>, HWBRCN. *CMZ :- -31/03/00 17:54:05 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWBRCN C----------------------------------------------------------------------- C SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY C BASED ON HWBCON BY BRW C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDM2, & RHEP,IST2,ANTC,XHEP,IP,COLP LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2, & BVDEC3 LOGICAL IFGO C--logical functions to decide if baryon number violating C--BVDEC1 DELTAB=+1 BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR. & IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR. & IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6. & AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND. & IDHW(JDAHEP(2,IP)).LE.6 C--BVDEC2 DELTAB=-1 BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR. & IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR. & IDHW(IP).EQ.449).AND. & IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND. & IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND. & IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12 C--Neutralino and Chargino Decays BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND. & (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12. & .AND.IDHW(JDAHEP(2,IP)).LE.12)) C--Now the hard vertices BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12. & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12. & AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457 BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12. & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198. & AND.IDHW(JDAHEP(1,IP)).LE.207. & AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000 C--Those particles which are coloured COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR. & (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR. & (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59 C--Those particles which are anticoloured ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR. & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR. & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59 IF (IERROR.NE.0) RETURN C--Added 31/03/00 PR IF(NHEP.GT.NMXHEP) THEN CALL HWWARN('HWBRCN',101) GOTO 999 ENDIF COLP = 0 IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN JD = 0 DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4 JD = JD+1 IF(JD.NE.3) THEN JMOHEP(2,IHEP) = HRDCOL(1,JD) JDAHEP(2,IHEP) = HRDCOL(2,JD) ENDIF ENDDO COLUPD=.FALSE. DO IHEP=1,5 DO JHEP=1,2 HRDCOL(JHEP,IHEP)=0 ENDDO ENDDO ELSEIF(COLUPD) THEN RETURN ENDIF DO 110 IHEP=1,NHEP IST=ISTHEP(IHEP) JD =0 BVVUSE = .FALSE. BVVHRD = .FALSE. C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110 IF (JMOHEP(2,IHEP).EQ.0) THEN C---FIND COLOUR-CONNECTED PARTON IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN JC = JMOHEP(1,IHEP) ELSEIF(IST.EQ.155) THEN GOTO 110 ELSE JC=JMOHEP(1,IHEP) ENDIF IF (IST.NE.152) JC=JMOHEP(1,JC) C--Correction for BV IF(HRDCOL(1,1).NE.0) THEN IDP = IDHW(HRDCOL(1,1)) ELSE IDP = 0 ENDIF IDM = JMOHEP(1,JC) IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN JC=JMOHEP(2,JC) ELSE JD = JMOHEP(2,JC) JC = IDM IF(JC.EQ.JD) JD= JDAHEP(2,JC-1) BVVUSE = .TRUE. ENDIF C--NEW FOR BV HARD PROCESS ELSEIF(BVHRD(IDM)) THEN IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN JD = JMOHEP(2,JC) IDM2 = JDAHEP(2,HRDCOL(1,2)) IF(JD.EQ.IDM2) JD = HRDCOL(1,1) IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN JC = JMOHEP(2,JC) ELSEIF(JC.EQ.IDM2) THEN IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN JC = JMOHEP(2,JC) ELSE JMOHEP(2,IHEP)=JMOHEP(2,JC) GOTO 110 ENDIF ELSE JC = HRDCOL(1,1) BVVUSE = .TRUE. BVVHRD = .TRUE. IF(ACOLRD(IDHW(IHEP))) JC = JD IF(JC.EQ.IDM2) GOTO 110 ENDIF ELSE JC =JMOHEP(2,JC) BVVUSE = .TRUE. BVVHRD = .TRUE. ENDIF ELSEIF(BVHRD2(IDM)) THEN JD = JMOHEP(2,JC) IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN JMOHEP(2,IHEP)=JMOHEP(2,JC) GOTO 110 ENDIF IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1) BVVUSE=.TRUE. BVVHRD = .TRUE. IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN JC = JMOHEP(2,JC) ELSE JC = HRDCOL(1,1) ENDIF ELSE JC =JMOHEP(2,JC) ENDIF IF (JC.EQ.0) THEN CALL HWWARN('HWBCON',51) GOTO 110 ENDIF C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE IF (ISTHEP(JC).EQ.155) THEN IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN C---DECAYED BEFORE HADRONIZING IF(BVVHRD) THEN JHEP = JC ELSEIF(BVVUSE) THEN JHEP=JDAHEP(2,JC-1) ELSE JHEP=JMOHEP(2,JC) ENDIF IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN JHEP = JMOHEP(1,JMOHEP(1,JC)) IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN JC = JHEP JHEP = JDAHEP(2,JC-1) ELSE JHEP = 0 ENDIF ENDIF IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND. & ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110 ID=IDHW(JHEP) IF (ISTHEP(JHEP).EQ.155) THEN C---SPECIAL FOR GLUINO DECAYS IF (ID.EQ.449) THEN ID=IDHW(JC) IF(BVVUSE) THEN ID=IDHW(IHEP) IF(ID.LE.6.OR.ID.EQ.13.OR. & (ID.GE.115.AND.ID.LE.120)) THEN ID = 7 ELSE ID = 1 ENDIF ENDIF CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO) IF(IFGO) GOTO 999 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD ELSE JC=JDAHEP(2,JHEP) IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449) & JC=JDAHEP(1,JHEP) IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD ENDIF ELSE IF(BVVUSE) THEN IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR. & BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN JC = JD GOTO 100 ELSE JMOHEP(2,IHEP)=JHEP ID = IDHW(JHEP) IF((ID.GE.7.AND.ID.LE.12).OR. & (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP ENDIF ELSE C--new for particles connected to BV IDM = JMOHEP(1,JHEP) IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN JC = JHEP IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100 JMOHEP(2,IHEP)=JHEP GOTO 110 ENDIF C--new for top's from BV ID = IDHW(JC) IDP = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC))) IF((ID.EQ.6.AND.(BVDEC1(IDP))). & OR.(ID.EQ.12.AND.BVDEC2(IDP)). & OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN JMOHEP(2,IHEP)=JHEP IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP ELSE IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12. & AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR. & (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN JMOHEP(2,IHEP)=JHEP ELSE JMOHEP(2,IHEP)=JHEP IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR. & (.NOT.COLRD(IDHW(IHEP)).AND. & .NOT.ACOLRD(IDHW(JHEP)))) THEN IF(JDAHEP(2,JHEP).EQ.0) THEN JDAHEP(2,JHEP)=IHEP ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN JDAHEP(2,JHEP)=IHEP ENDIF ELSE IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP ENDIF ENDIF ENDIF ENDIF GOTO 110 ENDIF ELSE JC=JMOHEP(2,JC) ENDIF ENDIF 100 CONTINUE IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD & .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110 ENDIF IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC)) C--SEARCH IN THE JET IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND. & ISTHEP(IHEP).EQ.155) THEN JMOHEP(2,IHEP) = JC GOTO 110 ENDIF CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD) IF(COLP.NE.0) THEN JMOHEP(2,IHEP) = COLP IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)). & AND.JDAHEP(2,COLP).EQ.0) & JDAHEP(2,COLP) = IHEP IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND. & (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP ENDIF ENDIF ENDIF 110 CONTINUE C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash IHEP=1 130 IF (IHEP.LE.NHEP) THEN IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND. & (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN IF(JMOHEP(2,IHEP).NE.0) THEN IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP) & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP) ENDIF IF (JDAHEP(2,IHEP).NE.0) THEN IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP) & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP) ENDIF DO RHEP=1,NHEP IST=ISTHEP(RHEP) IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP) & JDAHEP(2,RHEP)=JMOHEP(2,IHEP) ENDDO DO RHEP=1,NHEP IST=ISTHEP(RHEP) IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP) & JMOHEP(2,RHEP) = JDAHEP(2,IHEP) ENDDO JMOHEP(2,IHEP)=IHEP JDAHEP(2,IHEP)=IHEP ENDIF IHEP=IHEP+1 GOTO 130 ENDIF C--Update the BV anticolour corrections DO 210 IHEP=1,NHEP+1 IF(IHEP.EQ.1) GOTO 210 IST2 = 0 IF(IHEP.EQ.NHEP+1) THEN ANTC = HRDCOL(1,1) IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210 IST=155 XHEP=HRDCOL(1,2) IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC)) IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC) ELSE ANTC = JDAHEP(2,IHEP-1) IF(ANTC.NE.0) IST2=ISTHEP(ANTC) IST=ISTHEP(IHEP) IDM = IDHW(IHEP) XHEP=IHEP ENDIF JC = 0 JHEP = 0 JD = 0 IF(IST.EQ.155.AND.IST2.EQ.155) THEN IDM = IDHW(XHEP) IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR. & BVHRD2(XHEP)) THEN JC=ANTC ID = IDHW(JC) JHEP = JC IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC) GOTO 200 ENDIF IF (ID.EQ.449) THEN C--SPECIAL FOR GLUINO DECAYS ID=IDHW(XHEP) IF(IHEP.EQ.NHEP+1) ID = 407 CALL HWBRC1(JC,ID,JHEP,.FALSE.,IFGO) IF(IFGO) GOTO 999 ELSE IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN JC=JDAHEP(1,JHEP) ELSE JC=JDAHEP(2,JHEP) ENDIF ENDIF C--SEARCH IN JET CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.) ANTC = COLP IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND. & COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN JMOHEP(2,COLP) = IHEP ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND. & IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN JDAHEP(2,COLP) = IHEP ELSEIF(IHEP.GT.NHEP.AND. & ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))). & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND. & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN JDAHEP(2,COLP) = IHEP ENDIF ENDIF ENDIF 200 CONTINUE IF(IHEP.EQ.NHEP+1) THEN IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN HRDCOL(1,1)=ANTC IF(JDAHEP(2,ANTC).EQ.IHEP) THEN IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)). & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2))) & THEN JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2)) ELSE JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2)) ENDIF ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2)) ENDIF ENDIF ELSEIF(IHEP.NE.1) THEN IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC ENDIF 210 CONTINUE C--Update BV decaying particles connections DO 310 IHEP=1,NHEP+1 IF(IHEP.EQ.1) GOTO 310 IF(IHEP.EQ.NHEP+1) THEN ANTC=HRDCOL(1,1) IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310 IST=155 XHEP=HRDCOL(1,2) IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC)) ELSE ANTC=JMOHEP(2,IHEP) IST=ISTHEP(IHEP) IDM = IDHW(IHEP) XHEP=IHEP ENDIF IST2 = 0 JC = 0 JD = 0 IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC) ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN IST2=ISTHEP(ANTC) ENDIF IF(IST.EQ.155.AND.IST2.EQ.155) THEN IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN C--FIND COLOUR CONNECTED PARTON JC = ANTC ID=IDHW(JC) JHEP = JC IF(BVDEC2(JHEP)) THEN ANTC=JC GOTO 300 ENDIF IF (ID.EQ.449) THEN ID=IDHW(XHEP) IF(IHEP.EQ.NHEP+1) ID = 401 C--SPECIAL FOR GLUINO DECAYS CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO) IF(IFGO) GOTO 999 ELSE IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN JC=JDAHEP(1,JHEP) ELSE JC=JDAHEP(2,JHEP) ENDIF ENDIF C--SEARCH IN JET CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.) ANTC = COLP IF(COLP.EQ.0) GOTO 300 IF(IHEP.LE.NHEP) THEN IF(JDAHEP(2,COLP).EQ.0) THEN JDAHEP(2,COLP) = JDAHEP(2,IHEP) ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN JDAHEP(2,COLP) = JDAHEP(2,IHEP) ENDIF ELSEIF(IHEP.GT.NHEP.AND. & ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND. & IDHW(JDAHEP(2,XHEP)).EQ.449). & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND. & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN JDAHEP(2,COLP) = IHEP ENDIF ENDIF ENDIF 300 CONTINUE IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC ELSEIF(IHEP.GT.NHEP) THEN IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC IF(ANTC.EQ.0) GOTO 310 IF(JDAHEP(2,ANTC).EQ.IHEP) THEN IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)). & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2))) & THEN JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2)) ELSE JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2)) ENDIF ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2)) ENDIF ENDIF 310 CONTINUE C--Update partons connected to decaying SUSY particle DO 400 IHEP=1,NHEP IST=ISTHEP(IHEP) C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE IF (IST.LT.145.OR.IST.GT.152) GOTO 400 IF(JMOHEP(2,IHEP).EQ.0) GOTO 400 IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN C--FIND THE COLOUR CONNECTED PARTON JC=JMOHEP(2,IHEP) ID=IDHW(JC) JHEP = JC IF(BVDEC2(JC).AND.IDHW(JC).NE.449) THEN IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12) & JMOHEP(2,IHEP)=JDAHEP(1,JC) GOTO 400 ENDIF IF (ID.EQ.449) THEN C--SPECIAL FOR GLUINO DECAYS ID=IDHW(IHEP) CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO) IF(IFGO) GOTO 999 ELSE ID=IDHW(IHEP) IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN JC=JDAHEP(1,JHEP) ELSE JC=JDAHEP(2,JHEP) IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1 ENDIF ENDIF C--SEARCH IN JET CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.) JMOHEP(2,IHEP) = COLP ENDIF 400 CONTINUE C--Update partons connected to decaying SUSY particle DO 500 IHEP=1,NHEP IST=ISTHEP(IHEP) C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE IF (IST.LT.145.OR.IST.GT.152) GOTO 500 IF(JDAHEP(2,IHEP).EQ.0) GOTO 500 IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN C--FIND THE COLOUR CONNECTED PARTON JC=JDAHEP(2,IHEP) ID=IDHW(JC) ID=IDHW(JC) IF (ID.EQ.449) THEN ID=IDHW(IHEP) C--SPECIAL FOR GLUINO DECAYS JHEP = JC CALL HWBRC1(JC,ID,JHEP,.FALSE.,IFGO) IF(IFGO) GOTO 999 ELSE IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN JC = JDAHEP(1,JC) ELSE JC=JDAHEP(2,JC) ENDIF ENDIF C--SEARCH IN THE JET CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.) IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP ENDIF 500 CONTINUE C--Flavour and anticolour connections in Rslash DO 610 IHEP=1,NHEP IST=ISTHEP(IHEP) IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610 JD = 0 BVVUSE = .FALSE. JC = JMOHEP(1,IHEP) IF(IST.NE.152) JC = JMOHEP(1,JC) IF(JC.EQ.0) THEN CALL HWWARN('HWBRCN',51) GOTO 610 ENDIF C--For particles which came from a top decay IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC))) C--flavour connect to self if needed IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN JDAHEP(2,IHEP) = IHEP GOTO 610 ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1) GOTO 610 ELSE JC = JD ENDIF ENDIF C--Decide if this came from a BV decay IDM = JMOHEP(1,JC) IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM). & OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN C--Do BV piece IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN IF(IDHW(JMOHEP(1,JC)).EQ.449.AND. & JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN JC = JDAHEP(2,JMOHEP(1,JC)-1) ELSE JC = JMOHEP(2,JMOHEP(1,JC)) ENDIF IF(ABS(IDHEP(JC)).LT.1000000) THEN IF(JDAHEP(1,JC).EQ.0) THEN JDAHEP(2,IHEP) = JC GOTO 610 ELSE GOTO 600 ENDIF ELSEIF(ABS(IDHEP(JC)).GT.1000000 & .AND.ISTHEP(JC).NE.155) THEN GOTO 610 ENDIF IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN JC = JDAHEP(1,JC) ELSE IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN JC = JDAHEP(1,JC) ELSE JC = JDAHEP(2,JC) ENDIF ENDIF ELSE C--For the hard process IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN JDAHEP(2,IHEP) = JDAHEP(2,JC) GOTO 610 ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN JD=HRDCOL(1,1) IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN JC = JDAHEP(2,JC) GOTO 600 ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN JC=JDAHEP(2,JC) GOTO 600 ENDIF IF(JDAHEP(2,JC).EQ.8) JC = JD ELSE JD=JMOHEP(2,JMOHEP(1,JC)) ENDIF IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND. & ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN JDAHEP(2,IHEP) = JD IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP ENDIF IF(ABS(IDHEP(JD)).GT.1000000 & .AND.ISTHEP(JD).NE.155) GOTO 610 IF(ISTHEP(JC).EQ.149) THEN JDAHEP(2,IHEP)=JC GOTO 610 ENDIF IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN JC = JDAHEP(1,JC) ELSE JC = JDAHEP(2,JC) ENDIF ENDIF C--SEARCH IN THE JET 600 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.) IF(COLP.NE.0) THEN IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN IF(ISTHEP(COLP).EQ.155) THEN JC = JDAHEP(2,COLP) ELSE JC = JDAHEP(2,JDAHEP(2,COLP)) ENDIF GOTO 600 ENDIF JDAHEP(2,IHEP) = COLP ENDIF ELSE C--check if it came from a top IF(ABS(IDHEP(JC)).EQ.6) THEN C--start the analysis again JC = JMOHEP(1,IHEP) IF(IST.NE.152) JC = JMOHEP(1,JC) JC = JDAHEP(2,JC) IF(JC.EQ.0) THEN CALL HWWARN('HWBRCN',52) GOTO 610 ENDIF IF(ISTHEP(JC).EQ.155) THEN IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN C---DECAYED BEFORE HADRONIZING JHEP=JDAHEP(2,JC-1) IF (JHEP.EQ.0) GO TO 610 ID=IDHW(JHEP) IF (ISTHEP(JHEP).EQ.155) THEN C---SPECIAL FOR GLUINO DECAYS IF (ID.EQ.449) THEN CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO) IF(IFGO) GOTO 999 ELSE JC=JDAHEP(2,JHEP) ENDIF ELSE IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP JDAHEP(2,IHEP) = JHEP GOTO 610 ENDIF ELSE JC=JDAHEP(2,JC-1) ENDIF ENDIF C--SEARCH IN JET CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.) IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP ELSE IF(ISTHEP(JMOHEP(1,JC)).EQ.155 & .AND.IDHW(JC).LE.6) THEN JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1) IF(JDAHEP(2,IHEP).NE.0) GOTO 610 ENDIF CALL HWWARN('HWBRCN',100) GOTO 610 ENDIF ENDIF 610 CONTINUE 999 RETURN END CDECK ID>, HWBRC1. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : PeterRichardson C----------------------------------------------------------------------- SUBROUTINE HWBRC1(JC,ID,JHEP,COL,IFGO) C----------------------------------------------------------------------- C--Function to find the right daugther of a decaying gluino C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID,JHEP,KC,JC LOGICAL COL,IFGO C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER C--Rparity take the first daughther IFGO = .FALSE. IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12 & .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN KC = JDAHEP(1,JHEP) GOTO 20 ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR. & (ID.GE.401.AND.ID.LE.406).OR. & (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR. & (ID.GE.115.AND.ID.LE.120)) THEN C---LOOK FOR ANTI(S)QUARK OR GLUON DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP) ID=IDHW(KC) IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR. & (ID.GE.419.AND.ID.LE.424)) GOTO 20 ENDDO ELSE C---LOOK FOR (S)QUARK OR GLUON DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP) ID=IDHW(KC) IF (ID.LE. 6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR. & (ID.GE.413.AND.ID.LE.418)) GOTO 20 ENDDO ENDIF C---COULDNT FIND ONE CALL HWWARN('HWBRC1',100) IFGO = .TRUE. RETURN 20 JC=KC END CDECK ID>, HWBRC2. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD) C----------------------------------------------------------------------- C--Function to search in the jet for the particle C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD FLA(IP) = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120). & OR.(IP.GE.401.AND.IP.LE.406). & OR.(IP.GE.413.AND.IP.LE.418)) AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114). & OR.(IP.GE.407.AND.IP.LE.412). & OR.(IP.GE.419.AND.IP.LE.424)) ID = IDHW(IHEP) COLP = 0 C--begining and end of jet IF(JDAHEP(1,JC).NE.0) THEN JC=JDAHEP(1,JC) JD=JDAHEP(2,JC) ELSE COLP = JC RETURN ENDIF IF (JD.LT.JC) JD=JC LHEP=0 IF(CON) THEN C--SEARCH FOR A COLOUR PARTNER DO 110 JHEP=JC,JD IDM = IDHW(JHEP) IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110 IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR. & (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110 IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN IF(BVVHRD.AND.AFLA(ID)) THEN CONTINUE ELSE RETURN ENDIF ENDIF IF(BVVUSE.AND.( & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)). & OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449)))) & GOTO 110 IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110 C---JOIN IHEP AND JHEP COLP=JHEP IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12. & AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN IF(IHEP.NE.HRDCOL(1,2).AND. & (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59) & .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59)) & .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59)))) & JDAHEP(2,JHEP)=IHEP RETURN 110 CONTINUE IF (LHEP.NE.0) COLP=LHEP C--Additional Baryon number violating piece IF(COLP.EQ.0) THEN IDM2= IDHW(JC) IF(JMOHEP(1,JC).LT.6) THEN IF(IDM2.LE.6) THEN IDM2= IDM2+6 ELSEIF(IDM2.GT.6) THEN IDM2=IDM2-6 ENDIF ENDIF IF(IHEP.EQ.HRDCOL(1,2).OR. & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59) & .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN QHEP = JD+1 12 QHEP = QHEP-1 IF(IDHEP(QHEP).EQ.0) GOTO 12 IF(IDHW(QHEP).EQ.59) THEN IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN COLP = IHEP RETURN ELSE GOTO 12 ENDIF ENDIF NCOUNT = 0 11 IF(JDAHEP(2,QHEP).NE.0) THEN IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND. & JDAHEP(2,QHEP).NE.QHEP) THEN IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN QHEP = JDAHEP(2,QHEP) NCOUNT = NCOUNT+1 IF(NCOUNT.LT.NHEP) GOTO 11 ENDIF ENDIF ENDIF ELSE QHEP = JC 13 QHEP = QHEP+1 IF(IDHEP(QHEP).EQ.0) GOTO 13 IF(IDHW(QHEP).EQ.59) THEN IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN COLP = IHEP RETURN ELSE GOTO 13 ENDIF ENDIF NCOUNT = 0 9 IF(JMOHEP(2,QHEP).NE.0) THEN IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND. & JMOHEP(2,QHEP).NE.QHEP) THEN IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN QHEP = JMOHEP(2,QHEP) NCOUNT = NCOUNT+1 IF(NCOUNT.LT.NHEP) GOTO 9 ENDIF ENDIF ENDIF ENDIF IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP ENDIF ELSE C--Search for an anticolour partner DO 210 JHEP=JC,JD IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210 IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP IF (JMOHEP(2,JHEP).NE.0) GOTO 210 C---JOIN IHEP AND JHEP COLP=JHEP RETURN 210 CONTINUE IF (LHEP.NE.0) COLP=LHEP C--New piece IF(COLP.EQ.0) THEN IDM2=IDHW(JC) IF(JMOHEP(1,JC).LT.6) THEN IF(IDM2.LE.6) THEN IDM2= IDM2+6 ELSEIF(IDM2.GT.6) THEN IDM2=IDM2-6 ENDIF ENDIF C--Additional Baryon number violating piece IF((FLA(ID).AND.AFLA(IDM2)).OR. & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59) & .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449) & .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND. & IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND. & ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155) & )) THEN C--special for gluino decay to gluon IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND. & IDHW(JMOHEP(1,JC)).EQ.13) RETURN QHEP = JC 211 QHEP = QHEP+1 IF(IDHEP(QHEP).EQ.0) GOTO 211 IF(IDHW(QHEP).EQ.59) THEN IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN COLP = IHEP RETURN ELSE GOTO 211 ENDIF ENDIF NCOUNT = 0 209 IF(JMOHEP(2,QHEP).NE.0) THEN IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND. & JMOHEP(2,QHEP).NE.QHEP) THEN IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN QHEP = JMOHEP(2,QHEP) NCOUNT = NCOUNT+1 IF(NCOUNT.LT.NHEP) GOTO 209 ENDIF ENDIF ENDIF IF(QHEP.NE.0) COLP=QHEP IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN IDM2= IDHW(QHEP) IF(FLA(IHEP).AND.FLA(QHEP).OR. & ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND. & (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449))) & JDAHEP(2,QHEP)=IHEP ENDIF ELSE QHEP = JD+1 220 QHEP = QHEP-1 IF(IDHEP(QHEP).EQ.0) GOTO 220 IF(IDHW(QHEP).EQ.59) THEN IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN COLP = IHEP RETURN ELSE GOTO 220 ENDIF ENDIF NCOUNT = 0 219 IF(JDAHEP(2,QHEP).NE.0) THEN IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN QHEP = JDAHEP(2,QHEP) NCOUNT = NCOUNT+1 IF(NCOUNT.LT.200) GOTO 219 ENDIF ENDIF ENDIF IF(QHEP.NE.0) COLP=QHEP IDM2 = IDHW(QHEP) IF(JDAHEP(2,QHEP).EQ.0.AND. & (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR. & (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP ENDIF ENDIF ENDIF END CDECK ID>, HWBSPA. *CMZ :- -26/04/91 14.26.44 by Federico Carminati *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWBSPA C----------------------------------------------------------------------- C Constructs time-like 4-momenta & production vertices in space-like C jet started by parton no.2 interference partner 1 and spin density C DECPAR(2). RHOPAR(2) gives the jet spin density matrix. C See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2, & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2) INTEGER IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR LOGICAL EICOR EXTERNAL HWRGEN SAVE ZERO2,DMIN DATA ZERO2,DMIN/2*0D0,1D-15/ IF (IERROR.NE.0) RETURN JPAR=2 KPAR=1 IF (NPAR.EQ.2) THEN CALL HWVZRO(2,RHOPAR(1,2)) RETURN ENDIF C Generate azimuthal angle of JPAR's branching using an M-function C Find the daughters of JPAR, with LPAR time-like 10 LPAR=JDAPAR(1,JPAR) IF (TMPAR(LPAR)) THEN MPAR=LPAR+1 ELSE MPAR=LPAR LPAR=MPAR+1 ENDIF C Soft correlations CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT) CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP) PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN) EIKON=1. EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13 IF (EICOR) THEN IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN EISCR=ONE ELSE EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR)) ENDIF EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR)) EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR) EIDEN2=PT*ABS(PPAR(1,LPAR)) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO) ENDIF C Spin correlations WT=ZERO SPIN=ONE IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN Z1=PPAR(4,JPAR)/PPAR(4,MPAR) Z2=ONE-Z1 IF (IDPAR(MPAR).EQ.13) THEN TR=Z1/Z2+Z2/Z1+Z1*Z2 ELSEIF (IDPAR(MPAR).LT.13) THEN TR=(ONE+Z2**2)/(TWO*Z1) ENDIF WT=Z2/(Z1*TR) ENDIF C Assign the azimuthal angle PRMAX=(1.+ABS(WT))*EIKON 50 CALL HWRAZM( ONE,CX,SX) CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT) C Determine the angle between the branching planes CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP) CAZ=ROHEP(1)/PT PHIPAR(1,JPAR)=2.*CAZ*CAZ-1. PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO) IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR) & +DECPAR(2,JPAR)*PHIPAR(2,JPAR)) IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50 C Construct full 4-momentum of LPAR, sum P-trans of MPAR PPAR(2,LPAR)=ZERO PPAR(2,MPAR)=ZERO CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR)) CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2)) C Test for end of space-like branches IF (JDAPAR(1,MPAR).EQ.0) GOTO 60 C Generate new Decay matrix CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR), & PHIPAR(1,JPAR),DECPAR(1,MPAR)) C Advance along the space-like branch JPAR=MPAR KPAR=LPAR GOTO 10 C Retreat along space-like line C Assign initial spin density matrix 60 CONTINUE CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR)) CALL HWUMAS(PPAR(1,2)) CALL HWVZRO(4,VPAR(1,MPAR)) JSTR=JPAR LSTR=LPAR MSTR=MPAR 70 JPAR=JSTR LPAR=LSTR MPAR=MSTR CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR)) IF (MPAR.EQ.2) RETURN C Construct spin density matrix for time-like branch CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR), & DECPAR(1,JPAR),RHOPAR(1,LPAR)) C Evolve time-like side branch CALL HWBTIM(LPAR,MPAR) C Construct spin density matrix for space-like branch CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR), & DECPAR(1,LPAR),RHOPAR(1,JPAR)) C Assign production vertex to J CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR)) CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR)) CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR)) C Find parent and partner of MPAR MPAR=JPAR JPAR=JMOPAR(1,MPAR) C BRW modified here 19/06/01 to avoid compiler-dependent bug C (overwriting of JPAR etc.) IPAR=MPAR+1 KPAR=JMOPAR(1,IPAR) IF (JPAR.EQ.KPAR) THEN LPAR=MPAR+1 ELSE LPAR=MPAR-1 ENDIF JSTR=JPAR LSTR=LPAR MSTR=MPAR GOTO 70 END CDECK ID>, HWBSPN. *CMZ :- -26/04/91 11.11.54 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWBSPN C----------------------------------------------------------------------- C Constructs appropriate spin density/decay matrix for parton C in hard subprocess, otherwise zero. Assignments based upon C Comp. Phys. Comm. 58 (1990) 271. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2) INTEGER IST SAVE R1,R2,V12 IF (IERROR.NE.0) RETURN IST=MOD(ISTHEP(NEVPAR),10) C Assumed partons processed in the order IST=1,2,3,4 IF (IPROC.GE.100.AND.IPROC.LE.116) THEN C An e+e- ---> qqbar g event IF (IDPAR(2).EQ.13) THEN RHOPAR(1,2)=GPOLN RHOPAR(2,2)=0. RETURN ENDIF ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR. & IHPRO.EQ.10.OR.IHPRO.EQ.11.OR. & IHPRO.EQ.15.OR.IHPRO.EQ.16.OR. & (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN C A hard 2 --- > 2 QCD subprocess involving gluons IF (IST.EQ.2) THEN CALL HWVEQU(2,RHOPAR(1,2),R1(1)) C=GCOEF(2)/GCOEF(1) DECPAR(1,2)=C*R1(1) DECPAR(2,2)=C*R1(2) RETURN ELSEIF (IST.EQ.3) THEN CALL HWVEQU(2,RHOPAR(1,2),R2(1)) V12=R1(1)*R2(1)+R1(2)*R2(2) TR=1./(GCOEF(1)+GCOEF(2)*V12) RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR RETURN ELSEIF (IST.EQ.4) THEN V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2) V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2) TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23) C1=(GCOEF(2)+GCOEF(5))*TR C2=(GCOEF(3)+GCOEF(6))*TR C3=(GCOEF(4)+GCOEF(6))*TR RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1) RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2) RETURN ENDIF ENDIF ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN C A gluon fusion ---> Higgs event IF (IST.EQ.2) THEN IF (IHIGGS.NE.4) THEN DECPAR(1,2)=RHOPAR(1,2) DECPAR(2,2)=-RHOPAR(2,2) ELSE DECPAR(1,2)=-RHOPAR(1,2) DECPAR(2,2)=RHOPAR(2,2) END IF RETURN ENDIF ELSEIF (IPRO.EQ.42) THEN C A gluon fusion (or qq-bar annihilation) ---> graviton production event IF (IST.EQ.2) THEN DECPAR(1,2)=RHOPAR(1,2) DECPAR(2,2)=RHOPAR(2,2) RETURN ENDIF ENDIF CALL HWVZRO(2,RHOPAR(1,2)) CALL HWVZRO(2,DECPAR(1,2)) END CDECK ID>, HWBSU1. *CMZ :- -13/07/92 20.15.54 by Mike Seymour *-- Author : Bryan Webber, modified by Mike Seymour C----------------------------------------------------------------------- FUNCTION HWBSU1(ZLOG) C----------------------------------------------------------------------- C Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR. C HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U EXTERNAL HWBSUL Z=EXP(ZLOG) U=1.-Z HWBSU1=HWBSUL(Z)*(1.+U*U) END CDECK ID>, HWBSU2. *CMZ :- -13/07/92 20.15.54 by Mike Seymour *-- Author : Bryan Webber, modified by Mike Seymour C----------------------------------------------------------------------- FUNCTION HWBSU2(Z) C----------------------------------------------------------------------- C INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR. C HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWBSU2,HWBSUL,Z,U EXTERNAL HWBSUL U=1.-Z HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U END CDECK ID>, HWBSUD. *CMZ :- -14/07/92 13.28.23 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWBSUD C----------------------------------------------------------------------- C COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT, & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD, & RMOLD(6),ACOLD,ZLO,ZHI INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2 SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD, & INOLD COMMON/HWSINT/QRAT,QLAM IF (LRSUD.EQ.0) THEN POWER=1./FLOAT(NQEV-1) AFAC=6.*CAFAC/BETAF QMIN=QG+QG QFAC=(1.1*QLIM/QMIN)**POWER SUD(1,1)=1. QEV(1,1)=QMIN C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR DO 10 IQ=2,NQEV QNOW=QFAC*QEV(IQ-1,1) QLAM=QNOW/QCDL3 ZMIN=QG/QNOW QRAT=1./ZMIN G1=0 DO 5 I=3,6 ZLO=ZMIN ZHI=HALF IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1)) IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I)) IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR) 5 CONTINUE SUD(IQ,1)=EXP(AFAC*G1) 10 QEV(IQ,1)=QNOW AFAC=3.*CFFAC/BETAF C--QUARK FORM FACTORS. C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V DO 15 IS=2,NSUD Q1=HWBVMC(IS) IF (IS.EQ.7) Q1=HWBVMC(209) QMIN=Q1+QG IF (QMIN.GT.QLIM) GOTO 15 QFAC=(1.1*QLIM/QMIN)**POWER SUD(1,IS)=1. QEV(1,IS)=QMIN DO 14 IQ=2,NQEV QNOW=QFAC*QEV(IQ-1,IS) QLAM=QNOW/QCDL3 ZMIN=QG/QNOW QRAT=1./ZMIN ZMAX=QG/QMIN G1=0 DO 12 I=3,6 ZLO=ZMIN ZHI=ZMAX IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1)) IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I)) IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR) 12 CONTINUE ZMIN=Q1/QNOW QRAT=1./ZMIN ZMAX=Q1/QMIN G2=0 DO 13 I=3,6 ZLO=ZMIN ZHI=ZMAX IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1)) IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I)) IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR) 13 CONTINUE SUD(IQ,IS)=EXP(AFAC*(G1+G2)) 14 QEV(IQ,IS)=QNOW 15 CONTINUE QCOLD=QCDLAM VGOLD=VGCUT VQOLD=VQCUT ACOLD=ACCUR INOLD=INTER NQOLD=NQEV NSOLD=NSUD NCOLD=NCOLO NFOLD=NFLAV SDOLD=SUDORD DO 16 IS=1,NSUD 16 RMOLD(IS)=RMASS(IS) ELSE IF (LRSUD.GT.0) THEN IF (IPRINT.NE.0) WRITE (6,17) LRSUD 17 FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4) OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN') READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD, & ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD CLOSE(UNIT=LRSUD) ENDIF C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501) IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502) IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503) IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504) IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505) IF (NQEV .NE.NQOLD) CALL HWWARN('HWBSUD',506) IF (NSUD .NE.NSOLD) CALL HWWARN('HWBSUD',507) IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508) IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509) IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510) C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN DO 18 IS=1,NSUD IF (RMASS(IS).NE.RMOLD(IS)) & CALL HWWARN('HWBSUD',510+IS) IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM) & CALL HWWARN('HWBSUD',500) 18 CONTINUE ENDIF IF (LWSUD.GT.0) THEN IF (IPRINT.NE.0) WRITE (6,19) LWSUD 19 FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4) OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN') WRITE(UNIT=LWSUD) QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6), & ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD CLOSE(UNIT=LWSUD) ENDIF IF (IPRINT.GT.2) THEN C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS DO 40 IS=1,NSUD WRITE(6,20) IS,NQEV 20 FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.', & I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT', & ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD', & ' WITHOUT BRANCHING'///2X,8(' Q SUD ')/) L2=NQEV/8 L1=L2/32 IF (L1.LT.1) L1=1 DO 40 L=L1,L2,L1 LL=L+7*L2 WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2) 30 FORMAT(2X,8(F9.2,F7.4)) 40 CONTINUE WRITE(6,50) 50 FORMAT(1H1) ENDIF END CDECK ID>, HWBSUG. *CMZ :- -13/07/92 20.15.54 by Mike Seymour *-- Author : Bryan Webber, modified by Mike Seymour C----------------------------------------------------------------------- FUNCTION HWBSUG(ZLOG) C----------------------------------------------------------------------- C Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W EXTERNAL HWBSUL Z=EXP(ZLOG) W=Z*(1.-Z) HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z END CDECK ID>, HWBSUL. *CMZ :- -13/07/92 20.15.54 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWBSUL(Z) C----------------------------------------------------------------------- C LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR. C THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER C Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN, & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT, & MUMIN,MUMAX,ALMIN,ALMAX INTEGER NF LOGICAL FIRST EXTERNAL HWUALF SAVE FIRST,BET,BEP,MUMI,MUMA COMMON/HWSINT/QRAT,QLAM DATA FIRST/.TRUE./ ALFINT(AL,BL)=1/BET(NF)* & LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL)) HWBSUL=0 U=1.-Z IF (SUDORD.EQ.1) THEN AL=LOG(QRAT*Z) BL=LOG(QLAM*U*Z) HWBSUL=LOG(1.-AL/BL) ELSE IF (FIRST) THEN DO 10 NF=3,6 BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC) BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2) & /BET(NF) IF (NF.EQ.3) THEN MUMI(3)=0 ALMI(3)=1D30 ELSE MUMI(NF)=RMASS(NF) ALMI(NF)=HWUALF(1,MUMI(NF)) ENDIF IF (NF.EQ.6) THEN MUMA(NF)=1D30 ALMA(NF)=0 ELSE MUMA(NF)=RMASS(NF+1) ALMA(NF)=HWUALF(1,MUMA(NF)) ENDIF IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF)) 10 CONTINUE FIRST=.FALSE. ENDIF QNOW=QLAM*QCDL3 QMIN=QNOW/QRAT MUMIN= U*QMIN MUMAX=Z*U*QNOW IF (MUMAX.LE.MUMIN) RETURN ALMIN=HWUALF(1,MUMIN) ALMAX=HWUALF(1,MUMAX) NF=3 20 IF (MUMIN.GT.MUMA(NF)) THEN NF=NF+1 GOTO 20 ENDIF IF (MUMAX.LT.MUMA(NF)) THEN HWBSUL=ALFINT(ALMIN,ALMAX) ELSE HWBSUL=ALFINT(ALMIN,ALMA(NF)) NF=NF+1 30 IF (MUMAX.GT.MUMA(NF)) THEN HWBSUL=HWBSUL+FINT(NF) NF=NF+1 GOTO 30 ENDIF HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX) ENDIF HWBSUL=HWBSUL*BET(5) ENDIF END CDECK ID>, HWBTIM. *CMZ :- -26/04/91 14.27.17 by Federico Carminati *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWBTIM(INITBR,INTERF) C----------------------------------------------------------------------- C Constructs full 4-momentum & production vertices in time-like jet C initiated by INITBR, interference partner INTERF and spin density C RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix. C Includes azimuthal angular correlations between branching planes C due to spin (if AZSPIN) using the algorithm of Knowles & Collins. C Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR, & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2) INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD LOGICAL EICOR,SWAP EXTERNAL HWRGEN SAVE ZERO2,DMIN DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/ IF (IERROR.NE.0) RETURN JPAR=INITBR KPAR=INTERF IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30 C No branching, assign decay matrix CALL HWVZRO(2,DECPAR(1,JPAR)) RETURN C Advance up the leader C Find the parent and partner of J 10 IPAR=JMOPAR(1,JPAR) KPAR=JPAR+1 C Generate new Rho IF (JMOPAR(1,KPAR).EQ.IPAR) THEN C Generate Rho' CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR), & ZERO2,RHOPAR(1,JPAR)) ELSE KPAR=JPAR-1 IF (JMOPAR(1,KPAR).NE.IPAR) THEN CALL HWWARN('HWBTIM',100) GOTO 999 ENDIF C Generate Rho'' CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR), & DECPAR(1,KPAR),RHOPAR(1,JPAR)) ENDIF C Generate azimuthal angle of J's branching 30 IF (JDAPAR(1,JPAR).EQ.0) THEN C Final state gluon CALL HWVZRO(2,DECPAR(1,JPAR)) IF (JPAR.EQ.INITBR) RETURN GOTO 70 ELSE C Assign an angle to a branching using an M-function C Find the daughters of J LPAR=JDAPAR(1,JPAR) MPAR=JDAPAR(2,JPAR) C Soft correlations CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT) CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP) PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN) EIKON=1. SWAP=.FALSE. EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13)) IF (EICOR) THEN C Rearrange s.t. LPAR is the (softest) gluon IF (IDPAR(MPAR).EQ.13) THEN IF (IDPAR(LPAR).NE.13.OR. & PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN SWAP=.TRUE. LPAR=MPAR MPAR=LPAR-1 ENDIF ENDIF EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR)) & *ABS(PPAR(2,LPAR)-PPAR(2,MPAR)) EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR) EIDEN2=PT*ABS(PPAR(1,LPAR)) IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN EISCR=ONE ELSE CALL HWWARN('HWBTIM',102) GOTO 999 ENDIF ELSE EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR)) ENDIF EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN) ENDIF C Spin correlations WT=0. SPIN=1. IF (AZSPIN) THEN Z1=PPAR(4,LPAR)/PPAR(4,JPAR) Z2=1.-Z1 IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2) ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2) ENDIF ENDIF C Assign the azimuthal angle PRMAX=(1.+ABS(WT))*EIKON NTRY=0 50 NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWBTIM',101) GOTO 999 ENDIF CALL HWRAZM( ONE,CX,SX) CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT) C Determine the angle between the branching planes CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP) CAZ=ROHEP(1)/PT PHIPAR(1,JPAR)=2.*CAZ*CAZ-1. PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN) IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR) & +RHOPAR(2,JPAR)*PHIPAR(2,JPAR)) IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50 C Construct full 4-momentum of L and M JOLD=JPAR IF (SWAP) THEN PPAR(1,LPAR)=-PPAR(1,LPAR) PPAR(1,MPAR)=-PPAR(1,MPAR) JPAR=MPAR ELSE JPAR=LPAR ENDIF PPAR(2,LPAR)=0. CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR)) PPAR(2,MPAR)=0. CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR)) C Assign production vertex to L and M CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR)) CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR)) CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR)) ENDIF 60 IF (JDAPAR(1,JPAR).NE.0) GOTO 10 C Assign decay matrix CALL HWVZRO(2,DECPAR(1,JPAR)) C Backtrack down the leader 70 IPAR=JMOPAR(1,JPAR) KPAR=JDAPAR(1,IPAR) IF (KPAR.EQ.JPAR) THEN C Develop the side branch JPAR=JDAPAR(2,IPAR) GOTO 60 ELSE C Construct decay matrix CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR), & PHIPAR(1,IPAR),DECPAR(1,IPAR)) ENDIF IF (IPAR.EQ.INITBR) RETURN JPAR=IPAR GOTO 70 999 RETURN END CDECK ID>, HWBTOP. *CMZ :- -31/03/00 17:54:05 by Peter Richardson *-- Author : Gennaro Corcella C----------------------------------------------------------------------- SUBROUTINE HWBTOP C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W, & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3), & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA, & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A) C---FIND AN UNTREATED CMF ICMF=0 DO 10 IHEP=1,NHEP C----FIND A DECAYING TOP QUARK 10 IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113 & .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12)) & ICMF=IHEP IF (ICMF.EQ.0) RETURN EM=PHEP(5,ICMF) X3MIN=2*GCUTME/EM C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2) 100 CONTINUE C-----AW=(MW/MT)**2 AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2 C---CHOOSE X3 X3MAX=1-AW X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0)) C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER C--IN ORDER TO SOLVE THE CUBIC EQUATION CC=(1-AW)**2/4 QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3 & -((3+2*AW-4*X(3))**2)/9 RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3)) & -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC) & *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3 C---CHOOSE X1 X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3) & -(3+2*AW-4*X(3))/3 X1MIN=1-X(3)+(AW*X(3))/(1-X(3)) IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1) C---CALCULATE WEIGHT W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2) & +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))) & *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX)) C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW)) C---FACTOR FOR GLUON EMISSION ID=IDHW(JDAHEP(2,ICMF)) GLUFAC=0 IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE) & /(PIFAC*(1-AW)*(1-2*AW+1/AW)) C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON IF (GLUFAC*W.GT.HWRGEN(4)) THEN ID3=13 ELSE GOTO 1000 ENDIF C---CHECK INFRA-RED CUT-OFF FOR GLUON M(1)=PHEP(5,JDAHEP(1,ICMF)) M(2)=HWBVMC(ID) M(3)=HWBVMC(ID3) E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2) E(3)=HALF*EM*X(3) E(2)=EM-E(1)-E(3) PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2, & E(2)**2-M(2)**2) IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) $ GOTO 1000 C---CALCULATE MASS-DEPENDENT SUPPRESSION EPS=(RMASS(ID)/EM)**2 EPG=(RMASS(ID3)/EM)**2 GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2 & -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW)) MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW) & *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3)) & -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3) & *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2) IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3) & -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3) & *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) GOTO 1000 C---STORE OLD MOMENTA c---PT = TOP MOMENTUM, PW= W MOMENTUM CALL HWVEQU(5,PHEP(1,ICMF),PT) CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW) C--------GET THE NON-EMITTING PARTON CMF DIRECTION CALL HWULOF(PHEP(1,ICMF),PW,PW) CALL HWRAZM(ONE,CS,SN) CALL HWUROT(PW,CS,SN,R) CALL HWUROF(R,PW,PW) CALL HWUMAS(PW) C---REORDER ENTRIES: IHEP=EMITTER, KHEP=EMITTED NHEP=NHEP+1 IHEP=JDAHEP(2,ICMF) WHEP=JDAHEP(1,ICMF) KHEP=NHEP C---SET UP MOMENTA IN TOP REST FRAME PHEP(1,ICMF)=0 PHEP(2,ICMF)=0 PHEP(3,ICMF)=0 PHEP(4,ICMF)=EM PHEP(5,ICMF)=EM PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG) PHEP(4,KHEP)=HALF*EM*X(3) PHEP(5,IHEP)=RMASS(ID) PHEP(5,KHEP)=RMASS(ID3) PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW $ -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW $ -EPS-EPG)**2-4*AW) PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM $ *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW) PHEP(2,IHEP)=0 PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2 $ -PHEP(3,KHEP)**2) PHEP(1,IHEP)=-PHEP(1,KHEP) PHEP(2,KHEP)=0 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1) CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1) CALL HWUMAS(PW1) DO K=1,5 PHEP(K,WHEP)=PW1(K) ENDDO C---ORIENT IN CMF, THEN BOOST TO LAB CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF)) CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP)) CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP)) CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP)) CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF)) CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP)) C---STATUS AND COLOUR CONNECTION C--Bug fix 31/03/00 PR ISTHEP(KHEP)=114 IDHW(KHEP)=ID3 IDHEP(KHEP)=IDPDG(ID3) JMOHEP(1,KHEP)=ICMF JMOHEP(1,IHEP)=ICMF JDAHEP(1,KHEP)=0 JDAHEP(2,ICMF)=KHEP IF(IDHW(ICMF).EQ.6) THEN JDAHEP(2,IHEP)=ICMF JDAHEP(2,KHEP)=IHEP JMOHEP(2,IHEP)=KHEP JMOHEP(2,KHEP)=ICMF ELSE JDAHEP(2,IHEP) = KHEP JDAHEP(2,KHEP) = ICMF JMOHEP(2,IHEP) = ICMF JMOHEP(2,KHEP) = IHEP ENDIF C--End of Fix C--modification to allow photon radiation via photos in top decay 1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF) END CDECK ID>, HWBVMC. *CMZ :- -26/04/91 11.11.54 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWBVMC(ID) C----------------------------------------------------------------------- C VIRTUAL MASS CUTOFF FOR PARTON TYPE ID C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC INTEGER ID IF (ID.EQ.13) THEN HWBVMC=RMASS(ID)+VGCUT ELSEIF (ID.LT.13) THEN HWBVMC=RMASS(ID)+VQCUT ELSEIF (ID.EQ.59) THEN HWBVMC=RMASS(ID)+VPCUT ELSE HWBVMC=RMASS(ID) ENDIF END CDECK ID>, HWCBCT. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT) C----------------------------------------------------------------------- C Subroutine to split a baryonic cluster containing two heavy quarks C Based on HWCCUT C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4, & PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5), & VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4), & DELTM,PDIQUK(5),AY(5) INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY, & NTRYMX,J,IB LOGICAL SPLIT EXTERNAL HWUPCM,HWRGEN,HWVDOT PARAMETER(SKAPPA=1.,NTRYMX=100) IF(IERROR.NE.0) RETURN EMC=PCL(5) ID1=IDHW(JHEP) ID2=IDHW(KHEP) ID3=IDHW(THEP) QM1=RMASS(ID1) QM2=RMASS(ID2) QM3=RMASS(ID3) SPLIT = .FALSE. NTRY = 0 C Decide if cluster contains a b-(anti)quark IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR. & ID3.EQ.5.OR.ID3.EQ.11) THEN IB=2 ELSE IB=1 ENDIF C-- Set the positon of the cluster to be that of the heavy quark CALL HWVEQU(4,VHEP(1,THEP),VCLUS) C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY C--FLAVOUR BARYON PXY=EMC-QM1-QM2-QM3 20 NTRY=NTRY+1 IF(NTRY.GT.NTRYMX) RETURN 30 EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB) EMY= QM3+PXY*HWRGEN(1)**PSPLT(IB) IF(EMX+EMY.GE.EMC) GOTO 30 C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM 40 ID4=HWRINT(1,3) IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40 QM4=RMASS(ID4) C--Now combine particles 3 & 4 into a diquark C--If three also heavy this diquark doesn't exist in HERWIG C--just assume mass is sum of quark masses,as for other diquarks DQM=QM3+QM4 C--Now obtain the masses for the cluster splitting PCX=HWUPCM(EMX,QM1,DQM) IF(PCX.LT.ZERO) GOTO 20 PCY=HWUPCM(EMY,QM2,QM4) IF(PCY.LT.ZERO) GOTO 20 SPLIT=.TRUE. C--Now we've decided which light quark to pull out of the vacuum C--Find the direction of the second heavy quark CALL HWULOF(PCL,PHEP(1,THEP),AX) RCM=1./SQRT(HWVDOT(3,AX,AX)) CALL HWVSCA(3,RCM,AX,AX) C--Construct the new CoM momenta(collinear) PXY=HWUPCM(EMC,EMX,EMY) CALL HWVSCA(3,PXY,AX,PC) C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame PC(4)=SQRT(PXY**2+EMY**2) PC(5)=EMY C--pa is momenta of 2nd quark in Y frame CALL HWVSCA(3,PCY,AX,PA) PA(4)=SQRT(PCY**2+QM3**2) PA(5)=QM3 C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark CALL HWULOB(PC,PA,PB) CALL HWVDIF(4,PC,PB,PA) PA(5)=QM4 LHEP=NHEP+1 MHEP=NHEP+2 C--boost these momenta back to lab frame CALL HWULOB(PCL,PB,PHEP(1,THEP)) CALL HWULOB(PCL,PA,PHEP(1,MHEP)) C--pc now becomes momenta of X cluster in cluster frame CALL HWVSCA(3,-ONE,PC,PC) PC(4)=EMC-PC(4) PC(5)=EMX C--find the dirn of the 1st heavy quark in the X frame C--transform to cluster frame CALL HWULOF(PCL,PHEP(1,JHEP),AY) C--transform to X-frame CALL HWULOF(PC,AY,AY) RCM=1./SQRT(HWVDOT(3,AY,AY)) CALL HWVSCA(3,RCM,AY,AY) C--pa now momenta of 1st havy quark along this dirn CALL HWVSCA(3,PCX,AY,PA) PA(4)=SQRT(PCX**2+QM1**2) PA(5)=QM1 C--pb now momenta of 1st heavy quark in cluster frame then to lab CALL HWULOB(PC,PA,PB) CALL HWULOB(PCL,PB,PHEP(1,JHEP)) C--now find the diquark momenta by momentum conservation DO 50 J=1,4 50 PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP) PDIQUK(5)=DQM C--Now obtain the quark momenta from the diquark DO 60 J=1,3 60 PA(J) = 0 PA(4) = QM2 PA(5) = QM2 CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP)) CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP)) C--Construct new vertex positions RKAPPA=GEV2MM/SKAPPA CALL HWVSCA(3,RKAPPA,AX,AX) DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC) CALL HWVSCA(3,DELTM,AX,VTMP) VTMP(4)=(HALF*EMC-PXY)*RKAPPA CALL HWULB4(PCL,VTMP,VTMP) CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP)) CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP)) C--Relabel the colours of the quarks IDHEP(LHEP) = IDPDG(ID4) IDHEP(MHEP) = IDPDG(ID4) IF(IDHEP(JHEP).GT.0) THEN IDHW(LHEP) = ID4+6 IDHEP(LHEP) = -IDHEP(LHEP) IDHW(MHEP) = ID4 JDAHEP(2,LHEP) = JHEP JMOHEP(2,LHEP) = MHEP JMOHEP(2,MHEP) = JMOHEP(2,JHEP) JDAHEP(2,MHEP) = LHEP JMOHEP(2,JHEP) = LHEP ELSE IDHW(LHEP) = ID4 IDHW(MHEP) = ID4+6 IDHEP(MHEP) = -IDHEP(MHEP) JMOHEP(2,LHEP) = JHEP JDAHEP(2,MHEP) = JDAHEP(2,JHEP) JDAHEP(2,LHEP) = MHEP JMOHEP(2,MHEP) = LHEP JDAHEP(2,JHEP) = LHEP ENDIF ISTHEP(LHEP) = 151 ISTHEP(MHEP) = 151 JMOHEP(1,LHEP) = JMOHEP(1,KHEP) JDAHEP(1,LHEP) = 0 JMOHEP(1,MHEP) = JMOHEP(1,JHEP) JDAHEP(1,MHEP) = 0 NHEP = NHEP+2 END CDECK ID>, HWCBVI. *CMZ :- -12/12/01 14:59:58 by Peter Richardson *-- Author : Mark Gibbs, modified by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWCBVI C----------------------------------------------------------------------- C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION C MODIFIED FOR RPARITY VIOLATING SUSY C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/HWBVIC/NBV,IBV(18) DOUBLE PRECISION HWRGEN,PDQ(5) INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3, & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3) LOGICAL SPLIT,DUNBV(18) SAVE IDIQK DATA IDIQK/111,110,113,110,109,112,113,112,114/ C---Check for errors IF (IERROR.NE.0) RETURN C---Correct colour connections are gluon splitting CALL HWCCCC C---Reset bvi clustering flag HVFCEN = .FALSE. C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY 5 NBV=0 DO 10 IHEP=1,NHEP IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN IF (QORQQB(IDHW(IHEP))) THEN IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))). & AND.JMOHEP(2,IHEP).GT.6) GOTO 10 ELSE C---Extra check for Gamma's IF (IDHW(IHEP).EQ.59) GO TO 10 C---End of bug fix. IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10 GO TO 10 ENDIF IF(JMOHEP(2,IHEP).LT.6.AND. & .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10 C--new for hard process NBV=NBV+1 IF (NBV.GT.18) THEN CALL HWWARN('HWCBVI',100) GOTO 999 ENDIF IBV(NBV)=IHEP DUNBV(NBV)=.FALSE. ENDIF 10 CONTINUE C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS DO 11 IHEP=1,NHEP IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN IF(QBORQQ(IDHW(IHEP))) THEN IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND. & JDAHEP(2,IHEP).GT.6) GO TO 11 ELSE C--Extra check for gamma's IF(IDHW(IHEP).EQ.59) GO TO 11 IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11 GO TO 11 ENDIF IF(JDAHEP(2,IHEP).LT.6.AND. & .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11 NBV=NBV+1 IF(NBV.GT.18) THEN CALL HWWARN('HWCBVI',100) GOTO 999 ENDIF IBV(NBV)=IHEP DUNBV(NBV)=.FALSE. ENDIF 11 CONTINUE IF (NBV.EQ.0) RETURN IF(MOD(NBV,3).NE.0) THEN CALL HWWARN('HWCBVI',101) GOTO 999 ENDIF C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST NBR=INT(NBV*HWRGEN(0)) DO 100 MBV=1,NBV JBV=MBV+NBR IF (JBV.GT.NBV) JBV=JBV-NBV IF (.NOT.DUNBV(JBV)) THEN DUNBV(JBV)=.TRUE. IP1=IBV(JBV) JP1=HWCBVT(IP1) C---FIND ASSOCIATED PARTONS DO 20 KBV=1,NBV IF (.NOT.DUNBV(KBV)) THEN IP2=IBV(KBV) JP2=HWCBVT(IP2) IF (JP2.EQ.JP1) THEN DUNBV(KBV)=.TRUE. DO 15 LBV=1,NBV IF (.NOT.DUNBV(LBV)) THEN IP3=IBV(LBV) JP3=HWCBVT(IP3) IF (JP3.EQ.JP2) THEN DUNBV(LBV)=.TRUE. GO TO 25 ENDIF ENDIF 15 CONTINUE ENDIF ENDIF 20 CONTINUE CALL HWWARN('HWCBVI',102) GOTO 999 25 IQ1=0 C---LOOK FOR DIQUARK IF (ABS(IDHEP(IP1)).GT.100) THEN IQ1=IP1 IQ2=IP2 IQ3=IP3 ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN IQ1=IP2 IQ2=IP3 IQ3=IP1 ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN IQ1=IP3 IQ2=IP1 IQ3=IP2 ENDIF IF (IQ1.EQ.0) THEN C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS IF (ABS(IDHEP(IP1)).GT.3) THEN IQ1=IP2 IQ2=IP3 IQ3=IP1 ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN IQ1=IP3 IQ2=IP1 IQ3=IP2 ELSE IQ1=IP1 IQ2=IP2 IQ3=IP3 ENDIF ID1=IDHEP(IQ1) ID2=IDHEP(IQ2) C---CHECK FLAVOURS IF (ID1.GT.0.AND.ID1.LT.4.AND. & ID2.GT.0.AND.ID2.LT.4) THEN IDQ=IDIQK(ID1,ID2) ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND. & ID1.LT.0.AND.ID2.GT.-4) THEN IDQ=IDIQK(-ID1,-ID2)+6 ELSE C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ) CALL HWUMAS(PDQ) C--Use the original splitting procedure CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT) IF (IERROR.NE.0) RETURN IF(SPLIT) GOTO 5 C--If it fails try the new procedure CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ) CALL HWUMAS(PDQ) IF(ABS(ID1).GT.3) THEN CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT) ELSEIF(ABS(ID2).GT.3) THEN CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT) ELSE CALL HWWARN('HWCBVI',100) GOTO 999 ENDIF IF (SPLIT) GO TO 5 C---Unable to form cluster; dispose of event CALL HWWARN('HWCBVI',-3) GOTO 999 ENDIF C---OVERWRITE FIRST AND CANCEL SECOND IDHW(IQ1)=IDQ IDHEP(IQ1)=IDPDG(IDQ) CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1)) CALL HWUMAS(PHEP(1,IQ1)) ISTHEP(IQ2)=0 C---REMAKE COLOUR CONNECTIONS IF (QORQQB(IDQ)) THEN JMOHEP(2,IQ1)=IQ3 JDAHEP(2,IQ3)=IQ1 ELSE JDAHEP(2,IQ1)=IQ3 JMOHEP(2,IQ3)=IQ1 ENDIF ELSE C---SPLIT A DIQUARK NHEP=NHEP+1 CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1)) CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP)) ISTHEP(NHEP)=150 JMOHEP(1,NHEP)=JMOHEP(1,IQ1) JDAHEP(1,NHEP)=0 C---FIND FLAVOURS IDQ=IDHW(IQ1) DO 30 ID2=1,3 DO 30 ID1=1,3 IF (IDIQK(ID1,ID2).EQ.IDQ) THEN IDHW(IQ1)=ID1 IDHW(NHEP)=ID2 C---REMAKE COLOUR CONNECTIONS (DIQUARK) JMOHEP(2,IQ1)=IQ2 JMOHEP(2,IQ2)=NHEP JMOHEP(2,IQ3)=IQ1 JMOHEP(2,NHEP)=IQ3 JDAHEP(2,IQ1)=IQ3 JDAHEP(2,IQ2)=IQ1 JDAHEP(2,IQ3)=NHEP JDAHEP(2,NHEP)=IQ2 GO TO 35 ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN IDHW(IQ1)=ID1+6 IDHW(NHEP)=ID2+6 C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK) JMOHEP(2,IQ1)=IQ3 JMOHEP(2,IQ2)=IQ1 JMOHEP(2,IQ3)=NHEP JMOHEP(2,NHEP)=IQ2 JDAHEP(2,IQ1)=IQ2 JDAHEP(2,IQ2)=NHEP JDAHEP(2,IQ3)=IQ1 JDAHEP(2,NHEP)=IQ3 GO TO 35 ENDIF 30 CONTINUE CALL HWWARN('HWCBVI',104) GOTO 999 35 IDHEP(IQ1)=IDPDG(IDHW(IQ1)) IDHEP(NHEP)=IDPDG(IDHW(NHEP)) ENDIF ENDIF 100 CONTINUE 999 RETURN END CDECK ID>, HWCBVT. *CMZ :- *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWCBVT(IP) C----------------------------------------------------------------------- C Function to find the baryon number violating vertex a parton came from C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4 JP(1) = IP ID = IDHW(IP) IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN JP(2) = JMOHEP(2,IP) ELSE JP(2) = JDAHEP(2,IP) ENDIF DO I=1,2 IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I))))) IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN JP(I)=IDM ENDIF ENDDO DO J=1,7 DO I=1,2 KP = JMOHEP(1,JP(I)) IDM = IDHW(KP) IDM2 = IDHW(JDAHEP(1,KP)) IDM3 = IDHW(JDAHEP(2,KP)) IDM4 = IDHW(JDAHEP(1,KP)+1) IF((ISTHEP(KP).EQ.155.AND. & ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND. & IDM3.LE.12.AND.IDM4.LE.12).OR. & (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406) & .AND.IDM2.LE.12.AND.IDM3.LE.12))) & .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND. & IDHW(JMOHEP(1,KP)).LE.12.AND. & IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND. & IDM3.LE.457).OR. & (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200. & AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN KP = JMOHEP(1,KP) ELSEIF(IDHW(KP).EQ.15) THEN TYPE=IDHW(JDAHEP(1,KP)) IF(TYPE.GE.7.AND.TYPE.LE.12.AND. & JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN KP=IP ELSEIF(TYPE.LE.6.AND. & JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN KP=IP ELSE HWCBVT = KP RETURN ENDIF ELSE HWCBVT = KP RETURN ENDIF ENDIF JP(I) =KP ENDDO ENDDO HWCBVT = 0 END CDECK ID>, HWCCCC. *CMZ :- *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWCCCC C----------------------------------------------------------------------- C Subroutine to correct colour connections after the gluon splitting C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP IF(IERROR.NE.0) RETURN C--Find the first particle in the event record with status 150 DO IHEP=1,NHEP IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN STFSPT = IHEP GOTO 10 ENDIF ENDDO 10 CONTINUE C--Now find any that are colour connected to earlier particles C--in the event record DO IHEP=STFSPT,NHEP C--First the quarks and antidiquarks IF(IDHW(IHEP).LT.6.OR. & (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN IF(JMOHEP(2,IHEP).LT.STFSPT) THEN LHEP = IHEP MHEP = JMOHEP(2,IHEP) RHEP = MHEP IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP) C--As from Rparity connect to particle not to antiparticle IF(IDHW(MHEP).NE.13) THEN JMOHEP(2,LHEP) = RHEP ELSE RHEP = RHEP+1 JMOHEP(2,LHEP) = RHEP ENDIF ENDIF ENDIF C--Now the antiquarks IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR. & (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN IF(JDAHEP(2,IHEP).LT.STFSPT) THEN LHEP = IHEP MHEP = JDAHEP(2,IHEP) RHEP = MHEP IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP) C--As from Rparity connect to antiparticle not particle IF(IDHW(MHEP).NE.13) THEN JDAHEP(2,LHEP) = RHEP ELSE JDAHEP(2,LHEP) = RHEP ENDIF ENDIF ENDIF ENDDO END CDECK ID>, HWCCUT. *CMZ :- -26/04/91 14.29.39 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT) C----------------------------------------------------------------------- C Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY, & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM, & VSCA,VTMP(4),RKAPPA,VCLUS INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB LOGICAL BTCLUS,SPLIT EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT COMMON/HWCFRM/VCLUS(4,NMXHEP) PARAMETER (SKAPPA=1.,NTRYMX=100) IF (IERROR.NE.0) RETURN EMC=PCL(5) ID1=IDHW(JHEP) ID2=IDHW(KHEP) QM1=RMASS(ID1) QM2=RMASS(ID2) SPLIT=.FALSE. NTRY=0 C Decide if cluster contains a b-(anti)quark IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN IB=2 ELSE IB=1 ENDIF IF (BTCLUS) THEN C Split beam and target clusters as soft clusters C Both (remnant) children treated like soft clusters if IOPREM=0(1) 10 ID3=HWRINT(1,2) QM3=RMASS(ID3) IF (EMC.LE.QM1+QM2+2.*QM3) THEN ID3=3-ID3 QM3=RMASS(ID3) IF (EMC.LE.QM1+QM2+2.*QM3) RETURN ENDIF PXY=EMC-QM1-QM2-TWO*QM3 IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR. & IOPREM.EQ.0) THEN EMX=QM1+QM3+HWREXQ(BTCLM,PXY) ELSE EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB) ENDIF IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR. & IOPREM.EQ.0) THEN EMY=QM2+QM3+HWREXQ(BTCLM,PXY) ELSE EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB) ENDIF IF (EMX+EMY.GE.EMC) THEN NTRY=NTRY+1 IF (NTRY.GT.NTRYMX) RETURN GOTO 10 ENDIF PCX=HWUPCM(EMX,QM1,QM3) PCY=HWUPCM(EMY,QM2,QM3) ELSE C Choose fragment masses for ordinary cluster PXY=EMC-QM1-QM2 20 NTRY=NTRY+1 IF (NTRY.GT.NTRYMX) RETURN 30 EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB) EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB) IF (EMX+EMY.GE.EMC) GOTO 30 C u,d,s pair production with weights QWT 40 ID3=HWRINT(1,3) IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40 QM3=RMASS(ID3) PCX=HWUPCM(EMX,QM1,QM3) IF (PCX.LT.ZERO) GOTO 20 PCY=HWUPCM(EMY,QM2,QM3) IF (PCY.LT.ZERO) GOTO 20 SPLIT=.TRUE. ENDIF C Boost antiquark to CoM frame to find axis CALL HWULOF(PCL,PHEP(1,KHEP),AX) RCM=1./SQRT(HWVDOT(3,AX,AX)) CALL HWVSCA(3,RCM,AX,AX) C Construct new CoM momenta (collinear) PXY=HWUPCM(EMC,EMX,EMY) CALL HWVSCA(3,PXY,AX,PC) PC(4)=SQRT(PXY**2+EMY**2) PC(5)=EMY CALL HWVSCA(3,PCY,AX,PA) PA(4)=SQRT(PCY**2+QM2**2) PA(5)=QM2 CALL HWULOB(PC,PA,PB) CALL HWVDIF(4,PC,PB,PA) PA(5)=QM3 LHEP=NHEP+1 MHEP=NHEP+2 IF (MHEP.GT.NMXHEP) THEN CALL HWWARN('HWCCUT',100) GOTO 999 ENDIF CALL HWULOB(PCL,PB,PHEP(1,KHEP)) CALL HWULOB(PCL,PA,PHEP(1,MHEP)) CALL HWVSCA(3,-ONE,PC,PC) PC(4)=EMC-PC(4) PC(5)=EMX CALL HWVSCA(3,PCX,AX,PA) PA(4)=SQRT(PCX**2+QM3**2) CALL HWULOB(PC,PA,PB) CALL HWULOB(PCL,PB,PHEP(1,LHEP)) DO 50 J=1,4 50 PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP) PHEP(5,JHEP)=QM1 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP)) C Construct new vertex positions RKAPPA=GEV2MM/SKAPPA CALL HWVSCA(3,RKAPPA,AX,AX) DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC) CALL HWVSCA(3,DELTM,AX,VTMP) VTMP(4)=(HALF*EMC-PXY)*RKAPPA CALL HWULB4(PCL,VTMP,VTMP) CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP)) CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP)) VSCA=0.25*EMC+HALF*(PXY+DELTM) CALL HWVSCA(3,VSCA,AX,VTMP) VTMP(4)=(EMC-VSCA)*RKAPPA CALL HWULB4(PCL,VTMP,VTMP) CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP)) VSCA=-0.25*EMC+HALF*(DELTM-PXY) CALL HWVSCA(3,VSCA,AX,VTMP) VTMP(4)=(EMC+VSCA)*RKAPPA CALL HWULB4(PCL,VTMP,VTMP) CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP)) C (Re-)label quarks IDHW(LHEP)=ID3+6 IDHW(MHEP)=ID3 IDHEP(MHEP)= IDPDG(ID3) IDHEP(LHEP)=-IDPDG(ID3) ISTHEP(LHEP)=151 ISTHEP(MHEP)=151 JMOHEP(2,JHEP)=LHEP JDAHEP(2,KHEP)=MHEP JMOHEP(1,LHEP)=JMOHEP(1,KHEP) JMOHEP(2,LHEP)=MHEP JDAHEP(1,LHEP)=0 JDAHEP(2,LHEP)=JHEP JMOHEP(1,MHEP)=JMOHEP(1,JHEP) JMOHEP(2,MHEP)=KHEP JDAHEP(1,MHEP)=0 JDAHEP(2,MHEP)=LHEP NHEP=NHEP+2 999 RETURN END CDECK ID>, HWCDEC. *CMZ :- -26/04/91 10.18.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCDEC C----------------------------------------------------------------------- C DECAYS CLUSTERS INTO PRIMARY HADRONS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3 IF (IERROR.NE.0) RETURN IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS DO 10 JCL=2,NHEP IF (ISTHEP(JCL).EQ.164) GOTO 20 IF (ISTHEP(JCL).EQ.165) THEN IP=JMOHEP(1,JCL) JP=JMOHEP(2,JCL) KP=IP IF (ISTHEP(IP).EQ.162) THEN KP=JP JP=IP ENDIF IF (JMOHEP(2,KP).NE.JP) THEN IP=JMOHEP(2,KP) ELSE IP=JDAHEP(2,KP) ENDIF KCL=JDAHEP(1,IP) IF (ISTHEP(KCL)/10.NE.16) THEN CALL HWWARN('HWCDEC',100) GOTO 999 ENDIF ISTHEP(KCL)=164 GOTO 20 ENDIF 10 CONTINUE ENDIF 20 CONTINUE DO 30 JCL=1,NHEP IST=ISTHEP(JCL) IF (IST.GT.162.AND.IST.LT.166) THEN C---DON'T HADRONIZE BEAM/TARGET CLUSTERS IF (IST.EQ.163.OR..NOT.GENSOF) THEN C---SET UP FLAVOURS FOR CLUSTER DECAY CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3) CALL HWCHAD(JCL,ID1,ID3,ID2) ENDIF ENDIF 30 CONTINUE ISTAT=50 999 RETURN END CDECK ID>, HWCFLA. *CMZ :- -26/04/91 10.18.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2) C----------------------------------------------------------------------- C SETS UP FLAVOURS FOR CLUSTER DECAY C----------------------------------------------------------------------- IMPLICIT NONE INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12) SAVE JDEC DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/ JD=JD1 IF (JD.GT.12) JD=JD-108 ID1=JDEC(JD) JD=JD2 IF (JD.GT.12) JD=JD-96 ID2=JDEC(JD-6) END CDECK ID>, HWCFOR. *CMZ :- -26/04/91 14.15.56 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCFOR C----------------------------------------------------------------------- C Converts colour-connected quark-antiquark pairs into clusters C Modified by IGK to include BRW's colour rearrangement and C MHS's cluster vertices C MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1, & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2, & EM0,EM1,EM2,PC0,PC1 INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP, & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L LOGICAL HWRLOG,SPLIT EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT COMMON/HWCFRM/VCLUS(4,NMXHEP) SAVE MAP DATA MAP/1,2,3,4,5,6,1,2,3,4,5,6,96*0,7,8,9,10,11,12,7,8,9,10,11, & 12/ IF (IERROR.NE.0) RETURN C Split gluons CALL HWCGSP C Find colour partners after baryon number violating event IF (HVFCEN) THEN IF(RPARTY) THEN CALL HVCBVI ELSE CALL HWCBVI ENDIF ENDIF IF (IERROR.NE.0) RETURN C Look for partons to cluster DO 10 IBHEP=1,NHEP 10 IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20 IBCL=1 GOTO 130 20 CONTINUE C--Final check for colour disconnections DO 25 JHEP=IBHEP,NHEP IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND. & QORQQB(IDHW(JHEP))) THEN KHEP=JMOHEP(2,JHEP) C BRW FIX 13/03/99 IF (KHEP.EQ.0.OR..NOT.( & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND. & QBORQQ(IDHW(KHEP)))) THEN DO KHEP=IBHEP,NHEP IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154 & .AND.QBORQQ(IDHW(KHEP))) THEN LHEP=JDAHEP(2,KHEP) IF (LHEP.EQ.0.OR..NOT.( & ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND. & QORQQB(IDHW(LHEP)))) THEN JMOHEP(2,JHEP)=KHEP JDAHEP(2,KHEP)=JHEP GOTO 25 ENDIF ENDIF ENDDO C END FIX CALL HWWARN('HWCFOR',100) GOTO 999 ENDIF ENDIF 25 CONTINUE IF (CLRECO) THEN C Allow for colour rearrangement of primary clusters NRECO=0 C Randomize starting point JBHEP=HWRINT(IBHEP,NHEP) JHEP=JBHEP 30 JHEP=JHEP+1 IF (JHEP.GT.NHEP) JHEP=IBHEP IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND. & QORQQB(IDHW(JHEP))) THEN C Find colour connected antiquark or diquark KHEP=JMOHEP(2,JHEP) C Find partner antiquark or diquark LHEP=JDAHEP(2,JHEP) C Find closest antiquark or diquark DCL0=1.D15 LCL=0 DO 40 IHEP=IBHEP,NHEP IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND. & QBORQQ(IDHW(IHEP))) THEN C Check whether already reconnected IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL) DCL1=ABS(HWULDO(DCL,DCL)) IF (DCL1.LT.DCL0) THEN DCL0=DCL1 LCL=IHEP ENDIF ENDIF ENDIF 40 CONTINUE IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN MCL=JDAHEP(2,LCL) IF (JDAHEP(2,MCL).NE.KHEP) THEN C Pairwise reconnection is possible CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL) DCL0=DCL0+ABS(HWULDO(DCL,DCL)) CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL) DCL1=ABS(HWULDO(DCL,DCL)) CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL) DCL1=DCL1+ABS(HWULDO(DCL,DCL)) IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN C Reconnection occurs JMOHEP(2,JHEP)= LCL JDAHEP(2,LCL )=-JHEP JMOHEP(2,MCL) = KHEP JDAHEP(2,KHEP)=-MCL NRECO=NRECO+1 ENDIF ENDIF ENDIF ENDIF IF (JHEP.NE.JBHEP) GOTO 30 IF (NRECO.NE.0) THEN DO 50 IHEP=IBHEP,NHEP 50 JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP)) ENDIF ENDIF C Find (adjusted) cluster positions using MHS prescription DFAC=ONE DMAX=1D-10 DO 70 JHEP=IBHEP,NHEP IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND. & QORQQB(IDHW(JHEP))) THEN KHEP=JMOHEP(2,JHEP) CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1) CALL HWVSCA(4,DFAC,DISP1,DISP1) CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2) CALL HWVSCA(4,DFAC,DISP2,DISP2) C Rescale the lengths of DISP1,DISP2 if too long DOT1=HWVDOT(3,DISP1,DISP1) DOT2=HWVDOT(3,DISP2,DISP2) IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1) CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2) ENDIF CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL) DOT1=HWVDOT(3,DISP1,PCL) DOT2=HWVDOT(3,DISP2,PCL) C If PCL > 90^o from either quark, use a vector which isn't IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN CALL HWVSUM(4,DISP1,DISP2,PCL) DOT1=HWVDOT(3,DISP1,PCL) DOT2=HWVDOT(3,DISP2,PCL) ENDIF C If vectors are exactly opposite each other this method cannot work IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN C So use midpoint of quark constituents CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP)) CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP)) GOTO 70 ENDIF C Rescale DISP1 or DISP2 to give equal components in the PCL direction FAC=DOT1/DOT2 IF (FAC.GT.ONE) THEN CALL HWVSCA(4, FAC,DISP2,DISP2) DOT2=DOT1 ELSE CALL HWVSCA(4,ONE/FAC,DISP1,DISP1) DOT1=DOT2 ENDIF C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL FAC=(HWVDOT(3,PCL,VHEP(1,KHEP)) & -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1 SCA1=MAX(ONE,ONE+FAC) SCA2=MAX(ONE,ONE-FAC) DO 60 I=1,4 60 VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP) & +SCA1*DISP1(I)+SCA2*DISP2(I)) ENDIF 70 CONTINUE C First chop up beam/target clusters DO 80 JHEP=IBHEP,NHEP KHEP=JMOHEP(2,JHEP) ISTJ=ISTHEP(JHEP) ISTK=ISTHEP(KHEP) C--PR MOD here 8/7/99 IF (QORQQB(IDHW(JHEP)).AND. & (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0) & .OR.((ISTK.EQ.153.OR.ISTK.EQ.154). & AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN C--end CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL) CALL HWUMAS(PCL) CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT) IF (IERROR.NE.0) RETURN ENDIF 80 CONTINUE C Second chop up massive pairs DO 100 JHEP=IBHEP,NMXHEP IF (JHEP.GT.NHEP) GOTO 110 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND. & QORQQB(IDHW(JHEP))) THEN 90 KHEP=JMOHEP(2,JHEP) CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL) CALL HWUMAS(PCL) IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT) IF (IERROR.NE.0) RETURN IF (SPLIT) GOTO 90 ENDIF ENDIF 100 CONTINUE C Third create clusters and store production vertex 110 IBCL=NHEP+1 JCL=NHEP DO 120 JHEP=IBHEP,NHEP IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND. & QORQQB(IDHW(JHEP))) THEN JCL=JCL+1 IF(JCL.GT.NMXHEP) THEN CALL HWWARN('HWCFOR',105) GOTO 999 ENDIF IDHW(JCL)=19 IDHEP(JCL)=91 KHEP=JMOHEP(2,JHEP) IF (KHEP.EQ.0.OR..NOT.( & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND. & QBORQQ(IDHW(KHEP)))) THEN CALL HWWARN('HWCFOR',104) GOTO 999 ENDIF CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL)) CALL HWUMAS(PHEP(1,JCL)) IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN ISTHEP(JCL)=164 ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN ISTHEP(JCL)=165 ELSE ISTHEP(JCL)=163 ENDIF JMOHEP(1,JCL)=JHEP JMOHEP(2,JCL)=KHEP JDAHEP(1,JCL)=0 JDAHEP(2,JCL)=0 JDAHEP(1,JHEP)=JCL JDAHEP(1,KHEP)=JCL ISTHEP(JHEP)=ISTHEP(JHEP)+8 ISTHEP(KHEP)=ISTHEP(KHEP)+8 CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL)) ENDIF 120 CONTINUE NHEP=JCL C Fix up momenta for single-hadron clusters 130 DO 150 JCL=IBCL,NHEP C Don't hadronize beam/target clusters IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150 IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150 C Set up flavours for cluster decay CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3) EM0=PHEP(5,JCL) IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN IF (EM0.GT.MIN(RMIN(ID1,1)+RMIN(1,ID3), $ RMIN(ID1,2)+RMIN(2,ID3))) GOTO 150 ELSE C Special for b clusters: allow 1-hadron decay above threshold IF (B1LIM*HWRGEN(1).LT.EM0/(MIN(RMIN(ID1,1)+RMIN(1,ID3), $ RMIN(ID1,2)+RMIN(2,ID3)))-1.) & GOTO 150 ENDIF EM1=RMIN(ID1,ID3) IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150 C Decide to go backward or forward to transfer 4-momentum L=1-2*HWRINT(0,1) MCL=NHEP-IBCL+1 LCL=JCL DO 140 I=1,MCL LCL=LCL+L IF (LCL.LT.IBCL) LCL=LCL+MCL IF (LCL.GT.NHEP) LCL=LCL-MCL IF (LCL.EQ.JCL) THEN IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150 CALL HWWARN('HWCFOR',101) GOTO 999 ENDIF IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140 C Rescale momenta in 2-cluster CoM CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL) CALL HWUMAS(PCL) EM2=PHEP(5,LCL) PC0=HWUPCM(PCL(5),EM0,EM2) PC1=HWUPCM(PCL(5),EM1,EM2) IF (PC1.LT.ZERO) THEN C Need to rescale other mass as well CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3) EM2=RMIN(ID1,ID3) PC1=HWUPCM(PCL(5),EM1,EM2) IF (PC1.LT.ZERO) GOTO 140 PHEP(5,LCL)=EM2 ENDIF IF (PC0.GT.ZERO) THEN PC0=PC1/PC0 CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL)) CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL)) PHEP(4,JCL)=SQRT(PC1**2+EM1**2) PHEP(5,JCL)=EM1 CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL)) CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL)) GOTO 150 ELSEIF (PC0.EQ.ZERO) THEN PHEP(5,JCL)=EM1 CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.) GOTO 150 ELSE CALL HWWARN('HWCFOR',102) GOTO 999 ENDIF 140 CONTINUE CALL HWWARN('HWCFOR',103) GOTO 999 150 CONTINUE ISTAT=60 C Non-partons labelled as partons (ie photons) should get copied DO 160 IHEP=1,NHEP IF (ISTHEP(IHEP).EQ.150) THEN NHEP=NHEP+1 JDAHEP(1,IHEP)=NHEP ISTHEP(IHEP)=157 ISTHEP(NHEP)=190 IDHW(NHEP)=IDHW(IHEP) IDHEP(NHEP)=IDPDG(IDHW(IHEP)) CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP)) C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP)) C--END FIXES JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=JMOHEP(1,IHEP) JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 ENDIF 160 CONTINUE 999 RETURN END CDECK ID>, HWCGSP. *CMZ :- -13/07/92 20.15.54 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCGSP C----------------------------------------------------------------------- C SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE C BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,PF INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST EXTERNAL HWRGEN,HWRINT IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400) LHEP=NHEP-1 MHEP=NHEP DO 100 IHEP=1,NHEP IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN JHEP=JMOHEP(2,IHEP) C BRW FIX 12/03/99 IF (JHEP.LE.0) THEN KHEP=0 DO JHEP=1,NHEP IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149 & .AND.JDAHEP(2,JHEP).LE.0) THEN KHEP=KHEP+1 JMOHEP(2,IHEP)=JHEP JDAHEP(2,JHEP)=IHEP ENDIF ENDDO IF (KHEP.EQ.0) THEN CALL HWWARN('HWCGSP',102) GOTO 999 ENDIF IF (KHEP.NE.1) THEN CALL HWWARN('HWCGSP',103) GOTO 999 ENDIF C BRW FIX 13/07/10 CALL HWWARN('HWCGSP',13) JHEP=JMOHEP(2,IHEP) C END FIX ENDIF C END FIX C---CHECK FOR DECAYED HEAVY ANTIQUARKS IF (ISTHEP(JHEP).EQ.155) THEN JHEP=JDAHEP(1,JDAHEP(2,JHEP)) DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP) 10 IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20 CALL HWWARN('HWCGSP',100) GOTO 999 20 JHEP=J ENDIF KHEP=JDAHEP(2,IHEP) C BRW FIX 12/03/99 IF (KHEP.LE.0) THEN KHEP=0 DO JHEP=1,NHEP IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149 & .AND.JMOHEP(2,JHEP).LE.0) THEN KHEP=KHEP+1 JDAHEP(2,IHEP)=JHEP JMOHEP(2,JHEP)=IHEP ENDIF ENDDO IF (KHEP.EQ.0) THEN CALL HWWARN('HWCGSP',104) GOTO 999 ENDIF IF (KHEP.NE.1) THEN CALL HWWARN('HWCGSP',105) GOTO 999 ENDIF C BRW FIX 13/07/10 CALL HWWARN('HWCGSP',15) JHEP=JMOHEP(2,IHEP) C END FIX KHEP=JDAHEP(2,IHEP) ENDIF C END FIX C---CHECK FOR DECAYED HEAVY QUARKS IF (ISTHEP(KHEP).EQ.155) THEN CALL HWWARN('HWCGSP',101) GOTO 999 ENDIF IF (IDHW(IHEP).EQ.13) THEN C---SPLIT A GLUON LHEP=LHEP+2 MHEP=MHEP+2 IF(MHEP.GT.NMXHEP) THEN CALL HWWARN('HWCGSP',106) GOTO 999 ENDIF 30 ID=HWRINT(1,NGSPL) IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30 PHEP(5,LHEP)=RMASS(ID) PHEP(5,MHEP)=RMASS(ID) C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP), & PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.) ELSE PF=HWRGEN(1) CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP)) CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP)) PHEP(5,LHEP)=PF*PHEP(5,IHEP) PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP) ENDIF CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP)) CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP)) CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP)) IDHW(LHEP)=ID+6 IDHW(MHEP)=ID IDHEP(MHEP)= IDPDG(ID) IDHEP(LHEP)=-IDPDG(ID) ISTHEP(IHEP)=2 ISTHEP(LHEP)=150 ISTHEP(MHEP)=150 C---NEW COLOUR CONNECTIONS IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP JMOHEP(1,LHEP)=JMOHEP(1,IHEP) JMOHEP(2,LHEP)=MHEP JMOHEP(1,MHEP)=JMOHEP(1,IHEP) JMOHEP(2,MHEP)=JHEP JDAHEP(1,LHEP)=0 JDAHEP(2,LHEP)=KHEP JDAHEP(1,MHEP)=0 JDAHEP(2,MHEP)=LHEP JDAHEP(1,IHEP)=LHEP JDAHEP(2,IHEP)=MHEP ELSE C---COPY A NON-GLUON LHEP=LHEP+1 MHEP=MHEP+1 IF(MHEP.GT.NMXHEP) THEN CALL HWWARN('HWCGSP',107) GOTO 999 ENDIF CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP)) CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP)) IDHW(MHEP)=IDHW(IHEP) IDHEP(MHEP)=IDHEP(IHEP) IST=ISTHEP(IHEP) ISTHEP(IHEP)=2 IF (IST.EQ.149) THEN ISTHEP(MHEP)=150 ELSE ISTHEP(MHEP)=IST+6 ENDIF C---NEW COLOUR CONNECTIONS IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) & JMOHEP(2,KHEP)=MHEP IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP)) & JDAHEP(2,JHEP)=MHEP JMOHEP(1,MHEP)=JMOHEP(1,IHEP) JMOHEP(2,MHEP)=JMOHEP(2,IHEP) JDAHEP(1,MHEP)=0 JDAHEP(2,MHEP)=JDAHEP(2,IHEP) JDAHEP(1,IHEP)=MHEP ENDIF ENDIF 100 CONTINUE NHEP=MHEP 999 RETURN END CDECK ID>, HWCHAD. *CMZ :- -26/04/91 14.00.57 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2) C----------------------------------------------------------------------- C HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3 C ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED C (IN SPECIAL CLUSTER CODE - SEE HWCFLA) C C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ, & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP, & IM,JM,KM,IB LOGICAL DIQK EXTERNAL HWRGEN,HWRINT DIQK(ID)=ID.GT.3.AND.ID.LT.10 IF (IERROR.NE.0) RETURN ID2=0 EM0=PHEP(5,JCL) IF (LOCN(ID1,ID3).LE.0) THEN CALL HWWARN('HWCHAD',104) GOTO 999 ENDIF IR1=NCLDK(LOCN(ID1,ID3)) EM1=RMIN(ID1,ID3) IF (ABS(EM0-EM1).LT.0.001) THEN C---SINGLE-HADRON CLUSTER NHEP=NHEP+1 IF (NHEP.GT.NMXHEP) THEN CALL HWWARN('HWCHAD',100) GOTO 999 ENDIF IDHW(NHEP)=IR1 IDHEP(NHEP)=IDPDG(IR1) ISTHEP(NHEP)=191 JDAHEP(1,JCL)=NHEP JDAHEP(2,JCL)=NHEP CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP)) CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP)) ELSE NTRY=0 IDMIN=1 EMLOW=RMIN(ID1,1)+RMIN(1,ID3) EMADU=RMIN(ID1,2)+RMIN(2,ID3) IF (EMADU.LT.EMLOW) THEN IDMIN=2 EMLOW=EMADU ENDIF EMSQ=EM0**2 PCMAX=EMSQ-EMLOW**2 IF (PCMAX.GE.ZERO) THEN C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A C QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2) IMAX=12 IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3 DO 10 I=3,IMAX IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20 10 CONTINUE I=IMAX+1 20 ID2=HWRINT(1,I-1) IF (PWT(ID2).NE.ONE) THEN IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20 ENDIF C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS NTRY=NTRY+1 30 IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2)) IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30 IR1=NCLDK(IR1) 40 IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4)) IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40 IR2=NCLDK(IR2) EM1=RMASS(IR1) EM2=RMASS(IR2) PCM=EMSQ-(EM1+EM2)**2 IF (PCM.GT.ZERO) GOTO 70 IF (NTRY.LE.NDTRY) GOTO 20 C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST 60 ID2=HWRINT(1,2) IR1=NCLDK(LOCN(ID1,ID2)) IR2=NCLDK(LOCN(ID2,ID3)) EM1=RMASS(IR1) EM2=RMASS(IR2) PCM=EMSQ-(EM1+EM2)**2 IF (PCM.GT.ZERO) GOTO 70 NTRY=NTRY+1 IF (NTRY.LE.NDTRY+50) GOTO 60 CALL HWWARN('HWCHAD',101) GOTO 999 C---DECAY IS ALLOWED 70 PCM=PCM*(EMSQ-(EM1-EM2)**2) IF (NTRY.GT.NCTRY) GOTO 80 PTEST=PCM*SWTEF(IR1)*SWTEF(IR2) IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20 ELSE C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY ID2=1 IR2=NCLDK(LOCN(1,1)) EM2=RMASS(IR2) PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2) ENDIF C---DECAY IS CHOSEN. GENERATE DECAY MOMENTA C AND PUT PARTICLES IN /HEPEVT/ 80 IF (PCM.LT.ZERO) THEN CALL HWWARN('HWCHAD',102) GOTO 999 ENDIF PCM=0.5*SQRT(PCM)/EM0 MHEP=NHEP+1 NHEP=NHEP+2 IF (NHEP.GT.NMXHEP) THEN CALL HWWARN('HWCHAD',103) GOTO 999 ENDIF PHEP(5,MHEP)=EM1 PHEP(5,NHEP)=EM2 C Decide if cluster contains a b-(anti)quark or not IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN IB=2 ELSE IB=1 ENDIF IF (CLDIR(IB).NE.0) THEN DO 110 IM=1,2 JM=JMOHEP(IM,JCL) IF (JM.EQ.0) GOTO 110 IF (ISTHEP(JM).NE.158) GOTO 110 C LOOK FOR PARENT PARTON DO 100 KM=JMOHEP(1,JM)+1,JM IF (ISTHEP(KM).EQ.2) THEN IF (JDAHEP(1,KM).EQ.JM) THEN C FOUND PARENT PARTON IF (IDHW(KM).NE.13) THEN C FIND ITS DIRECTION IN CLUSTER CMF CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP) PCQK=PP(1)**2+PP(2)**2+PP(3)**2 IF (PCQK.GT.ZERO) THEN PCQK=SQRT(PCQK) IF (CLSMR(IB).GT.ZERO) THEN C DO GAUSSIAN SMEARING OF DIRECTION 90 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0)) IF (CT.LT.-ONE) GOTO 90 ST=ONE-CT*CT IF (ST.GT.ZERO) ST=SQRT(ST) CALL HWRAZM( ONE,CX,SX) CALL HWUROT(PP,CX,SX,RMAT) PP(1)=ZERO PP(2)=PCQK*ST PP(3)=PCQK*CT CALL HWUROB(RMAT,PP,PP) ENDIF PCQK=PCM/PCQK IF (IM.EQ.2) PCQK=-PCQK CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP)) PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2) CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP)) CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP)) GOTO 130 ENDIF ENDIF GOTO 120 ENDIF ELSEIF (ISTHEP(KM).GT.140) THEN C FINISHED THIS JET GOTO 110 ENDIF 100 CONTINUE 110 CONTINUE ENDIF 120 CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP), & PCM,TWO,.TRUE.) 130 IDHW(MHEP)=IR1 IDHW(NHEP)=IR2 IDHEP(MHEP)=IDPDG(IR1) IDHEP(NHEP)=IDPDG(IR2) ISTHEP(MHEP)=192 ISTHEP(NHEP)=192 JMOHEP(1,MHEP)=JCL C---SECOND MOTHER OF HADRON IS JET JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL)) JDAHEP(1,JCL)=MHEP JDAHEP(2,JCL)=NHEP C---SMEAR HADRON POSITIONS HPSMR=GEV2MM/PHEP(5,JCL) DO I=1,4 VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR) ENDDO VHEP(4,MHEP)=ABS(VHEP(4,MHEP)) & +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP))) CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP)) CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP)) CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP)) DO I=1,4 VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR) ENDDO VHEP(4,NHEP)=ABS(VHEP(4,NHEP)) & +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP))) CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP)) CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP)) CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP)) ENDIF ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10) JMOHEP(1,NHEP)=JCL JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL)) 999 RETURN END CDECK ID>, HWD2ME. *CMZ :- -09/04/02 13:37:38 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD2ME(IMODE) C----------------------------------------------------------------------- C Computes the width and maximum weight for a two body mode C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IMODE,I DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2, & M2(3) EXTERNAL HWUPCM C--set up the masses and couplings M(1) = RMASS(IDK(ID2PRT(IMODE))) DO 1 I=1,2 A(I) = A2MODE(I,IMODE) 1 M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE))) DO 2 I=1,3 2 M2(I) = M(I)**2 C--first compute the masses etc PCM = HWUPCM(M(1),M(2),M(3)) PCM2 = PCM**2 PHS = PCM/M2(1)/8.0D0/PIFAC C--now compute the width and max weight C--first the fermion --> fermion scalar diagrams IF(I2DRTP(IMODE).EQ.1) THEN WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3)) & +FOUR*A(1)*A(2)*M(1)*M(2)) E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT C--next the fermion --> scalar fermion diagrams ELSEIF(I2DRTP(IMODE).EQ.2) THEN WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2)) & +FOUR*A(1)*A(2)*M(1)*M(3)) E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT C--next the fermion --> scalar antifermion diagrams ELSEIF(I2DRTP(IMODE).EQ.3) THEN WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2)) & +FOUR*A(1)*A(2)*M(1)*M(3)) E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT C--next the fermion --> fermion gauge boson diagrams ELSEIF(I2DRTP(IMODE).EQ.4) THEN WGT = 2.0D0*(M2(1)-M2(2))**2 MWGT = WGT C--next the scalar --> fermion antifermion diagrams ELSEIF(I2DRTP(IMODE).EQ.5) THEN WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2) & -FOUR*M(2)*M(3)*A(1)*A(2) MWGT = WGT C--next the scalar --> fermion fermion diagrams ELSEIF(I2DRTP(IMODE).EQ.6) THEN WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2) & -FOUR*M(2)*M(3)*A(1)*A(2) MWGT = WGT C--next the fermion --> fermion pion diagrams ELSEIF(I2DRTP(IMODE).EQ.7) THEN WGT = HALF/FOUR/RMASS(198)**4*( & (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2))) & +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2)) E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)* & M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT C--next scalar --> antifermion fermion diagrams ELSEIF(I2DRTP(IMODE).EQ.8) THEN WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2) & -FOUR*M(2)*M(3)*A(1)*A(2) MWGT = WGT C--next fermion --> gravitino photon ELSEIF(I2DRTP(IMODE).EQ.9) THEN WGT = 8.0D0*M2(1)**3 MWGT = WGT C--next fermion --> gravitino scalar ELSEIF(I2DRTP(IMODE).EQ.10) THEN WGT = HALF*(M2(1)-M2(3))**3 E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT C--next sfermion --> fermion gravitino ELSEIF(I2DRTP(IMODE).EQ.11) THEN WGT = (M2(1)-M2(2))**3 MWGT = WGT C--next antisfermion --> fermion gravitino ELSEIF(I2DRTP(IMODE).EQ.12) THEN WGT = (M2(1)-M2(2))**3 MWGT = WGT C--next the scalar --> antifermion antifermion diagrams ELSEIF(I2DRTP(IMODE).EQ.13) THEN WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2) & -FOUR*M(2)*M(3)*A(1)*A(2) MWGT = WGT C--next the antifermion --> scalar antifermion diagrams ELSEIF(I2DRTP(IMODE).EQ.14) THEN WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2)) & +FOUR*A(1)*A(2)*M(1)*M(3)) E1 = SQRT(M2(2)+PCM2) E2 = SQRT(M2(3)+PCM2) MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT C--unrecognised issue warning ELSE CALL HWWARN('HWITWO',500) ENDIF WGT = P2MODE(IMODE)* WGT*PHS MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS C--put the information in the common block WT2MAX(IMODE) = MWGT C--output the information IF(IPRINT.GE.2) THEN WRITE(*,3010) WGT WRITE(*,3020) MWGT WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))* & RLTIM(IDK(ID2PRT(IMODE))) ENDIF RETURN C--format statements 3010 FORMAT(' PARTIAL WIDTH = ',G12.4) 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4) 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4) END CDECK ID>, HWD3ME. *CMZ :- -20/10/99 09:46:43 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN) C----------------------------------------------------------------------- C Subroutine to perform the three body decays for spin correlations C and SUSY three body modes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2, & DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI, & HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX, & BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX) DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8), & F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8) EXTERNAL HWRUNI,HWUPCM,HWRGEN COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF SAVE BRW,BRZ DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/ DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/ C--compute the masses of external particles for the decay mode C--first for true three body decay modes IF(ITYPE.EQ.0) THEN C--initalisation for the diagrams WTMAX = WT3MAX(IMODE) PRE = P3MODE(IMODE) NCTHRE = N3NCFL(IMODE) NDIA = NDI3BY(IMODE) IDP(1) = IDK(ID3PRT(IMODE)) DO 1 I=1,3 1 IDP(I+1) = IDKPRD(I,ID3PRT(IMODE)) DO 2 I=1,NCTHRE DO 2 J=1,NCTHRE 2 CFTHRE(I,J) = SPN3CF(I,J,IMODE) C--enter the couplings for the diagrams DO 3 I=1,NDI3BY(IMODE) DRTYPE(I) = I3DRTP(I,IMODE) DRCF (I) = I3DRCF(I,IMODE) DO 3 J=1,2 A(J,I) = A3MODE(J,I,IMODE) 3 B(J,I) = B3MODE(J,I,IMODE) C--enter the intermediate masses for the diagrams DO 4 I=1,NDI3BY(IMODE) IDP(I+4) = I3MODE(I,IMODE) MR(I) = RMASS(I3MODE(I,IMODE)) MS(I) = MR(I)**2 IF(I3MODE(I,IMODE).GT.200) THEN MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE)) ELSEIF(I3MODE(I,IMODE).EQ.200) THEN MWD(I) = RMASS(200)*GAMZ ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN MWD(I) = RMASS(198)*GAMW ELSEIF(I3MODE(I,IMODE).EQ.59) THEN MWD(I) = 0.0D0 ENDIF 4 CONTINUE C--reorder for top quark decay modes(b first then W products) IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN I = IDP(2) IDP(2) = IDP(4) IDP(4) = IDP(3) IDP(3) = I ENDIF C--reorder if fermion not first IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR. & IDP(2).GE.400)) THEN I = IDP(3) IDP(3) = IDP(4) IDP(4) = I ENDIF C--then for two body modes to gauge bosons including boson decays ELSE C--initalisation for the diagram WTMAX = WTBMAX(ITYPE,IMODE) NDIA = 1 PRE = PBMODE(ITYPE,IMODE) DRTYPE(1) = IBDRTP(IMODE) DRCF (1) = 1 NCTHRE = 1 CFTHRE(1,1) = ONE C--particles in decay IDP(1) = IDK(IDBPRT(IMODE)) IDP(2) = IDKPRD(1,IDBPRT(IMODE)) IF(IDP(2).GE.198.AND.IDP(2).LE.200) & IDP(2) = IDKPRD(2,IDBPRT(IMODE)) IDP(5) = IBMODE(IMODE) C--masses of virtual particles and couplings MR(1) = RMASS(IBMODE(IMODE)) MS(1) = MR(1)**2 DO J=1,2 A(J,1) = ABMODE(J,IMODE) B(J,1) = BBMODE(J,ITYPE,IMODE) ENDDO IF(IBMODE(IMODE).EQ.200) THEN MWD(1) = RMASS(200)*GAMZ ELSE MWD(1) = RMASS(198)*GAMW ENDIF C--particles from boson decay IF(IBMODE(IMODE).EQ.200) THEN ID1 = ITYPE IF(ITYPE.GT.6) ID1 = ID1+114 ID2 = ID1+6 ELSE ID1 = 2*ITYPE-1 IF(ITYPE.GT.3) ID1 = ID1+114 ID2 = ID1+7 IF(IBMODE(IMODE).EQ.198) THEN I = ID1+6 ID1 = ID2-6 ID2 = I ENDIF ENDIF IDP(3) = ID1 IDP(4) = ID2 C--only do the decay if possible for an on-shell boson IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN IF(IPRINT.GE.2.AND..NOT.GENEV) & WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)) MA(3) = RMASS(IDP(3)) MA(4) = RMASS(IDP(4)) DO 5 I=1,4 5 MA2(I) = MA(I)**2 ENDIF C--set up the masses MA OFF SHELL MB ON SHELL DO 6 I=1,4 MB(I) = RMASS(IDP(I)) MB2(I) = MB(I)**2 IF(.NOT.GENEV) THEN MA (I) = MB (I) MA2(I) = MB2(I) ENDIF 6 CONTINUE IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN C--compute the width and maximum weight if initialising IF(.NOT.GENEV) THEN C--search for maximum weight WMAX = ZERO WSUM = ZERO WSSUM = ZERO DO 7 I=1,NSEARCH CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN) WGT = WGT*PRE WGTM=WGTM*PRE IF(WGTM.GT.WMAX) WMAX = WGTM WSUM = WSUM+WGT WSSUM = WSSUM+WGT**2 IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500) 7 CONTINUE C--compute width and maximum weight WSUM = WSUM/DBLE(NSEARCH) WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2) WSSUM = SQRT(WSSUM/DBLE(NSEARCH)) C--if required output results IF(IPRINT.GE.2) THEN WRITE(6,3010) WSUM,WSSUM WRITE(6,3020) WMAX IF(ITYPE.EQ.0) THEN TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE))) ELSE IF(IBMODE(IMODE).EQ.200) THEN TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/ & RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE) ELSE TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/ & RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE) ENDIF ENDIF WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP ENDIF C--set up the maximum weight IF(ITYPE.EQ.0) THEN WT3MAX(IMODE) = 1.1D0*WMAX ELSE WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX ENDIF C--if not initialising generate the momenta ELSE C--generate a configuation NTRY = 0 100 NTRY = NTRY+1 CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN) WGT = WGT*PRE C--check maximum isn't violated, increase and issue warning if it is IF(WGT.GT.WTMAX) THEN CALL HWWARN('HWD3ME',1) IF(ITYPE.EQ.0) THEN WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)), & RNAME(IDP(4)),WTMAX,WGT*1.1D0 ELSE WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5)) WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)), & WTMAX,WGT*1.1D0 ENDIF WTMAX = WGT*1.1D0 IF(ITYPE.EQ.0) THEN WT3MAX(IMODE) = WTMAX ELSE WTBMAX(ITYPE,IMODE) = WTMAX ENDIF ENDIF IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100 IF(NTRY.GE.NSNTRY) THEN CALL HWWARN('HWD3ME',100) GOTO 999 ENDIF ENDIF RETURN C--format statements for the outputs 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8) 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4) 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4) 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4) 3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8, & 'EXCEEDS MAX', & /10X,' MAXIMUM WEIGHT =',1PG24.16, & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16) 3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8) 3060 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX', & /10X,' MAXIMUM WEIGHT =',1PG24.16, & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16) 999 RETURN END CDECK ID>, HWD3M0. *CMZ :- -09/04/02 13:46:07 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN) C----------------------------------------------------------------------- C Subroutine to calculate the matrix element for a given mode C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA, & DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI, & M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5), & M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5), & MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC, & HWRGEN,A02,A2 DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8), & RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8), & RHOB(2,2),F1M(2,2,8),F3(2,2,8) EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(EPS=1D-10) SAVE PREF DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/ C--select the momenta of the particles C--first see if there is a boson mode IB = -1 DO 1 I=1,NDIA IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR. & DRTYPE(I).EQ.7) IB = IDP(I+4) 1 CONTINUE C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner MMIN = (MA(3)+MA(4))**2 MMAX = (MA(1)-MA(2))**2 IF(IB.GT.0.AND.IB.NE.59) THEN CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN) ELSEIF(IB.EQ.59) THEN M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX)) M342 = EXP(M342) FJAC = (LOG(MMAX)-LOG(MMIN))*M342 ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND. & IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN A02 = ATAN((MMIN-MS(1))/MWD(1)) A2 = ATAN((MMAX-MS(1))/MWD(1))-A02 M342 = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1)) FJAC = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1) ELSE FJAC = MMAX-MMIN M342 = HWRUNI(1,MMIN,MMAX) ENDIF M34 = SQRT(M342) FJAC = HALF*FJAC/M34 C--copy the momentum of the decaying particle into the internal common block CALL HWVEQU(5,PHEP(1,ID),P(1,1)) DO 2 I=2,4 2 P(5,I) = MA(I) C--perform the decay 1---> 2+34 PCMA = HWUPCM(MA(1),MA(2),M34) PLAB(5,1) = M34 CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.) C--perform the decay 34 --> 3+4 PCMB = HWUPCM(M34,MA(3),MA(4)) CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.) C--compute the phase sapce factors PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1) C--compute the other possible masses for the propagator M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3)) M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4)) C--compute the vectors for the helicity amplitudes DO 3 I=1,4 C--compute the references vectors C--not important if SM particle which can't have spin measured C--ie anything other the top and tau C--also not important if particle is approx massless C--first the SM particles other than top and tau IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN CALL HWVEQU(5,PREF,PLAB(1,I+4)) C--all other particles ELSE PP = SQRT(HWVDOT(3,P(1,I),P(1,I))) CALL HWVSCA(3,ONE/PP,P(1,I),N) PLAB(4,I+4) = HALF*(P(4,I)-PP) PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I))) CALL HWVSCA(3,PP,N,PLAB(1,I+4)) CALL HWUMAS(PLAB(1,I+4)) PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4)) C--fix to avoid problems if approx massless due to energy IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4)) ENDIF C--now the massless vectors PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I)) DO 4 J=1,4 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4) 3 CALL HWUMAS(PLAB(1,I)) C--change order of momenta for call to HE code DO 5 I=1,4 PM(1,I) = P(3,I) PM(2,I) = P(1,I) PM(3,I) = P(2,I) PM(4,I) = P(4,I) 5 PM(5,I) = P(5,I) DO 6 I=1,8 PCM(1,I)=PLAB(3,I) PCM(2,I)=PLAB(1,I) PCM(3,I)=PLAB(2,I) PCM(4,I)=PLAB(4,I) 6 PCM(5,I)=PLAB(5,I) C--compute the S functions CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D) DO 7 I=1,8 DO 7 J=1,8 S(I,J,2) = -S(I,J,2) 7 D(I,J) = TWO*D(I,J) C--compute the F functions CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP) CALL HWUMAS(PTMP) CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1)) CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2)) CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3)) CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4)) CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1)) CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2)) CALL HWH2F3(8,F01,PTMP,ZERO) C--now find the prefactor for all the diagrams PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))* & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4)) PRE = ONE/SQRT(PRE) C--zero the matrix element DO 8 P0=1,2 DO 8 P1=1,2 DO 8 P2=1,2 DO 8 P3=1,2 DO 8 I =1,NCTHRE 8 ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0) C--now call the subroutines to compute the individual diagrams DO 9 I=1,NDIA C--vector boson exchange diagram IF(DRTYPE(I).EQ.1) THEN CALL HWD3M1(I,MED) C--Higgs boson exchange diagram ELSEIF(DRTYPE(I).EQ.2) THEN CALL HWD3M2(I,MED) C--antisfermion exchange diagram ELSEIF(DRTYPE(I).EQ.3) THEN CALL HWD3M3(I,MED) C--sfermion exchange diagram ELSEIF(DRTYPE(I).EQ.4) THEN CALL HWD3M4(I,MED) C--antifermion vector boson exchange diagram ELSEIF(DRTYPE(I).EQ.5) THEN CALL HWD3M5(I,MED) C--scalar vector boson exchange diagram ELSEIF(DRTYPE(I).EQ.6) THEN CALL HWD3M6(I,MED) C--gravitino fermion fermion ELSEIF(DRTYPE(I).EQ.7) THEN CALL HWD3M7(I,MED) C--fermion RPV1 ELSEIF(DRTYPE(I).EQ.8) THEN CALL HWD3M8(I,MED) C--fermion RPV2 ELSEIF(DRTYPE(I).EQ.9) THEN CALL HWD3M9(I,MED) C--fermion RPV3 ELSEIF(DRTYPE(I).EQ.10) THEN CALL HWD3MA(I,MED) C--fermion --> 3 fermions 1 ELSEIF(DRTYPE(I).EQ.11) THEN CALL HWD3MB(I,MED) C--fermion --> 3 fermions 2 ELSEIF(DRTYPE(I).EQ.12) THEN CALL HWD3MC(I,MED) C--fermion --> 3 fermions 3 ELSEIF(DRTYPE(I).EQ.13) THEN CALL HWD3MD(I,MED) C--fermion --> 3 antifermions 1 ELSEIF(DRTYPE(I).EQ.14) THEN CALL HWD3MF(I,MED) C--fermion --> 3 antifermions 2 ELSEIF(DRTYPE(I).EQ.15) THEN CALL HWD3MG(I,MED) C--fermion --> 3 antifermions 3 ELSEIF(DRTYPE(I).EQ.16) THEN CALL HWD3MH(I,MED) C--antifermion --> antifermion fermion fermion ELSEIF(DRTYPE(I).EQ.17) THEN CALL HWD3MI(I,MED) C--error not known ELSE CALL HWWARN('HWD3M0',501) ENDIF C--add up the matrix elements DO 10 P0=1,2 DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 10 ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I)) & +MED(P0,P1,P2,P3) 9 CONTINUE C--preform the final normalisation DO 15 P0=1,2 DO 15 P1=1,2 DO 15 P2=1,2 DO 15 P3=1,2 DO 15 I =1,NCTHRE 15 ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I) C--compute the unnormalised spin density matrix DO 35 P0 =1,2 DO 35 P0P=1,2 RHOB(P0,P0P) = (0.0D0,0.0D0) DO 35 P1=1,2 DO 35 P2=1,2 DO 35 P3=1,2 DO 35 I =1,NCTHRE DO 35 J =1,NCTHRE 35 RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)* & DCONJG(ME(P0P,P1,P2,P3,J)) C--compute the weight WGT = ZERO DO 45 P0=1,2 DO 45 P0P=1,2 45 WGT = WGT+DREAL(RHOIN(P0,P0P)*RHOB(P0,P0P)) C--normalise this for phase space WGT = WGT*PHS C--if initialising select the max weight IF(SYSPIN.OR.THREEB) & MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2))) & +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2)))) C--if generating the event put the information in the common block IF(GENEV) THEN C--put the matrix element into the spin common block IF(SYSPIN) THEN DO 25 P0=1,2 DO 25 P1=1,2 DO 25 P2=1,2 DO 25 P3=1,2 DO 25 I =1,NCTHRE 25 MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I) NCFL(IDSPIN) = NCTHRE ENDIF C--if more than one colour flow pick the flow IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN C--contstruct the matrix elements for the colour flows WGTC = ZERO DO 50 I=1,NCTHRE WGTB(I) = ZERO DO 55 P0=1,2 DO 55 P0P=1,2 DO 55 P1=1,2 DO 55 P2=1,2 DO 55 P3=1,2 55 WGTB(I) = WGTB(I)+CFTHRE(I,I)*DREAL( & RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I))) WGTB(I) = WGTB(I)*PHS 50 WGTC = WGTC+WGTB(I) WGTC = WGT/WGTC DO 60 I=1,NCTHRE 60 WGTB(I) = WGTB(I)*WGTC C--select the colour flow WGTC = HWRGEN(1)*WGT DO 70 I=1,NCTHRE IF(WGTB(I).GE.WGTC) THEN NCFL(IDSPIN) = I RETURN ENDIF 70 WGTC = WGTC-WGTB(I) C--otherwise if wrong options set issue warning ELSEIF(NCTHRE.NE.1) THEN WRITE(6,1000) CALL HWWARN('HWD3M0',500) ENDIF ENDIF 1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED') END CDECK ID>, HWD3M1. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M1(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C gauge boson exchange diagram C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2), & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN, & MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID)) CN = -ONE/MS(ID) C--compute the C and D functions DO 10 P1=1,2 DO 10 P2=1,2 IF(P1.EQ.P2) THEN C--the A functions APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 ) APM(P1,P2) = 0.0D0 AMP(P1,P2) = 0.0D0 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4) C--the C and E functions C(P1,P2) = A( P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5, P2 ) & -MA2(2)*S(6,1,O(P2))*S(1,5, P2 )) & +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5, P2 ) & -S(6,2,O(P2))*S(2,5, P2 )) E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 ) & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 )) & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 ) & +S(7,4,O(P1))*S(4,8, P1 ))) ELSE C--the A functions APP(P1,P2) = 0.0D0 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1)) AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1)) AMM(P1,P2) = 0.0D0 C--the C and D functions C(P1,P2) = A( P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2)) & -S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2))) & +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2)) & +S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2))) E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))) & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))) ENDIF 10 CONTINUE C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 ME(P0,P1,P2,P3) = & APP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,4)*F0( P2 ,O(P0),3) & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4)) & +APM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7) & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),4)) & +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,8)*F0( P2 ,O(P0),3) & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8)) & +AMM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7) & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),8)) 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3)) END CDECK ID>, HWD3M2. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M2(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C Higgs boson exchange diagram C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND. & IDP(4+ID).NE.206) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--calculate the propagator factor PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID)) C--calculate the vertex functions DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1) & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1)) 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2) & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4) C--calculate the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3) END CDECK ID>, HWD3M3. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M3(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C antisfermion exchange diagram C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID)) C--compute the vertex factors DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1) & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1)) 10 V2(P1,P2) = B( P2 ,ID)*F1(O(P1), P2 ,4)*S(4,8,P2) & -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4) C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3) END CDECK ID>, HWD3M4. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M4(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C sfermion exchange diagram C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID)) C--compute the factors for the two vertices DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8, P2 ) & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4)) 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1)) & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2) C--now compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2) END CDECK ID>, HWD3M5. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M5(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C gauge boson exchange diagram (antiparticle decay) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8), & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2), & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID)) CN = -ONE/MS(ID) C--compute the C and D functions DO 10 P1=1,2 DO 10 P2=1,2 IF(P1.EQ.P2) THEN C--the A functions APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 ) APM(P1,P2) = 0.0D0 AMP(P1,P2) = 0.0D0 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4) C--the C and E functions C(P1,P2) = A( P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6, P1 ) & -MA2(2)*S(5,1,O(P1))*S(1,6, P1 )) & +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6, P1 ) & -S(5,2,O(P1))*S(2,6, P1 )) E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 ) & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 )) & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 ) & +S(7,4,O(P1))*S(4,8, P1 ))) ELSE C--the A functions APP(P1,P2) = 0.0D0 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1)) AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1)) AMM(P1,P2) = 0.0D0 C--the C and D functions C(P1,P2) = A( P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1)) & -S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1))) & +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1)) & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1))) E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))) & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))) ENDIF 10 CONTINUE C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 ME(P0,P1,P2,P3) = & APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,4)*F1M( P2 ,O(P1),3) & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4)) & +APM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7) & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),4)) & +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,8)*F1M( P2 ,O(P1),3) & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8)) & +AMM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7) & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),8)) 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3)) END CDECK ID>, HWD3M6. *CMZ :- -10/10/01 14:34:54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M6(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C gauge boson exchange diagram C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8), & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2), & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR, & P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF DOUBLE PRECISION XMASS,PLAB,PRW,PCM COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))) PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID)) CN = -ONE/MS(ID) DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4)) & +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4)) C--compute the C and D functions DO 10 P1=1,2 DO 10 P2=1,2 IF(P1.EQ.P2) THEN C--the A functions APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 ) APM(P1,P2) = 0.0D0 AMP(P1,P2) = 0.0D0 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4) C--the C function C(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 ) & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 )) & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 ) & +S(7,4,O(P1))*S(4,8, P1 ))) ELSE C--the A functions APP(P1,P2) = 0.0D0 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1)) AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1)) AMM(P1,P2) = 0.0D0 C--the C functions C(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))) & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))) ENDIF 10 CONTINUE C--compute the matrix element DO 15 P0=1,2 DO 15 P1=1,2 DO 15 P2=1,2 DO 15 P3=1,2 15 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) DO 20 P2=1,2 DO 20 P3=1,2 20 ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3) & +APP(P2,P3)*F01( P2 , P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4) & +AMP(P2,P3)*F01( P2 , P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8)) END CDECK ID>, HWD3M7. *CMZ :- -13/03/02 14:19:47 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M7(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C decay fermion --> gravitino fermion antifermion (via gauge boson) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2) INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) DOUBLE PRECISION XMASS,PLAB,PRW,PCM COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O,DL DATA O/2,1/ DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/ C--compute the propagator factor PRE = HALF*HWULDO(PCM(1,6),PM(1,2))* & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4)) PRE = SQRT(PRE) PRE = PRE/(M342-MS(ID)+ZI*MWD(ID)) DO 10 P0=1,2 DO 10 P1=1,2 ME(P0,P1, P1 , P1 ) = PRE*B( P1 ,ID)*( & A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2, P1 )*F0(O(P1),O(P0),2) & +A(2,ID)* DL(P1,1)*S(2,3, P1 )*S(4,2,O(P1))*F0( 1 ,O(P0),2)) ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*( & A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2, P1 )*F0(O(P1),O(P0),2) & +A(2,ID)* DL(P1,1)*S(2,4, P1 )*S(3,2,O(P1))*F0( 1 ,O(P0),2)) ME(P0,P1,O(P1), P1 ) = (0.0D0,0.0D0) 10 ME(P0,P1, P1 ,O(P1)) = (0.0D0,0.0D0) END CDECK ID>, HWD3M8. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M8(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 1st 3 body RPV C diagram f--> fbar fbar f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--calculate the propagator factor PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID)) C--calculate the vertex functions DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6, P2) & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2)) 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,3)*S(3,7,P1) & -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3) C--calculate the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3) END CDECK ID>, HWD3M9. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3M9(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV C diagram f --> fbar fbar f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID)) C--compute the vertex factors DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7,P2) & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3)) 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,2)*S(2,6,P1) & -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2) C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3) END CDECK ID>, HWD3MA. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MA(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV C diagram f --> fbar fbar f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID)) C--compute the factors for the two vertices DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P1 ,ID)*F3(O(P2), P1 ,1)*S(1,5,P1) & +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1)) 10 V2(P1,P2) = B( P2 ,ID)*F1( P1 , P2 ,3)*S(3,7,P2) & -B(O(P2),ID)*F1( P1 ,O(P2),7)*MA(3) C--now compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2) END CDECK ID>, HWD3MB. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MB(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 4th 3 body RPV C diagram f --> f f f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--calculate the propagator factor PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID)) C--calculate the vertex functions DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1) & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1)) 10 V2(P1,P2) = B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2)) & -B( P2 ,ID)*F2(O(P1), P2 ,8)*MA(4) C--calculate the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3) END CDECK ID>, HWD3MC. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MC(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 5th 3 body RPV C diagram f --> f f f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID)) C--compute the vertex factors DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1) & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1)) 10 V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2)) & -B( P2 ,ID)*F1(O(P1), P2 ,8)*MA(4) C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3) END CDECK ID>, HWD3MD. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MD(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 6th 3 body RPV C diagram f --> f f f C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID)) C--compute the factors for the two vertices DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A(O(P2),ID)*F0M( P1 ,O(P2),4)*S(4,8,O(P2)) & -A( P2 ,ID)*F0M( P1 , P2 ,8)*MA(4)) 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1)) & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2) C--now compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2) END CDECK ID>, HWD3MF. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MF(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 7th 3 body RPV C diagram f --> fbar fbar fbar C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--calculate the propagator factor PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID)) C--calculate the vertex functions DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6,P2) & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2)) 10 V2(P1,P2) = B( P2 ,ID)*F2( P1 , P2 ,4)*S(4,8,P2) & -B(O(P2),ID)*F2( P1 ,O(P2),8)*MA(4) C--calculate the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3) END CDECK ID>, HWD3MG. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MG(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 8th 3 body RPV C diagram f --> fbar fbar fbar C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID)) C--compute the vertex factors DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7, P2 ) & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3)) 10 V2(P1,P2) = B( P1 ,ID)*F3 ( P2 , P1 ,2)*S(2,6, P1 ) & -B(O(P1),ID)*F3 ( P2 ,O(P1),6)*MA(2) C--compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3) END CDECK ID>, HWD3MH. *CMZ :- -08/04/02 14:48:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MH(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for 9th 3 body RPV C diagram f --> fbar fbar fbar C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--compute the propagator factor PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID)) C--compute the factors for the two vertices DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8,P2) & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4)) 10 V2(P1,P2) = B( P1 ,ID)*F2 ( P2 , P1 ,2)*S(2,6,P1) & -B(O(P1),ID)*F2 ( P2 ,O(P1),6)*MA(2) C--now compute the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2) END CDECK ID>, HWD3MI. *CMZ :- -09/04/02 13:37:38 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD3MI(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the three body C Higgs boson exchange diagram antifermion decay C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8), & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8), & F3(2,2,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--decide whether to do the diagram IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND. & IDP(4+ID).NE.207) THEN DO 5 P0=1,2 DO 5 P1=1,2 DO 5 P2=1,2 DO 5 P3=1,2 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) RETURN ENDIF C--calculate the propagator factor PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID)) C--calculate the vertex functions DO 10 P1=1,2 DO 10 P2=1,2 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M(O(P1), P2 ,2)*S(2,6,P2) & -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2)) 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2) & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4) C--calculate the matrix element DO 20 P0=1,2 DO 20 P1=1,2 DO 20 P2=1,2 DO 20 P3=1,2 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3) END CDECK ID>, HWD4ME. *CMZ :- -20/10/99 09:46:43 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE) C----------------------------------------------------------------------- C Subroutine to perform the four body Higgs decays C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12), & HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5) EXTERNAL HWRUNI,HWUPCM,HWRGEN COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP SAVE BRW,BRZ DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/ DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/ ITYPE(1) = ITYPE1 ITYPE(2) = ITYPE2 WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE) PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE) C--compute the masses of external particles for the decay mode DO I=1,2 C--couplings and masses of the internal particles A(I) = A4MODE(I,ITYPE1,IMODE) B(I) = B4MODE(I,ITYPE2,IMODE) MR(I) = RMASS(I4MODE(I,IMODE)) MS(I) = MR(I)**2 IF(I4MODE(I,IMODE).EQ.200) THEN MWD(I) = MR(I)*GAMZ ELSE MWD(I) = MR(I)*GAMW ENDIF IDP(5+I) = I4MODE(I,IMODE) C--id's of outgoing particles IF(I4MODE(I,IMODE).EQ.200) THEN IDP(2*I ) = ITYPE(I) IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114 IDP(2*I+1) = IDP(2*I)+6 ELSE IDP(2*I ) = 2*ITYPE(I)-1 IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114 IDP(2*I+1) = IDP(2*I)+7 IF(I4MODE(I,IMODE).EQ.198) THEN J = IDP(2*I )+6 IDP(2*I) = IDP(2*I+1)-6 IDP(2*I+1) = J ENDIF ENDIF ENDDO IDP(1) = IDK(ID4PRT(IMODE)) DO 1 I=1,5 M(I) = RMASS(IDP(I)) 1 M2(I) = M(I)**2 IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR. & MR(2).LT.M(4)+M(5)) RETURN IF(IPRINT.GE.2.AND..NOT.GENEV) & WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)), & RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5)) C--compute the width and maximum weight if initialising IF(.NOT.GENEV) THEN WMAX = ZERO WSUM = ZERO WSSUM = ZERO DO I=1,NSEARCH CALL HWD4M0(1,WGT) WGT = WGT*PRE IF(WGT.GT.WMAX) WMAX = WGT WSUM = WSUM+WGT WSSUM = WSSUM+WGT**2 IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500) ENDDO WSUM = WSUM/DBLE(NSEARCH) WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2) WSSUM = SQRT(WSSUM/DBLE(NSEARCH)) IF(IPRINT.GE.2) WRITE(6,3010) WSUM,WSSUM IF(IPRINT.GE.2) WRITE(6,3020) WMAX TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE))) DO J=1,2 IF(I4MODE(J,IMODE).EQ.200) THEN TEMP = TEMP*BRZ(ITYPE(J)) ELSE TEMP = TEMP*BRW(ITYPE(J)) ENDIF ENDDO IF(IPRINT.GE.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP C--set up the maximum weight WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX ELSE C--generate a configuation NTRY = 0 IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501) 100 NTRY = NTRY+1 CALL HWD4M0(ID,WGT) WGT = WGT*PRE IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100 IF(NTRY.GE.NSNTRY) THEN CALL HWWARN('HWD4ME',100) GOTO 999 ENDIF ENDIF 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ', & A8,' --> ',A8,' ',A8) 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4) 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4) 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4) 999 RETURN END CDECK ID>, HWD4M0. *CMZ :- -11/10/01 12:32:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWD4M0(ID,WGT) C----------------------------------------------------------------------- C Subroutine to calculate the matrix element for a given four body C decay mode C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI, & M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS, & M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5), & M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2), & AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI, & F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2) LOGICAL HWRLOG EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0)) SAVE O,PREF DATA O/2,1/ DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/ C--select the masses of the gauge bosons and compute Jacobians IF(HWRLOG(HALF)) THEN CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2, & (M(2)+M(3))**2) M23 = SQRT(M232) CALL HWHGB1(1,2,IDP(7),MJAC(2),M452, & (M(1)-M23)**2,(M(4)+M(5))**2) M45 = SQRT(M452) ELSE CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2, & (M(4)+M(5))**2) M45 = SQRT(M452) CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2, & (M(2)+M(3))**2) M23 = SQRT(M232) ENDIF MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2) MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2) DO 1 I=2,5 1 P(5,I) = M(I) DO 2 I=1,2 2 CN(I) = -ONE/MS(I) C--now perform the decay of the Higgs to the bosons PCMA = HWUPCM(M(1),M23,M45) PLAB(5,1) = M23 PLAB(5,2) = M45 CALL HWVEQU(5,PHEP(1,ID),P(1,1)) CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.) PCMB(1) = HWUPCM(M23,M(2),M(3)) CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.) PCMB(2) = HWUPCM(M45,M(4),M(5)) CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.) DOT = HWULDO(PLAB(1,1),PLAB(1,2)) C--compute the phase sapce factors PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/ & M2(1)/M23/M45 C--compute the vectors for the helicity amplitudes DO 3 I=1,4 II=I+1 C--compute the references vectors C--not important if SM particle which can't have spin measured C--ie anything other the top and tau C--also not important if particle is approx massless C--first the SM particles other than top and tau IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12 & .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN CALL HWVEQU(5,PREF,PLAB(1,I+4)) C--all other particles ELSE PP = SQRT(HWVDOT(3,P(1,II),P(1,II))) CALL HWVSCA(3,ONE/PP,P(1,II),N) PLAB(4,I+4) = HALF*(P(4,II)-PP) PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II))) CALL HWVSCA(3,PP,N,PLAB(1,I+4)) CALL HWUMAS(PLAB(1,I+4)) PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4)) C--fix to avoid problems if approx massless due to energy IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4)) ENDIF C--now the massless vectors PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II)) DO 4 J=1,4 4 PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4) 3 CALL HWUMAS(PLAB(1,I)) C--change ordr of momenta for call to HE code DO 5 I=1,5 PM(1,I) = P(3,I) PM(2,I) = P(1,I) PM(3,I) = P(2,I) PM(4,I) = P(4,I) 5 PM(5,I) = P(5,I) DO 6 I=1,8 PCM(1,I)=PLAB(3,I) PCM(2,I)=PLAB(1,I) PCM(3,I)=PLAB(2,I) PCM(4,I)=PLAB(4,I) 6 PCM(5,I)=PLAB(5,I) C--compute the S functions CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D) DO 7 I=1,8 DO 7 J=1,8 S(I,J,2) = -S(I,J,2) 7 D(I,J) = TWO*D(I,J) CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1)) CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2)) CALL HWUMAS(PTMP(1,1)) CALL HWUMAS(PTMP(1,2)) C--compute the F functions CALL HWH2F3(8,F23,PTMP(1,1),ZERO) CALL HWH2F3(8,F45,PTMP(1,2),ZERO) C--now find the prefactor for all the diagrams PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))* & HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5)) PRE = 0.25D0/SQRT(PRE) C--zero the matrix element DO 8 P0=1,2 DO 8 P1=1,2 DO 8 P2=1,2 DO 8 P3=1,2 8 ME(P0,P1,P2,P3) = (0.0D0,0.0D0) C--compute the A, B, C and E functions DO 9 P1=1,2 DO 9 P2=1,2 IF(P1.EQ.P2) THEN C--the A and B functions APP(P1,P2) = A( P2 )*S(5,1,O(P1))*S(2,6, P1 ) APM(P1,P2) = 0.0D0 AMP(P1,P2) = 0.0D0 AMM(P1,P2) = -A(O(P2))*M(2)*M(3) BPP(P1,P2) = B( P2 )*S(7,3,O(P1))*S(4,8, P1 ) BPM(P1,P2) = 0.0D0 BMP(P1,P2) = 0.0D0 BMM(P1,P2) = -B(O(P2))*M(4)*M(5) C--the C and E functions C(P1,P2) =CN(1)*(A( P2 )*( M2(2)*S(5,2,O(P1))*S(2,6, P1 ) & +M2(3)*S(5,1,O(P1))*S(1,6, P1 )) & -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6, P1 ) & +S(5,2,O(P1))*S(2,6, P1 ))) E(P1,P2) =CN(2)*(B( P2 )*( M2(4)*S(7,4,O(P1))*S(4,8, P1 ) & +M2(5)*S(7,3,O(P1))*S(3,8, P1 )) & -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8, P1 ) & +S(7,4,O(P1))*S(4,8, P1 ))) ELSE C--the A functions APP(P1,P2) = 0.0D0 APM(P1,P2) = A( P2 )*M(2)*S(2,6,O(P1)) AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1)) AMM(P1,P2) = 0.0D0 BPP(P1,P2) = 0.0D0 BPM(P1,P2) = B( P2 )*M(4)*S(4,8,O(P1)) BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1)) BMM(P1,P2) = 0.0D0 C--the C and D functions C(P1,P2) =CN(1)*( A( P2 )*M(2)*( M2(3)*S(5,6,O(P1)) & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1))) & -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1)) & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))) E(P1,P2) =CN(2)*( B( P2 )*M(4)*( M2(5)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))) & -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1)) & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))) ENDIF 9 CONTINUE C--now put the whole thing together to give the matrix element DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 P0=O(P1) IF(P1.EQ.P3) THEN ME(P1,P2,P3,P4) = & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0)) & +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1))) &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1)) & +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))) &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0)) & +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1))) &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)) & +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1))) ELSE ME(P1,P2,P3,P4) = & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1)) & +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0))) &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1)) & +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0))) &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1)) & +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0))) &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1)) & +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0))) ENDIF ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4) & +C(P1,P2)*( & BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4) & +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8)) & +E(P3,P4)*( & APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2) & +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6)) & +DOT*C(P1,P2)*E(P3,P4) 10 ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4) C--compute the weight WGT = ZERO DO 40 P1=1,2 DO 40 P2=1,2 DO 40 P3=1,2 DO 40 P4=1,2 40 WGT = WGT+DREAL(ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4))) C--normalise this for phase space WGT = WGT*PHS C--enter the matrix element into the spin common block IF(GENEV.AND.SYSPIN) THEN NSPN = 5 DO 11 P1=1,2 DO 11 P2=1,2 DO 11 P3=1,2 DO 11 P4=1,2 11 MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4) SPNCFC(1,1,1) = ONE NCFL(1) = 1 ENDIF END CDECK ID>, HWDBOS. *CMZ :- -23/05/96 18.34.17 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWDBOS(IBOSON) C----------------------------------------------------------------------- C DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD) C USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE) C IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR) C IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS C--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS C--BRW FIX 18/07/07: ADD FULL DECAY CORRELATIONS IN HIGGS->VV C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM, & PBOS(5),PMAX,PROB,RRLL,RLLR INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH, & I,IQRK,IANT,ID,IQ,ITRY,JBOS LOGICAL QUARKS,HIGV2 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT IBOS=IBOSON IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200) THEN CALL HWWARN('HWDBOS',101) GOTO 999 ENDIF QUARKS=.FALSE. C---SEE IF IT IS PART OF A PAIR IMOTH=JMOHEP(1,IBOS) IPAIR=JMOHEP(2,IBOS) ICMF=JMOHEP(1,IBOS) C--BRW FIX 17/07/03 IF (IPAIR.EQ.IBOS) THEN IOPT=0 IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH) ELSE IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN IPAIR=JMOHEP(2,ICMF) IF (IPAIR.NE.0) THEN IPAIR=JDAHEP(1,IPAIR) IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS ENDIF ICMF=JMOHEP(1,ICMF) ENDIF IOPT=0 IF (IPAIR.NE.0) THEN IF (JMOHEP(2,IPAIR).NE.IBOS.OR. & IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0 ENDIF IF (IPAIR.GT.0.AND.IPAIR.NE.IBOS) IOPT=1 ENDIF C--END FIX C---SELECT DECAY PRODUCTS 10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT) C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE ! IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) THEN IQRK=IDHW(JMOHEP(1,ICMF)) IANT=IDHW(JMOHEP(2,ICMF)) IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN IQRK=JMOHEP(2,ICMF) IANT=JDAHEP(2,ICMF) ELSEIF (IQRK.EQ.13) THEN IQRK=JDAHEP(2,ICMF) IANT=JMOHEP(2,ICMF) ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN IQRK=JMOHEP(1,ICMF) IANT=JDAHEP(2,ICMF) ELSEIF (IANT.EQ.13) THEN IQRK=JDAHEP(2,ICMF) IANT=JMOHEP(1,ICMF) ELSEIF (IQRK.GT.IANT) THEN IQRK=JMOHEP(2,ICMF) IANT=JMOHEP(1,ICMF) ELSE IQRK=JMOHEP(1,ICMF) IANT=JMOHEP(2,ICMF) ENDIF PHEP(5,NHEP+1)=RMASS(IDN(1)) PHEP(5,NHEP+2)=RMASS(IDN(2)) PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2)) IF (PCM.LT.ZERO) THEN CALL HWWARN('HWDBOS',103) GOTO 999 ENDIF IF (IDHW(IBOS).EQ.200) THEN ID=IDN(1) IF (ID.GT.120) ID=ID-110 IQ=IDHW(IQRK) IF (IQ.GT.6) IQ=IQ-6 RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)* $ (VFCH(ID,1)**2+AFCH(ID,1)**2) $ +4*VFCH(IQ,1)*AFCH(IQ,1)* $ VFCH(ID,1)*AFCH(ID,1) RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)* $ (VFCH(ID,1)**2+AFCH(ID,1)**2) $ -4*VFCH(IQ,1)*AFCH(IQ,1)* $ VFCH(ID,1)*AFCH(ID,1) ELSE RRLL=ONE RLLR=ZERO ENDIF IF (IPRO.EQ.21) THEN PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+ & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2) ELSE PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))* & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS)) ENDIF 1 CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2), & PCM,TWO,.TRUE.) IF (IPRO.EQ.21) THEN PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+ & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+ & RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+ & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2) ELSE PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))* & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+ & RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))* & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1)) ENDIF IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN CALL HWWARN('HWDBOS',104) GOTO 999 ENDIF IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1 ELSE C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR) ITRY=0 HIGV2=IPAIR.EQ.IBOS.AND.IDHW(ICMF).EQ.201 IF (HIGV2) THEN IQRK=JDAHEP(1,JBOS) IANT=JDAHEP(2,JBOS) IF (IDHW(IBOS).EQ.200) THEN ID=IDN(1) IF (ID.GT.120) ID=ID-110 IQ=IDHW(IQRK) IF (IQ.GT.120) IQ=IQ-110 RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)* $ (VFCH(ID,1)**2+AFCH(ID,1)**2) $ +4*VFCH(IQ,1)*AFCH(IQ,1)* $ VFCH(ID,1)*AFCH(ID,1) RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)* $ (VFCH(ID,1)**2+AFCH(ID,1)**2) $ -4*VFCH(IQ,1)*AFCH(IQ,1)* $ VFCH(ID,1)*AFCH(ID,1) ELSE RRLL=ONE RLLR=ZERO ENDIF PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))* & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS)) ELSE IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS)) IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO) & GOTO 20 C---MAY BE FROM A SUSY DECAY ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN CALL HWWARN('HWDBOS',1) ENDIF RHOHEP(1,IBOS)=1. RHOHEP(2,IBOS)=1. RHOHEP(3,IBOS)=1. ENDIF 20 IHEL=HWRINT(1,3) IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20 ENDIF C---SELECT DIRECTION OF FERMION 25 ITRY=ITRY+1 IF (ITRY.GT.NDTRY) THEN CALL HWWARN('HWDBOS',105) GOTO 999 ENDIF 30 COSTH=HWRUNI(0,-ONE,ONE) IF (HIGV2) GOTO 32 IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30 IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0) ) GOTO 30 IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30 C---GENERATE DECAY RELATIVE TO Z-AXIS 32 PHEP(5,NHEP+1)=RMASS(IDN(1)) PHEP(5,NHEP+2)=RMASS(IDN(2)) PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2)) IF (PCM.LT.ZERO) THEN CALL HWWARN('HWDBOS',102) GOTO 999 ENDIF CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1)) PHEP(3,NHEP+1)=PCM*COSTH PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2) C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS) CALL HWUROT(PBOS, ONE,ZERO,R) CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1)) C---BOOST BACK TO LAB C--BRW FIX 30/11/08: BOOST FIRST TO HIGGS RF, THEN TO LAB CALL HWULOB(PBOS,PHEP(1,NHEP+1),PHEP(1,NHEP+1)) CALL HWULOB(PHEP(1,ICMF),PHEP(1,NHEP+1),PHEP(1,NHEP+1)) C--END BRW FIX CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2)) IF (HIGV2) THEN C---HIGGS->VV DECAY CORRELATION PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))* & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))+ & RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))* & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2)) IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN CALL HWWARN('HWDBOS',106) GOTO 999 ENDIF IF (PMAX*HWRGEN(0).GT.PROB) GOTO 25 ENDIF ENDIF C---STATUS, IDs AND POINTERS ISTHEP(IBOS)=195 DO 50 I=1,2 ISTHEP(NHEP+I)=193 IDHW(NHEP+I)=IDN(I) IDHEP(NHEP+I)=IDPDG(IDN(I)) JDAHEP(I,IBOS)=NHEP+I JMOHEP(1,NHEP+I)=IBOS JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS) 50 CONTINUE NHEP=NHEP+2 IF (IDN(1).LE.12) THEN ISTHEP(NHEP-1)=113 ISTHEP(NHEP)=114 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(2,NHEP)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP JDAHEP(2,NHEP-1)=NHEP QUARKS=.TRUE. ELSE C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1)) CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP)) C--END FIX ENDIF C---IF FIRST OF A PAIR, DO SECOND DECAY IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN JBOS=IBOS IBOS=IPAIR GOTO 10 ENDIF C---IF QUARK DECAY, HADRONIZE IF (QUARKS) THEN EMSCA=PHEP(5,IBOS) CALL HWBGEN CALL HWDHOB CALL HWCFOR CALL HWCDEC ENDIF 999 RETURN END CDECK ID>, HWDBOZ. *CMZ :- -29/04/91 18.00.03 by Federico Carminati *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT) C----------------------------------------------------------------------- C CHOOSE DECAY MODE OF BOSON C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ, & FACW INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2, & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER LOGICAL GENLST EXTERNAL HWRGEN,HWRINT SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST SAVE IDMODE,BRMODE DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/ C---STORE THE DECAY MODES (FERMION FIRST) DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7, & 122,127,124,129,126,131,8*0, & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10, & 121,128,123,130,125,132,8*0, & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12, & 121,127,123,129,125,131,122,128,124,130,126,132/ C---STORE THE BRANCHING RATIOS TO THESE MODES DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0, & 0.108D0,0.108D0,4*0.0D0, & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0, & 0.108D0,0.108D0,4*0.0D0, & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/ C---FACTORS FOR CV AND CA FOR W AND Z DATA FACW,FACZ/2*0.0D0/ IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN) IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0) IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN CALL HWWARN('HWDBOZ',101) GOTO 999 ENDIF C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN NPAIR=0 NUMDEC=0 NWGLST=NWGTS GENLST=GENEV IF (IOPT.EQ.2) RETURN ENDIF NUMDEC=NUMDEC+1 IF (NUMDEC.GT.MODMAX) THEN CALL HWWARN('HWDBOZ',102) GOTO 999 ENDIF C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE IF (IOPT.EQ.1) THEN IF (NUMDEC.GT.MODMAX-1) THEN CALL HWWARN('HWDBOZ',103) GOTO 999 ENDIF IF (NPAIR.EQ.0) THEN IF (HWRGEN(1).GT.HALF) THEN MODTMP=MODBOS(NUMDEC+1) MODBOS(NUMDEC+1)=MODBOS(NUMDEC) MODBOS(NUMDEC)=MODTMP ENDIF NPAIR=NUMDEC ELSE NPAIR=0 ENDIF ENDIF C---SELECT USER'S CHOICE IF (IDBOS.EQ.200) THEN IF (MODBOS(NUMDEC).EQ.1) THEN I1=1 I2=6 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN I1=7 I2=7 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN I1=8 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN I1=9 I2=9 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN I1=7 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN I1=10 I2=12 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN I1=5 I2=5 ELSE I1=1 I2=12 ENDIF ELSE IF (MODBOS(NUMDEC).EQ.1) THEN I1=1 I2=5 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN I1=6 I2=6 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN I1=7 I2=7 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN I1=8 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN I1=6 I2=7 ELSE I1=1 I2=8 ENDIF ENDIF 10 IDEC=HWRINT(I1,I2) IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10 IFER=IDMODE(1,IDEC,IDBOS-197) IANT=IDMODE(2,IDEC,IDBOS-197) C---CALCULATE BRANCHING RATIO C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR) BR=0 DO 20 IDEC=I1,I2 20 BR=BR+BRMODE(IDEC,IDBOS-197) IF (IOPT.EQ.1) THEN IF (NPAIR.NE.0) THEN I1LST=I1 I2LST=I2 BRLST=BR ELSE BRCOM=0 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST) 30 BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197) BR=2*BR*BRLST - BRCOM**2 ENDIF ENDIF C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) ) IF (IDBOS.EQ.200) THEN IF (IFER.LE.6) THEN C Quark couplings CV=VFCH(IFER,1) CA=AFCH(IFER,1) ELSE C lepton couplings JFER=IFER-110 CV=VFCH(JFER,1) CA=AFCH(JFER,1) ENDIF CV=CV * FACZ CA=CA * FACZ ELSE CV=FACW CA=FACW ENDIF 999 RETURN END CDECK ID>, HWDBZ2. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson based on Mike Seymour's HWDBOZ C----------------------------------------------------------------------- SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS) C----------------------------------------------------------------------- C CHOOSE DECAY MODE OF BOSON C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS C IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN C MASS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ, & FACW,MSMODE(12,3),MASS INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2, & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY LOGICAL GENLST EXTERNAL HWRGEN,HWRINT SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST SAVE IDMODE,BRMODE DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/ C---STORE THE DECAY MODES (FERMION FIRST) DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7, & 122,127,124,129,126,131,8*0, & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10, & 121,128,123,130,125,132,8*0, & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12, & 121,127,123,129,125,131,122,128,124,130,126,132/ C---STORE THE BRANCHING RATIOS TO THESE MODES DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0, & 0.108D0,0.108D0,4*0.0D0, & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0, & 0.108D0,0.108D0,4*0.0D0, & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/ DATA MSMODE/36*0.0D0/ C---FACTORS FOR CV AND CA FOR W AND Z DATA FACW,FACZ/2*0.0D0/ IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN) IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0) IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN CALL HWWARN('HWDBZ2',101) GOTO 999 ENDIF IF(MSMODE(1,1).EQ.ZERO) THEN DO I1=1,12 DO I2=1,3 MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2)) ENDDO ENDDO ENDIF C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN NPAIR=0 NUMDEC=0 NWGLST=NWGTS GENLST=GENEV IF (IOPT.EQ.2) RETURN ENDIF NUMDEC=NUMDEC+1 IF (NUMDEC.GT.MODMAX) THEN CALL HWWARN('HWDBZ2',102) GOTO 999 ENDIF C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE IF (IOPT.EQ.1) THEN IF (NUMDEC.GT.MODMAX-1) THEN CALL HWWARN('HWDBZ2',103) GOTO 999 ENDIF IF (NPAIR.EQ.0) THEN IF (HWRGEN(1).GT.HALF) THEN MODTMP=MODBOS(NUMDEC+1) MODBOS(NUMDEC+1)=MODBOS(NUMDEC) MODBOS(NUMDEC)=MODTMP ENDIF NPAIR=NUMDEC ELSE NPAIR=0 ENDIF ENDIF C---SELECT USER'S CHOICE IF (IDBOS.EQ.200) THEN IF (MODBOS(NUMDEC).EQ.1) THEN I1=1 I2=6 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN I1=7 I2=7 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN I1=8 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN I1=9 I2=9 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN I1=7 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN I1=10 I2=12 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN I1=5 I2=5 ELSE I1=1 I2=12 ENDIF ELSE IF (MODBOS(NUMDEC).EQ.1) THEN I1=1 I2=5 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN I1=6 I2=6 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN I1=7 I2=7 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN I1=8 I2=8 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN I1=6 I2=7 ELSE I1=1 I2=8 ENDIF ENDIF NTRY = 0 10 IDEC=HWRINT(I1,I2) NTRY = NTRY+1 IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10 IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10 IF(NTRY.GE.NBTRY) THEN BR = ZERO RETURN ENDIF IFER=IDMODE(1,IDEC,IDBOS-197) IANT=IDMODE(2,IDEC,IDBOS-197) C---CALCULATE BRANCHING RATIO C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR) BR=0 DO 20 IDEC=I1,I2 20 IF(MSMODE(IDEC,IDBOS-197).LT.MASS) BR=BR+BRMODE(IDEC,IDBOS-197) IF (IOPT.EQ.1) THEN IF (NPAIR.NE.0) THEN I1LST=I1 I2LST=I2 BRLST=BR ELSE BRCOM=0 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST) 30 IF(MSMODE(IDEC,IDBOS-197).LT.MASS) & BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197) BR=2*BR*BRLST - BRCOM**2 ENDIF ENDIF C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) ) IF (IDBOS.EQ.200) THEN IF (IFER.LE.6) THEN C Quark couplings CV=VFCH(IFER,1) CA=AFCH(IFER,1) ELSE C lepton couplings JFER=IFER-110 CV=VFCH(JFER,1) CA=AFCH(JFER,1) ENDIF CV=CV * FACZ CA=CA * FACZ ELSE CV=FACW CA=FACW ENDIF 999 RETURN END CDECK ID>, HWDCHK. *CMZ :- -27/07/99 13.33.03 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWDCHK(IDKY,L,IFGO) C----------------------------------------------------------------------- C Checks line L of decay table is compatible with decay of particle C IDKY, tidies up the line and sets NPRODS. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION EPS,QS,Q,DM INTEGER IDKY,L,IFAULT,I,ID,J LOGICAL IFGO PARAMETER (EPS=1.D-6) IFGO = .FALSE. IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) THEN IFGO = .TRUE. RETURN ENDIF 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 C--modification so doesn't remove H --> W*W* Z*Z* modes IF (DM.LT.ZERO.AND..NOT. & (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND. & IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND. & IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) 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 IFGO = .TRUE. RETURN 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 'HERWIG65.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) 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) 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)=SNGL(PHEP(1,IHEP)) QQP(1,2)=SNGL(PHEP(2,IHEP)) QQP(1,3)=SNGL(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 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 'HERWIG65.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)=SNGL(PHEP(1,IHEP)) EUPCM(2,1)=SNGL(PHEP(2,IHEP)) EUPCM(3,1)=SNGL(PHEP(3,IHEP)) EUPCM(5,1)=SQRT(EUPCM(1,1)**2+EUPCM(2,1)**2+EUPCM(3,1)**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) THEN CALL HWWARN('HWDEUR',99) GOTO 999 ENDIF 40 CONTINUE 999 RETURN 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----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,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 INTEGER NTRY EXTERNAL HWRGEN B=P0(5)-P1(5) C=P2(5)+P3(5)+P4(5) IF (B.LT.C) THEN CALL HWWARN('HWDFOR',100) GOTO 999 ENDIF 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 NTRY=0 10 NTRY=NTRY+1 IF(NTRY.GT.NDETRY) THEN CALL HWWARN('HWDFOR',101) GOTO 999 ENDIF S1=BB+HWRGEN(1)*(CC-BB) RS1=SQRT(S1) FF=(RS1-P2(5))**2 S2=DD+HWRGEN(2)*(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*HWRGEN(3)**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 RETURN 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----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,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 INTEGER NTRY EXTERNAL HWRGEN B=P0(5)-P1(5) C=P2(5)+P3(5)+P4(5)+P5(5) IF (B.LT.C) THEN CALL HWWARN('HWDFIV',100) GOTO 999 ENDIF 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 NTRY=0 10 NTRY=NTRY+1 IF(NTRY.GT.NDETRY) THEN CALL HWWARN('HWDFIV',101) GOTO 999 ENDIF S1=BB+HWRGEN(1)*(CC-BB) RS1=SQRT(S1) GG=(RS1-P2(5))**2 S2=DD+HWRGEN(2)*(GG-DD) RS2=SQRT(S2) HH=(RS2-P3(5))**2 S3=EE+HWRGEN(3)*(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*HWRGEN(4)**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 RETURN END CDECK ID>, HWDHAD. *CMZ :- -26/04/91 11.11.54 by Peter Richardson *-- Author : Ian Knowles, Bryan Webber & Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWDHAD C----------------------------------------------------------------------- C GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS C Modified for TAUOLA interface 16/10/01 PR C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/FFS/TB,BT COMMON/SFF/IT1,IB1,IT2,IB2 DOUBLE PRECISION TB,BT INTEGER IT1,IB1,IT2,IB2 DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4), & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG LOGICAL STABLE EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,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) THEN CALL HWWARN('HWDHAD',100) GOTO 999 ENDIF 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 (HWRGEN(1).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) THEN CALL HWWARN('HWDHAD',101) GOTO 999 ENDIF 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 Use TAUOLA package for tau decays if requested IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN CALL HWDTAU(1,MHEP,0.0D0) GOTO 100 ENDIF C Choose decay mode ISTHEP(MHEP)=ISTHEP(MHEP)+5 RN=HWRGEN(2) 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) GOTO 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) THEN CALL HWWARN('HWDHAD',102) GOTO 999 ENDIF 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) THEN CALL HWWARN('HWDHAD',103) GOTO 999 ENDIF 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*HWRGEN(3) IF (RSUM.LT.RHOHEP(1,MO)) THEN C---(1+COSANG)**2 COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN C---1-COSANG**2 COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE) ELSE C---(1-COSANG)**2 COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*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.HWRGEN(11)*WTMX2) GOTO 50 ELSE IF (NME(IM).EQ.200) THEN C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element C sort tan(beta) IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR. & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR. & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR. & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR. & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR. & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN TB=TANB ELSE TB=1./TANB END IF IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR. & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR. & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR. & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR. & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR. & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN BT=TANB ELSE BT=1./TANB END IF IT1=IDK(IM) IB1=IDKPRD(3,IM) IT2=IDKPRD(1,IM) IB2=IDKPRD(2,IM) CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2), & PHEP(1,NHEP-1),HWDHWT) 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)) IF(IERROR.NE.0) RETURN 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)) IF(IERROR.NE.0) RETURN ELSE CALL HWWARN('HWDHAD',104) GOTO 999 ENDIF ENDIF ENDIF 100 CONTINUE C---MAY HAVE OVERFLOWED /HEPEVT/ CALL HWWARN('HWDHAD',105) 999 RETURN 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 'HERWIG65.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 'HERWIG65.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 SAVE CHANGE,NBIN DATA CHANGE,NBIN/0.425D0,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 'HERWIG65.INC' DOUBLE PRECISION HWDHGF,HWRGEN,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,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG SAVE GAM,EM,VECDEC PARAMETER (NLOOK=100) DIMENSION VECDEC(2,0:NLOOK) EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200)) SAVE GAMLIM 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) THEN CALL HWWARN('HWDHIG',101) GOTO 999 ENDIF EMH=PHEP(5,IHIG) IF (EMH.LE.ZERO) THEN CALL HWWARN('HWDHIG',102) GOTO 999 ENDIF 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) THEN CALL HWWARN('HWDHIG',103) GOTO 999 ENDIF 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(ABS(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.HWRGEN(0)) GOTO 500 ENDIF C---SEE IF SPECIFIED DECAY IS POSSIBLE IF (BRHIG(IMODE).EQ.ZERO) THEN CALL HWWARN('HWDHIG',104) GOTO 999 ENDIF 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) THEN CALL HWWARN('HWDHIG',105) GOTO 999 ENDIF 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 C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1)) CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP)) C--END FIX ENDIF 999 RETURN END CDECK ID>, HWDHOB. *CMZ :- -17/10/01 10:19:15 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 MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF C THE PROCESS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PW(5) INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST LOGICAL FOUND SAVE NHEPST IF (IERROR.NE.0) RETURN 10 FOUND=.FALSE. NHEPST = NHEP CLSAVE(1) = 0 CLSAVE(2) = 0 DO 60 IHEP=1,NMXHEP IS=ISTHEP(IHEP) ID=IDHW(IHEP) IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE) 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.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR. & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN FOUND=.TRUE. C--select the decay mode and enter the decay products in the event record CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP) IF (IERROR.NE.0) RETURN C--select the momenta of the decay products CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW) IF (IERROR.NE.0) RETURN C--make the colour connections CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE) IF (IERROR.NE.0) RETURN C--perform the parton-showers CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW) IF (IERROR.NE.0) RETURN ENDIF C--perform the colour corrections for RPV CALL HWDHO5(MHEP,LHEP,CLSAVE) IF(IERROR.NE.0) RETURN IF (IHEP.EQ.NHEP) GOTO 70 60 CONTINUE 70 IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE. IF (FOUND) THEN C--final check for colour disconnection CALL HWDHO6 C Go back to check for further heavy decay products GOTO 10 ENDIF END CDECK ID>, HWDHO1. *CMZ :- -17/10/01 10:19:15 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP) C----------------------------------------------------------------------- C Subroutine to perform the first part of the heavy object decays C IE to select the decay mode C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS EXTERNAL HWRGEN SAVE IST DATA IST/113,114,114/ IF (IERROR.NE.0) RETURN 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) C--copy the location of the particle in the spin block IF(SYSPIN.AND.NSPN.NE.0) THEN IF(ISNHEP(IHEP).EQ.0) THEN IS = IHEP MTRY = 0 5 MTRY = MTRY+1 IS = JMOHEP(1,IS) IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5 IF(MTRY.GT.NETRY) THEN CALL HWWARN('HWDHO1',102) GOTO 999 ENDIF ISNHEP(IHEP) = ISNHEP(IS) ENDIF ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP)) ENDIF MTRY=0 15 MTRY=MTRY+1 C Select decay mode RN=HWRGEN(0) 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('HWDHO1',50) 30 IF (NHEP+5.GT.NMXHEP) THEN CALL HWWARN('HWDHO1',100) GOTO 999 ENDIF 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 IF (ISTHEP(IHEP).NE.120) 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('HWDHO1',1) IF (MTRY.LE.NETRY) GO TO 15 CALL HWWARN('HWDHO1',101) GOTO 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)) 999 RETURN END CDECK ID>, HWDH02. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW) C----------------------------------------------------------------------- C Subroutine to perform the second part of the heavy object decays C IE generate the kinematics for the decay C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/FFS/TB,BT COMMON/SFF/IT1,IB1,IT2,IB2 DOUBLE PRECISION TB,BT INTEGER IT1,IB1,IT2,IB2,ISP DOUBLE PRECISION GAMHPM DOUBLE PRECISION HWUPCM,HWRGEN,PCM, & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT DOUBLE COMPLEX RHOIN(2,2,2) INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT SAVE RHOIN DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0), & (0.0D0,0.0D0),(0.0D0,0.0D0), & (0.5D0,0.0D0),(0.0D0,0.0D0), & (0.0D0,0.0D0),(0.5D0,0.0D0)/ ISP = INT(2*RSPIN(IDHW(IHEP)))+1 IF (IERROR.NE.0) RETURN IF (NPR.EQ.2) THEN C Two body decay: LHEP -> MHEP + NHEP IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN C--generate a two body decay to a gauge boson as a three body decay CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1) C--generate a two body decay of a Higgs to two gauge bosons ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000) C--if spin correlations call the routine to set-up the matrix element ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1) ELSE 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.) ENDIF 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)*HWRGEN(1).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)) ELSE IF (NME(IM).EQ.200) THEN C Generate decay momenta using full C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element GAMHPM=RMASS(206)/DKLTM(206) C sort tan(beta) IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR. & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR. & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR. & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR. & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR. & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN TB=TANB ELSE TB=1./TANB END IF IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR. & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR. & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR. & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR. & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR. & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN BT=TANB ELSE BT=1./TANB END IF IT1=IDK(IM) IB1=IDKPRD(3,IM) IT2=IDKPRD(1,IM) IB2=IDKPRD(2,IM) EMMX=PHEP(5,IHEP)-PHEP(5,NHEP) EMWSQ=RMASS(206)**2 GMWSQ=(RMASS(206)*GAMHPM)**2 EMLIM=GMWSQ IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2 55 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP), & PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT) CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW) PW(5)=HWULDO(PW,PW) EMTST=(EMWSQ-PW(5))**2 IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55 PW(5)=SQRT(PW(5)) C Assign production vertices to 1 and 2 CALL HWUDKL(206,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) C--Three body SUSY decay ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000, & RHOIN(1,1,ISP),1) C--special for top decay IF(ABS(IDHEP(IHEP)).EQ.6) THEN CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW) CALL HWUMAS(PW) ENDIF 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 ISTHEP(NHEP) = 114 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)) IF(IERROR.NE.0) RETURN CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP)) CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP)) ELSE CALL HWWARN('HWDHO2',100) ENDIF END CDECK ID>, HWDHO3. *CMZ :- -17/10/01 10:19:15 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE) C----------------------------------------------------------------------- C Subroutine to perform the third part of the heavy object decays C IE setup the colour connections C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2) IF (IERROR.NE.0) RETURN 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).OR. & ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND. & NME(IM).GE.10000.AND.NME(IM).LE.20000)) 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 2->2 JMOHEP(2,MHEP)=MHEP JDAHEP(2,MHEP)=MHEP JMOHEP(2,NHEP)=LHEP JDAHEP(2,NHEP)=LHEP ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN C heavy quark to charged Higgs 2->2 JMOHEP(2,MHEP)=LHEP JDAHEP(2,MHEP)=LHEP JMOHEP(2,NHEP)=NHEP JDAHEP(2,NHEP)=NHEP ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN C heavy quark to charged Higgs 2->3 JMOHEP(2,KHEP)=MHEP JDAHEP(2,KHEP)=MHEP JMOHEP(2,MHEP)=KHEP JDAHEP(2,MHEP)=KHEP JMOHEP(2,NHEP)=LHEP JDAHEP(2,NHEP)=LHEP ELSE CALL HWWARN('HWDHO3',100) GOTO 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('HWDHO3',101) GOTO 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 999 RETURN END CDECK ID>, HWDHO4. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW) C----------------------------------------------------------------------- C Subroutine to perform the fourth part of the heavy object decays C IE parton-showers with special treatment for top C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PW(5),PDW(5,3) INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP DOUBLE COMPLEX RHOIN(2,2) SAVE RHOIN DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0), & (0.0D0,0.0D0),(0.5D0,0.0D0)/ IF (IERROR.NE.0) RETURN SHEP = NHEP 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.OR.NME(IM).EQ.200.OR. & (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND. & (SYSPIN.OR.THREEB)))) THEN C---STORE W/H DECAY PRODUCTS CALL HWVEQU(10,PHEP(1,KHEP),PDW) C---BOOST THEM INTO W/H REST FRAME CALL HWULOF(PW,PDW(1,1),PDW(1,3)) C---REPLACE THEM BY W/H CALL HWVEQU(5,PW,PHEP(1,KHEP)) WHEP=KHEP IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND. & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198 IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND. & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12)) & IDHW(KHEP)=199 IF (NME(IM).EQ.200)IDHW(KHEP)=206 IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207 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/H MOMENTUM NTRY=0 41 NTRY=NTRY+1 IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP) THEN CALL HWWARN('HWDHO4',100) GOTO 999 ENDIF 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 IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP)) IF(NME(IM).EQ.200)CALL HWUDKL(206,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) C--modification to use photos in top decays IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP) C--end of modification CALL HWBGEN IF (IERROR.NE.0) RETURN ELSE C Do parton showers EMSCA=PHEP(5,IHEP) CALL HWBGEN IF (IERROR.NE.0) RETURN C--special for gauge boson decay modes of gauginos and four body higgs C--call routine to add decay products and generate parton shower IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN, & ISNHEP(IHEP)) ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000) ENDIF IF (IERROR.NE.0) RETURN ENDIF 999 RETURN END CDECK ID>, HWDHO5. *CMZ :- -17/10/01 10:19:15 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO5(MHEP,LHEP,CLSAVE) C----------------------------------------------------------------------- C Subroutine to perform the fifth part of the heavy object decays C IE sort out RPV colour connections C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2) IF (IERROR.NE.0) RETURN 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 END CDECK ID>, HWDHO6. *CMZ :- -17/10/01 10:19:15 by Peter Richardson *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDHO6 C----------------------------------------------------------------------- C Subroutine to perform the final part of the heavy object decays C IE sort out any colour connection problems C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,IM,JHEP,ISM,JCM IF (IERROR.NE.0) RETURN 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 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 'HERWIG65.INC' COMMON/FFS/TB,BT COMMON/SFF/IT1,IB1,IT2,IB2 DOUBLE PRECISION TB,BT INTEGER IT1,IB1,IT2,IB2 DOUBLE PRECISION GAMHPM DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4), & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J,IDS EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO SAVE IST 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) THEN CALL HWWARN('HWDHVY',100) GOTO 999 ENDIF 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) GOTO 999 ENDIF C Label constituents IF (NHEP+5.GT.NMXHEP) THEN CALL HWWARN('HWDHVY',102) GOTO 999 ENDIF 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 spectator mass C--BW fix 13/07/10: give diquarks extra mass in heavy baryon decays IDS=IDHW(IS) IF (IDS.GT.108.AND.IDS.LT.121) THEN XS=(RMASS(IDS)+DQXTRA)/PHEP(5,IHEP) ELSE XS=RMASS(IDS)/PHEP(5,IHEP) ENDIF 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)*HWRGEN(0).GT.EMLIM) GOTO 20 ELSEIF (NME(IM).EQ.200) THEN C Generate decay momenta using full C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element GAMHPM=RMASS(206)/DKLTM(206) C sort tan(beta) IF((IQ.EQ. 2).OR.(IQ.EQ. 4).OR. & (IQ.EQ. 6).OR.(IQ.EQ. 8).OR. & (IQ.EQ. 10).OR.(IQ.EQ. 12).OR. & (IQ.EQ.122).OR.(IQ.EQ.124).OR. & (IQ.EQ.126).OR.(IQ.EQ.128).OR. & (IQ.EQ.130).OR.(IQ.EQ.132))THEN TB=TANB ELSE TB=1./TANB END IF IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR. & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR. & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR. & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR. & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR. & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN BT=TANB ELSE BT=1./TANB END IF IT1=IQ IB1=IDKPRD(3,IM) IT2=IDKPRD(1,IM) IB2=IDKPRD(2,IM) EMWSQ=RMASS(206)**2 GMWSQ=(RMASS(206)*GAMHPM)**2 EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2 25 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP), & PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT) CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW) EMTST=(HWULDO(PW,PW)-EMWSQ)**2 IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 25 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*HWRGEN(0)) 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 RETURN 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 'HERWIG65.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 SAVE COLCON,FLACON 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) GOTO 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 RETURN 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 'HERWIG65.INC' DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN, & M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS, & M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND, & MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3), & TEST2 EXTERNAL HWDRM1,HWULDO,HWDPWT,HWRGEN INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG, & IDHWTP,IDHPTP,MTRY PARAMETER(EPS=1D-20) IF(IERROR.NE.0) RETURN C--Electroweak parameters, etc SWEAK = SQRT(SWEIN) MW = RMASS(198) M(4) = PHEP(5,LHEP) IG = IDHW(LHEP) C--Find the masses of the final state and zero parameters DO K=1,3 ID(K) = IDHW(MHEP+K-1) IF(ID(K).LE.12) THEN SN(K)=ID(K) ELSE SN(K)=ID(K)-120 ENDIF IF(SN(K).GT.6) SN(K)=SN(K)-6 M(K) = PHEP(5,LHEP+K) SB(K)=SN(K) LAMD(K) = ZERO ENDDO DO J=1,6 MX2(J) = ZERO MX(J) = ZERO M13SQT(J) = ZERO M23SQT(J) = ZERO M12SQT(J) = ZERO ENDDO C--Evaluate the coefficents for the mode we want IF(IG.GE.450.AND.IG.LE.453) THEN C--NEUTRALINO NSP = IG-449 AM = RMASS(IG) MSGN = ZSGNSS(NSP) MC(1) = ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK) MC(2) = ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK) C--Calculate the combinations of couplings needed IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN C--first for the UDD modes DO J=1,2 A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J) & +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J) B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J) & +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J)) MX2(J) = QMIXSS(SN(1),2,J) A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J) & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J) B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J) & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J)) MX2(J+2) = QMIXSS(SN(2),2,J) A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J) & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J) B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J) & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J)) MX2(J+2) = QMIXSS(SN(3),2,J) ENDDO DO K=1,3 SN(K) = SN(K)+400 SB(K) = SB(K)+412 ENDDO ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN C--Now for the LLE modes DO J=1,2 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J) & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J)) B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J) & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J) MX2(J)= LMIXSS(SN(1),1,J) A(J+2) = ZERO B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J) MX2(J+2) = LMIXSS(SN(2),1,J) A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J) & +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J) B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J) & +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J)) MX2(4+J) = LMIXSS(SN(3),2,J) ENDDO DO J=1,3 SN(J) = SN(J) + 424 SB(J) = SB(J) + 436 ENDDO ELSE C--Now for both types of LQD modes IF(MOD(SN(1),2).EQ.0) THEN C--First the neutrino,down,antidown mode DO J=1,2 A(J) = ZERO B(J) = SLFCH(10+SN(1),NSP)* & LMIXSS(SN(1),1,J) MX2(J) = LMIXSS(SN(1),1,J) A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J) & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J)) B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J) & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J) MX2(2+J) = QMIXSS(SN(2),1,J) A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J) & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J) B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J) & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J)) MX2(J+4) = QMIXSS(SN(3),2,J) ENDDO ELSE C--Now the charged lepton, antiup,down modes DO J=1,2 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J) & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J)) B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J) & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J) MX2(J) = LMIXSS(SN(1),1,J) A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J) & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J)) B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J) & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J) MX2(2+J) = QMIXSS(SN(2),1,J) A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J) & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J) B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J) & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J)) MX2(J+4) = QMIXSS(SN(3),2,J) ENDDO ENDIF SN(1) = SN(1) + 424 SB(1) = SB(1) + 436 DO J=2,3 SN(J) = SN(J) + 400 SB(J) = SB(J) + 412 ENDDO ENDIF DO K=1,3 SM(2*K-1) = RMASS(SN(K)) SM(2*K) = RMASS(SB(K)) SW(2*K-1) = HBAR/RLTIM(SN(K)) SW(2*K) = HBAR/RLTIM(SB(K)) ENDDO ND = 3 DO K=1,3 LAMD(K) = ONE ENDDO INFCOL = ONE ELSEIF(IG.EQ.449) THEN C--GLUINO C--First obtian the masses and widths needed AM = RMASS(IG) ND = 3 C--Calculate the combinations of couplings needed IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN C--first for the UDD modes INFCOL = -0.5D0 C--Couplings DO I=1,3 DO J=1,2 A(2*I-2+J) = -QMIXSS(SN(I),1,J) B(2*I-2+J) = QMIXSS(SN(I),2,J) MX2(2*I-2+J) = QMIXSS(SN(I),2,J) ENDDO SN(I) = SN(I)+400 SB(I) = SB(I)+412 ENDDO ELSE INFCOL = ONE C--Now for both types of LQD modes IF(MOD(SN(1),2).EQ.0) THEN C--First the neutrino,down,antidown mode DO J=1,2 A(J) = ZERO B(J) = ZERO MX2(J) = ZERO A(J+2) = QMIXSS(SN(2),2,J) B(J+2) = -QMIXSS(SN(2),1,J) MX2(J+2) = QMIXSS(SN(2),1,J) A(J+4) = -QMIXSS(SN(3),1,J) B(J+4) = QMIXSS(SN(3),2,J) MX2(4+J) = QMIXSS(SN(3),2,J) ENDDO ELSEIF(MOD(SN(1),2).EQ.1) THEN C--Now the charged lepton, antiup,down modes DO J=1,2 A(J) = ZERO B(J) = ZERO MX2(J) = ZERO A(J+2) = QMIXSS(SN(2),2,J) B(J+2) = -QMIXSS(SN(2),1,J) MX2(J+2) = QMIXSS(SN(2),1,J) A(J+4) = -QMIXSS(SN(3),1,J) B(J+4) = QMIXSS(SN(3),2,J) MX2(J+4) = QMIXSS(SN(3),2,J) ENDDO ENDIF SN(1) = SN(1) + 424 SB(1) = SB(1) + 436 DO K=2,3 SN(K) = SN(K) + 400 SB(K) = SB(K) + 412 ENDDO ENDIF DO K=1,3 SM(2*K-1) = RMASS(SN(K)) SM(2*K) = RMASS(SB(K)) SW(2*K-1) = HBAR/RLTIM(SN(K)) SW(2*K) = HBAR/RLTIM(SB(K)) ENDDO DO K=1,3 LAMD(K) = ONE ENDDO ELSEIF(IG.GE.454.AND.IG.LE.457) THEN C--CHARGINO CSP = IG-453 IF(CSP.GT.2) CSP = CSP-2 AM = RMASS(IG) INFCOL = -ONE MSGN = WSGNSS(CSP) MC(1) = ONE/(SQRT(2.0D0)*MW*COSB) MC(2) = ONE/(SQRT(2.0D0)*MW*SINB) C--Calculate the combinations of the couplings needed IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN C--first for the LLE modes, three modes IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN C--the one diagram mode nubar,positron, nu DO J=1,2 A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1) & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2) B(J+4) = ZERO MX2(J+4) = LMIXSS(SN(3)-1,2,J) ENDDO ND = 1 SN(3) = SN(3)+423 SB(3) = SB(3)+435 ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN C--the first two diagram mode nu, nu, positron DO J=1,2 A(J) = ZERO B(J) = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1) & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2) A(J+2) = ZERO B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1) & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2) MX2(J) = LMIXSS(SN(1)-1,1,J) MX2(J+2) = LMIXSS(SN(2)-1,1,J) ENDDO ND = 2 DO J=1,2 SN(J) = SN(J)+423 SB(J) = SB(J)+435 ENDDO ELSE C--the second two diagram mode positron, positron, electron DO J=1,2 A(J) = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J) B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J) A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J) B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J) MX2(J) = LMIXSS(SN(1)+1,1,J) MX2(J+2) = LMIXSS(SN(2)+1,1,J) ENDDO DO J=1,2 SN(J) = SN(J)+425 SB(J) = SB(J)+437 ENDDO ND = 2 ENDIF DO K=1,3 LAMD(K) = ONE ENDDO ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN C--now for the UDD IF(MOD(SN(1),2).EQ.0) THEN C--two diagram mode LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2) LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2) DO J=1,2 A(J) = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J) & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J) B(J) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J) A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J) & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J) B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J) MX2(J) = QMIXSS(SN(1)-1,2,J) MX2(J+2) = QMIXSS(SN(2)-1,2,J) ENDDO DO J=1,2 SN(J) = SN(J) + 399 SB(J) = SB(J) + 411 ENDDO ND = 2 ELSE C--three diagram mode LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2) LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2) LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2) DO I=1,3 DO J=1,2 A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J) & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J)) B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2) & *QMIXSS(SN(I)+1,1,J) MX2(J+2*I-2) = QMIXSS(SN(I)+1,2,J) ENDDO SN(I) = SN(I) + 401 SB(I) = SB(I) + 413 ENDDO ND = 3 ENDIF ELSE C--now for the LQD modes IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN C--first one diagram mode nubar, dbar, up DO J=1,2 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)* & QMIXSS(SN(3)-1,1,J) B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J) & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1) MX2(J+4) = QMIXSS(SN(3)-1,2,J) ENDDO SN(3) = SN(3) + 399 SB(3) = SB(3) + 411 ND = 1 ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN C--second one diagram mode positron, ubar, up DO J=1,2 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)* & QMIXSS(SN(3)-1,1,J) B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J) & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1) MX2(J+4) = QMIXSS(SN(3)-1,2,J) ENDDO SN(3) = SN(3) + 399 SB(3) = SB(3) + 411 ND = 1 ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN C--first two diagram mode positron, dbar, down DO J=1,2 A(J) = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J) B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J) A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J) B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J) & -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J)) MX2(J) = LMIXSS(SN(1)+1,1,J) MX2(J+2) = QMIXSS(SN(2)+1,1,J) ENDDO SN(1) = SN(1) + 425 SB(1) = SB(1) + 437 SN(2) = SN(2) + 401 SB(2) = SB(2) + 413 ND = 2 ELSE C--second two diagram mode nu, up, dbar DO J=1,2 A(J) = ZERO B(J) = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J) & -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J) A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)* & QMIXSS(SN(2)-1,1,J) B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J) & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J) MX2(J) = LMIXSS(SN(1)-1,1,J) MX2(J+2) = QMIXSS(SN(2)-1,1,J) ENDDO SN(1) = SN(1) + 423 SB(1) = SB(1) + 435 SN(2) = SN(2) + 399 SB(2) = SB(2) + 411 ND = 2 ENDIF DO K=1,3 LAMD(K) = ONE ENDDO ENDIF IF(ND.EQ.1) THEN DO K=1,2 SM(2*K-1) = 0.0D0 SM(2*K) = 0.0D0 SW(2*K-1) = 0.0D0 SW(2*K) = 0.0D0 ENDDO SM(5) = RMASS(SN(3)) SM(6) = RMASS(SB(3)) SW(5) = HBAR/RLTIM(SN(3)) SW(6) = HBAR/RLTIM(SB(3)) ELSE DO K=1,2 SM(2*K-1) = RMASS(SN(K)) SM(2*K) = RMASS(SB(K)) SW(2*K-1) = HBAR/RLTIM(SN(K)) SW(2*K) = HBAR/RLTIM(SB(K)) SM(4+K) = ZERO SW(4+K) = ZERO ENDDO ENDIF ELSE C--UNKNOWN CALL HWWARN('HWDRME',500) ENDIF C--Set mixing to zero if diagram not available IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3))) & .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1) IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3))) & .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1) IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3))) & .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2) IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3))) & .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2) IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2))) & .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3) IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2))) & .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3) C--Calculate the limiting points DO J=1,2 IF(ND.NE.1) THEN IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J), & M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J)) IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J), & M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J)) ENDIF IF(ND.NE.2) THEN IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J), & M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J)) ENDIF ENDDO C--Now evaluate the limit using these points LIMIT = ZERO DO 100 I=1,6 IF(ABS(MX(I)).LT.EPS) GOTO 100 LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX, & M,SM,SW,INFCOL,AM,0,ND) 100 CONTINUE LIMIT = TWO*LIMIT C--Now evaluate at a random point MTRY = 0 25 MTRY = MTRY+1 LTRY = 0 35 LTRY = LTRY+1 CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP), & PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT) C--Now calculate the m12sq etc for the actual point M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1)) M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2)) M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2)) C--Now calulate the matrix element TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX, & M,SM,SW,INFCOL,AM,1,ND) C--Now test the value againest the limit RAND = HWRGEN(0)*LIMIT IF(TEST2.GT.LIMIT) THEN LIMIT = 1.1D0*TEST2 CALL HWWARN('HWDRME',51) GOTO 150 ENDIF 150 IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN GOTO 35 ELSEIF(LTRY.GE.NETRY) THEN IF(MTRY.LE.NETRY) THEN LIMIT = LIMIT*0.9D0 CALL HWWARN('HWDRME',52) GOTO 25 ELSE CALL HWWARN('HWDRME',100) GOTO 999 ENDIF ENDIF C--Reorder the particles in gluino decay to get angular ordering right IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN DO LTRY=1,3 IF(TEST(LTRY).GT.RAND) THEN IF(LTRY.EQ.2) THEN IDHWTP = IDHW(MHEP) IDHW(MHEP) = IDHW(MHEP+1) IDHW(MHEP+1) = IDHWTP IDHPTP = IDHEP(MHEP) IDHEP(MHEP) = IDHEP(MHEP+1) IDHEP(MHEP+1) = IDHPTP CALL HWVEQU(5,PHEP(1,MHEP),DECMOM) CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP)) CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1)) ELSEIF(LTRY.EQ.3) THEN IDHWTP = IDHW(MHEP) IDHW(MHEP) = IDHW(MHEP+2) IDHW(MHEP+2) = IDHWTP IDHPTP = IDHEP(MHEP) IDHEP(MHEP) = IDHEP(MHEP+2) IDHEP(MHEP+2) = IDHPTP DO I=1,5 CALL HWVEQU(5,PHEP(1,MHEP),DECMOM) CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP)) CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2)) ENDDO ENDIF GOTO 52 ENDIF RAND=RAND-TEST(LTRY) ENDDO ENDIF 52 CONTINUE 999 RETURN END CDECK ID>, HWDRM1. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW & ,INFCOL,AM,LM,ND) C----------------------------------------------------------------------- C FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN C PHASE-SPACE POINT C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6), & INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO, & M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4 PARAMETER (ZERO=0) EXTERNAL HWDRM2,HWDRM3,HWDRM4 INTEGER LM,K,ND C--Zero the array DO K=1,21 TERM(K) = 0.0D0 ENDDO HWDRM1 = 0.0D0 C--The amplitude IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1), & SW(1),A(1),B(1)) IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2), & M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2)) IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ, & M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3)) IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ, & M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4)) IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ, & M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1)) IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ, & M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1)) ENDIF IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2), & SW(2),A(2),B(2)) IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ, & M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3)) IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ, & M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4)) IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ, & M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2)) IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ, & M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2)) ENDIF IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3), & SW(3),A(3),B(3)) IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1), & M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4)) IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ, & M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5)) IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ, & M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6)) ENDIF IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4), & SW(4),A(4),B(4)) IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ, & M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5)) IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ, & M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6)) ENDIF IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5), & SW(5),A(5),B(5)) IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1), & M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6)) ENDIF IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2* & HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6)) DO K=10,21 TERM(K)=TERM(K)*INFCOL ENDDO C--Add them up DO K=1,21 HWDRM1 = HWDRM1+TERM(K) ENDDO C--Different colour flows for the gluino IF(LM.NE.0) THEN NPLN = 0.0D0 PLN = 0.0D0 DO K=1,9 PLN = PLN+TERM(K) ENDDO DO K=10,21 NPLN= NPLN+TERM(K) ENDDO DO K=1,3 TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN) ENDDO ELSE DO K=1,3 TEST(K) = 0.0D0 ENDDO ENDIF IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50) END CDECK ID>, HWDRM2. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B) C----------------------------------------------------------------------- C Function to compute the matrix element squared part of a 3-body C R-parity decay C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1 HWDRM2 = (X - MA**2 - MB**2)*(4*A*B*MC*MD + & (A**2 + B**2)*(-X + MC**2 + MD**2))/ & ((X-MR1**2)**2+GAM1**2*MR1**2) END CDECK ID>, HWDRM3. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2) C----------------------------------------------------------------------- C Function to compute the light/heavy interference part of a 3-body C R-parity decay C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1 & ,GAM2 C HWDRM3 = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD + & (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))* & (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/ & (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2)) END CDECK ID>, HWDRM4. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2) C----------------------------------------------------------------------- C Function to compute the interference part of a 3-body C R-parity decay C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1 & ,GAM2 C HWDRM4 = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))* & (A2*B1*MC*MD*(X - MA**2 - MB**2) + & A1*A2*MA*MC*(X + Y - MA**2 - MC**2) + & A1*B2*MA*MD*(Y - MB**2 - MC**2) + & B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/ & (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2)) END CDECK ID>, HWDRM5. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM) C----------------------------------------------------------------------- C Subroutine to find the maximum of the ME C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D, & E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO EXTERNAL HWRUNI PARAMETER(EPS=1D-9,ZERO=0) C = A**2+B**2 D = 4*A*B RES(1) = -D*(MA**2 + MB**2)*MC*MD + & C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 - & MA**2*MD**2 - MB**2*MD**2) RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)* & (D**2*MC**2*MD**2 + & 2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) + & C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2)) RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2)) IF(RES(2).GT.ZERO) THEN RES(2) = SQRT(RES(2)) ELSE RES(2) = 0.0D0 ENDIF IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR. & (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN X = (RES(1)-RES(2))/RES(3) ELSE X = (RES(1)+RES(2))/RES(3) ENDIF IF(X.GT.(MD-MC)**2) X = (MD-MC)**2 IF(X.LT.(MA+MB)**2) X = (MA+MB)**2 E2S = (X-MA**2+MB**2)/(2*SQRT(X)) E3S = (MD**2-X-MC**2)/(2*SQRT(X)) E2M = E2S**2-MB**2 E3M = E3S**2-MC**2 IF(E2M.LT.ZERO) THEN IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2) E2M= 0.0D0 ENDIF IF(E3M.LT.ZERO) THEN IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3) E3M= 0.0D0 ENDIF E2M = SQRT(E2M) E3M = SQRT(E3M) LOW = (E2S+E3S)**2-(E2M+E3M)**2 UPP = (E2S+E3S)**2-(E2M-E3M)**2 Y = HWRUNI(1,LOW,UPP) Z = MA**2+MB**2+MC**2+MD**2-X-Y END CDECK ID>, HWDPWT. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWDPWT(EMSQ,DUMMYA,DUMMYB,DUMMYC) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWDPWT,EMSQ,DUMMYA,DUMMYB,DUMMYC HWDPWT=1. END CDECK ID>, HWDSIN. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSIN(CLSAVE) C----------------------------------------------------------------------- C Subroutine to perform decays including spin correlations C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PW(5) INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY, & ID1 IF(IERROR.NE.0) RETURN NTRY = 0 IDEC = 1 1 NTRY = NTRY+1 C--search the decay products and decide which one to decay next IF(.NOT.DECSPN(IDEC)) THEN CALL HWDSI1(IDEC,IP) ELSE IDEC = JMOSPN(IDEC) GOTO 1 ENDIF C--first no more particles in this decay to develop so move up chain IF(IP.EQ.0) THEN IDEC = JMOSPN(IDEC) C--reached the end of this spin chain go back to HWDHOB IF(IDEC.EQ.0) THEN NSPN = 0 RETURN C--otherwise keep going up the chain ELSE IF(NTRY.LE.NBTRY) THEN GOTO 1 ELSE CALL HWWARN('HWDSIN',100) GOTO 999 ENDIF ENDIF C--special for tau decays call spin correlation in tau decay routine ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN CALL HWDSI3(IP) IF(IERROR.NE.0) RETURN GOTO 1 ENDIF C--work out where that particle is IHEP = IDSPN(IP) C--if particle has daughters 10 IF(JDAHEP(1,IHEP).NE.0) THEN IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP) IF(IDHW(ID1).EQ.ID) IHEP=ID1 ENDDO ELSE IHEP = JDAHEP(1,IHEP) ENDIF ENDIF IS=ISTHEP(IHEP) ID=IDHW(IHEP) NTRY = NTRY+1 IF(NTRY.GE.NBTRY) THEN CALL HWWARN('HWDSIN',101) GOTO 999 ENDIF 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 CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP) IF(IERROR.NE.0) RETURN ELSE GOTO 10 ENDIF C--perform the decay including spin correlations CALL HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW) IF(IERROR.NE.0) RETURN C--make the colour connections CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE) IF (IERROR.NE.0) RETURN C--perform the parton-showers CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW) IF(IERROR.NE.0) RETURN C--perform RPV colour connections CALL HWDHO5(MHEP,LHEP,CLSAVE) IF(IERROR.NE.0) RETURN C--continue and perform the next decay IDEC = IP IF(NTRY.LE.NBTRY) THEN GOTO 1 ELSE CALL HWWARN('HWDSIN',102) ENDIF 999 RETURN END CDECK ID>, HWDSI1. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSI1(IDEC,IP) C----------------------------------------------------------------------- C Subroutine to check a vertex and decide which branch to treat C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P, & P1P,P2P,IF1,IF2,P5,P5P DOUBLE PRECISION NORM DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2) EXTERNAL HWRINT C--loop over the daughters and decide what to do IP = 0 C--if daughters of particle the same issue warning IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC)) THEN CALL HWWARN('HWDSI1',100) GOTO 999 ENDIF C--loop over the decay products DO I=JDASPN(1,IDEC),JDASPN(2,IDEC) IF(.NOT.DECSPN(I)) THEN C--first SM particles other than tau and top and stable particles IF(RSTAB(IDHW(IDSPN(I))) & .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6) & .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND. & ABS(IDHEP(IDSPN(I))).NE.15)) THEN DECSPN(I) = .TRUE. RHOSPN(1,1,I) = HALF RHOSPN(1,2,I) = ZERO RHOSPN(2,1,I) = ZERO RHOSPN(2,2,I) = HALF C--spinless particles ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN DECSPN(I) = .TRUE. RHOSPN(1,1,I) = ONE RHOSPN(1,2,I) = ZERO RHOSPN(2,1,I) = ZERO RHOSPN(2,2,I) = ZERO ELSE C--particle which needs development IP = IP+1 IPICK(IP) = I ENDIF ENDIF ENDDO C--pick the particle to decay next IF(IP.EQ.0) THEN IF(JMOSPN(IDEC).EQ.0) RETURN C--done everything compute the decay matrix and move up DECSPN(IDEC) = .TRUE. NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1 DO 20 P0=1,2 DO 20 P0P=1,2 20 RHOSPN(P0,P0P,IDEC) = ZERO C--two body decay IF(NPR.EQ.2) THEN DO 21 P0 =1,2 DO 21 P0P=1,2 DO 21 P1 =1,2 DO 21 P1P=1,2 DO 21 P2 =1,2 DO 21 P2P=1,2 21 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+ & MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC)) C--three body decay ELSEIF(NPR.EQ.3) THEN DO 25 P0 =1,2 DO 25 P0P=1,2 DO 25 P1 =1,2 DO 25 P1P=1,2 DO 25 P2 =1,2 DO 25 P2P=1,2 DO 25 P3 =1,2 DO 25 P3P=1,2 25 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+ & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--higher ELSE CALL HWWARN('HWDSI1',500) ENDIF C--now normalise this NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC)) IF(NORM.GT.ZERO) THEN NORM = ONE/NORM DO 35 P0=1,2 DO 35 P0P=1,2 35 RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC) ELSE CALL HWWARN('HWDSI1',101) GOTO 999 ENDIF ELSE C--pick the particle to be decayed IP = IPICK(HWRINT(1,IP)) C--setup the spin density matrix for the decay C--special for the hard process IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1 C--set up the spin density matrices for the incoming partons C--zero off diagonal elements RHOLP(2,1) = ZERO RHOLP(1,2) = ZERO RHOPS(2,1) = ZERO RHOPS(1,2) = ZERO C--set up for polarized incoming beams in lepton collisons IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND. & IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN RHOLP(1,1) = HALF*(ONE+EPOLN(3)) RHOLP(2,2) = HALF*(ONE-EPOLN(3)) RHOPS(1,1) = HALF*(ONE-PPOLN(3)) RHOPS(2,2) = HALF*(ONE+PPOLN(3)) C--otherwise average ELSE RHOLP(1,1) = HALF RHOLP(2,2) = HALF RHOPS(1,1) = HALF RHOPS(2,2) = HALF ENDIF C--first decay product IF(NPR.EQ.2) THEN IF(IP.EQ.JDASPN(1,IDEC)) THEN C--if using first colour flow option IF(SPCOPT.EQ.1) THEN DO 5 P3 =1,2 DO 5 P3P=1,2 RHOSPN(P3,P3P,IP) = ZERO DO 5 IF1=1,NCFL(1) DO 5 IF2=1,NCFL(1) DO 5 P1 =1,2 DO 5 P1P=1,2 DO 5 P2 =1,2 DO 5 P2P=1,2 DO 5 P4 =1,2 DO 5 P4P=1,2 5 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)* & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))* & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1) C--if using second colour flow option ELSEIF(SPCOPT.EQ.2) THEN DO 6 P3 =1,2 DO 6 P3P=1,2 RHOSPN(P3,P3P,IP) = ZERO DO 6 P1 =1,2 DO 6 P1P=1,2 DO 6 P2 =1,2 DO 6 P2P=1,2 DO 6 P4 =1,2 DO 6 P4P=1,2 6 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP) & +SPNCFC(NCFL(1),NCFL(1),1)* & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))* & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1) C--unknown option issue warning ELSE CALL HWWARN('HWDSI1',501) ENDIF C--second decay product ELSE IF(SPCOPT.EQ.1) THEN DO 10 P4 =1,2 DO 10 P4P=1,2 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0) DO 10 IF1=1,NCFL(1) DO 10 IF2=1,NCFL(1) DO 10 P1 =1,2 DO 10 P1P=1,2 DO 10 P2 =1,2 DO 10 P2P=1,2 DO 10 P3 =1,2 DO 10 P3P=1,2 10 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)* & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))* & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1) ELSEIF(SPCOPT.EQ.2) THEN DO 11 P4 =1,2 DO 11 P4P=1,2 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0) DO 11 P1 =1,2 DO 11 P1P=1,2 DO 11 P2 =1,2 DO 11 P2P=1,2 DO 11 P3 =1,2 DO 11 P3P=1,2 11 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP) & +SPNCFC(NCFL(1),NCFL(1),1)* & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))* & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1) ELSE CALL HWWARN('HWDSI1',502) GOTO 999 ENDIF ENDIF C--new for four body gauge boson pair processes ELSEIF(NPR.EQ.4) THEN C--first particle IF(IP.EQ.JDASPN(1,IDEC)) THEN DO 41 P1 =1,2 DO 41 P1P=1,2 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0) DO 41 P3 =1,2 DO 41 P3P=1,2 DO 41 P5 =1,2 DO 41 P5P=1,2 41 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+ & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--second particle ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN DO 42 P1 =1,2 DO 42 P1P=1,2 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0) DO 42 P3 =1,2 DO 42 P3P=1,2 DO 42 P5 =1,2 DO 42 P5P=1,2 42 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+ & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--third particle ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN DO 43 P3 =1,2 DO 43 P3P=1,2 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0) DO 43 P1 =1,2 DO 43 P1P=1,2 DO 43 P5 =1,2 DO 43 P5P=1,2 43 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+ & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--fourth particle ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN DO 44 P3 =1,2 DO 44 P3P=1,2 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0) DO 44 P1 =1,2 DO 44 P1P=1,2 DO 44 P5 =1,2 DO 44 P5P=1,2 44 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+ & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2) C--unrecognized issue warning ELSE CALL HWWARN('HWDSI1',509) GOTO 999 ENDIF C--unrecognized issue warning ELSE CALL HWWARN('HWDSI1',508) GOTO 999 ENDIF ELSE NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1 DO 50 P1 =1,2 DO 50 P1P=1,2 50 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0) C--set-up matrix for 2-body decay IF(NPR.EQ.2) THEN IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503) IF(IP.EQ.JDASPN(1,IDEC)) THEN DO 60 P0 =1,2 DO 60 P0P=1,2 DO 60 P1 =1,2 DO 60 P1P=1,2 DO 60 P2 =1,2 DO 60 P2P=1,2 60 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)* & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))* & RHOSPN(P2,P2P,JDASPN(2,IDEC)) ELSE DO 70 P0 =1,2 DO 70 P0P=1,2 DO 70 P1 =1,2 DO 70 P1P=1,2 DO 70 P2 =1,2 DO 70 P2P=1,2 70 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)* & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC)) ENDIF C--set-up matrix for 3-body decay ELSEIF(NPR.EQ.3) THEN IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1) & CALL HWWARN('HWDSI1',504) C--first particle IF(IP.EQ.JDASPN(1,IDEC)) THEN DO 100 P0 =1,2 DO 100 P0P=1,2 DO 100 P1 =1,2 DO 100 P1P=1,2 DO 100 P2 =1,2 DO 100 P2P=1,2 DO 100 P3 =1,2 DO 100 P3P=1,2 100 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)* & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))* & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--second particle ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN DO 105 P0 =1,2 DO 105 P0P=1,2 DO 105 P1 =1,2 DO 105 P1P=1,2 DO 105 P2 =1,2 DO 105 P2P=1,2 DO 105 P3 =1,2 DO 105 P3P=1,2 105 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)* & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P3,P3P,JDASPN(2,IDEC)) C--third particle ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN DO 110 P0 =1,2 DO 110 P0P=1,2 DO 110 P1 =1,2 DO 110 P1P=1,2 DO 110 P2 =1,2 DO 110 P2P=1,2 DO 110 P3 =1,2 DO 110 P3P=1,2 110 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)* & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)* & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1) C--unrecognized ELSE CALL HWWARN('HWDSI1',102) GOTO 999 ENDIF ELSEIF(NPR.EQ.4) THEN C--first particle IF(IP.EQ.JDASPN(1,IDEC)) THEN DO 151 P1 =1,2 DO 151 P1P=1,2 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0) DO 151 P2 =1,2 DO 151 P2P=1,2 DO 151 P3 =1,2 DO 151 P3P=1,2 DO 151 P4 =1,2 DO 151 P4P=1,2 151 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+ & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))* & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)* & RHOSPN(P4,P4P,JDASPN(2,IDEC)) C--second particle ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN DO 152 P2 =1,2 DO 152 P2P=1,2 RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0) DO 152 P1 =1,2 DO 152 P1P=1,2 DO 152 P3 =1,2 DO 152 P3P=1,2 DO 152 P4 =1,2 DO 152 P4P=1,2 152 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+ & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)* & RHOSPN(P4,P4P,JDASPN(2,IDEC)) C--third particle ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN DO 153 P3 =1,2 DO 153 P3P=1,2 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0) DO 153 P1 =1,2 DO 153 P1P=1,2 DO 153 P2 =1,2 DO 153 P2P=1,2 DO 153 P4 =1,2 DO 153 P4P=1,2 153 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+ & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)* & RHOSPN(P4,P4P,JDASPN(2,IDEC)) C--fourth particle ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN DO 154 P4 =1,2 DO 154 P4P=1,2 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0) DO 154 P1 =1,2 DO 154 P1P=1,2 DO 154 P2 =1,2 DO 154 P2P=1,2 DO 154 P3 =1,2 DO 154 P3P=1,2 154 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+ & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)* & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))* & RHOSPN(P1,P1P,JDASPN(1,IDEC))* & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)* & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2) ELSE CALL HWWARN('HWDSI1',505) ENDIF ELSE CALL HWWARN('HWDSI1',506) ENDIF ENDIF C--normalise the spin density matrix NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP)) IF(NORM.GT.ZERO) THEN NORM = ONE/NORM DO 15 P3=1,2 DO 15 P3P=1,2 15 RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP) ELSE CALL HWWARN('HWDSI1',107) GOTO 999 ENDIF ENDIF 999 RETURN END CDECK ID>, HWDSI2. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW) C----------------------------------------------------------------------- C Subroutine to perform the second part of the heavy object decays C IE generate the kinematics for the decay C including spin correlations C was part of HWDHOB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM INTEGER IHEP,IM,KHEP,MHEP,NPR,ISN,RHEP EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM IF (IERROR.NE.0) RETURN ISN = ISNHEP(IHEP) IF (NPR.EQ.2) THEN C Two body decay: LHEP -> MHEP + NHEP IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN C--generate a two body decay to a gauge boson as a three body decay CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000, & RHOSPN(1,1,ISN),ISN) C--two body decay ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000, & RHOSPN(1,1,ISN),ISN) C--otherwise issue warning C--change by PR 9/30/02 to issue non-terminal warning and continue ELSE CALL HWWARN('HWDSI2',1) 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.) DECSPN(ISN) = .TRUE. IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN RHOSPN(1,1,ISN) = ONE RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = ZERO ELSE RHOSPN(1,1,ISN) = HALF RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = HALF ENDIF ENDIF 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 C--if old codes issue warning IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN CALL HWWARN('HWDSI2',502) C--three body spin matrix element ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000, & RHOSPN(1,1,ISN),ISN) C--special for top decay IF(ABS(IDHEP(IHEP)).EQ.6) THEN CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW) CALL HWUMAS(PW) ENDIF C--unknown issue warning ELSE CALL HWWARN('HWDSI2',2) C Three body phase space decay CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP), & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT) CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP)) DECSPN(ISN) = .TRUE. IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN RHOSPN(1,1,ISN) = ONE RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = ZERO ELSE RHOSPN(1,1,ISN) = HALF RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = HALF ENDIF ENDIF ELSEIF(NPR.EQ.4) THEN CALL HWWARN('HWDSI2',3) C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP KHEP = MHEP RHEP = MHEP+1 MHEP = MHEP+2 ISTHEP(NHEP) = 114 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)) IF(IERROR.NE.0) RETURN CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP)) CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP)) DECSPN(ISN) = .TRUE. IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN RHOSPN(1,1,ISN) = ONE RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = ZERO ELSE RHOSPN(1,1,ISN) = HALF RHOSPN(1,2,ISN) = ZERO RHOSPN(2,1,ISN) = ZERO RHOSPN(2,2,ISN) = HALF ENDIF ELSE CALL HWWARN('HWDSI2',100) ENDIF END CDECK ID>, HWDSI3. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSI3(IP) C----------------------------------------------------------------------- C Subroutine to handle spin correlations in tau decays C averages spin if not using TAUOLA C if using TAUOLA selects the spin and uses TAUOLA to perform the C decay C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IP,IHEP,ID1,ID,NTRY DOUBLE PRECISION PPOL,HWRGEN,POL EXTERNAL HWRGEN C--if HERWIG is performing tau decays average over spins and return C--spin averaged tau decay will be done later IF(TAUDEC.EQ.'HERWIG') THEN DECSPN(IP) = .TRUE. RHOSPN(1,1,IP) = HALF RHOSPN(2,1,IP) = ZERO RHOSPN(1,2,IP) = ZERO RHOSPN(2,2,IP) = HALF C--if using tauola select the polarization for the decay ELSEIF(TAUDEC.EQ.'TAUOLA') THEN C--work out where that particle is IHEP = IDSPN(IP) NTRY = 0 10 ID = IDHW(IHEP) IF(JDAHEP(1,IHEP).NE.0) THEN IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP) IF(IDHW(ID1).EQ.ID) IHEP=ID1 ENDDO ELSE IHEP = JDAHEP(1,IHEP) ENDIF NTRY = NTRY+1 IF(NTRY.LT.NBTRY) THEN GOTO 10 ELSE CALL HWWARN('HWDSI3',100) GOTO 999 ENDIF ENDIF C--select the tau polarization PPOL = DBLE(RHOSPN(1,1,IP)) IF(PPOL.GE.HWRGEN(0)) THEN POL = 1.0D0 RHOSPN(1,1,IP) = ONE RHOSPN(2,1,IP) = ZERO RHOSPN(1,2,IP) = ZERO RHOSPN(2,2,IP) = ZERO ELSE POL =-1.0D0 RHOSPN(1,1,IP) = ZERO RHOSPN(2,1,IP) = ZERO RHOSPN(1,2,IP) = ZERO RHOSPN(2,2,IP) = ONE ENDIF C--decay the particle CALL HWDTAU(1,IHEP,POL) DECSPN(IP) = .TRUE. ELSE CALL HWWARN('HWDSI3',500) ENDIF 999 RETURN END CDECK ID>, HWDSM2. *CMZ :- -09/04/02 13:46:07 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN) C----------------------------------------------------------------------- C Subroutine to calculate the two body matrix element for spin C correlations C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P, & NTRY DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA, & HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2), & WGT,WTMAX,HWRGEN DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8), & F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(EPS=1D-20) EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN SAVE O,PREF DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/ DATA O/2,1/ C--first setup if this is the start of a new spin chain IF(NSPN.EQ.0) THEN C--zero the elements of the array CALL HWVZRI( NMXHEP,ISNHEP) CALL HWVZRI( NMXSPN,JMOSPN) CALL HWVZRI(2*NMXSPN,JDASPN) CALL HWVZRI( NMXSPN, IDSPN) NSPN = NSPN+1 JMOSPN(NSPN) = 0 IDSPN (NSPN) = ID DECSPN(NSPN) = .FALSE. IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN RHOSPN(1,1,NSPN) = ONE RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = ZERO ELSE RHOSPN(1,1,NSPN) = HALF RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = HALF ENDIF ISNHEP(ID) = NSPN ENDIF C--MA is mass for this decay (OFF-SHELL) C--generate the momenta for a two body decay P(5,1) = PHEP(5, ID) P(5,2) = PHEP(5,IOUT1) P(5,3) = PHEP(5,IOUT2) IDP(1) = IDHW(ID) IDP(2) = IDHW(IOUT1) IDP(3) = IDHW(IOUT2) DO 1 I=1,3 MA(I) = P(5,I) 1 MA2(I) = MA(I)**2 PCMA = HWUPCM(P(5,1),P(5,2),P(5,3)) C--setup the couplings DO 2 I=1,2 2 A(I) = A2MODE(I,IMODE) C--phase space factor PHS = PCMA/MA2(1)/8.0D0/PIFAC C--maximum weight WTMAX = WT2MAX(IMODE) NTRY = 0 1000 NTRY = NTRY+1 CALL HWVEQU(5,PHEP(1,ID),P(1,1)) CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.) DO 3 I=1,3 C--compute the references vectors C--not important if SM particle which can't have spin measured C--ie anything other the top and tau C--also not important if particle is approx massless C--first the SM particles other than top and tau IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN CALL HWVEQU(5,PREF,PLAB(1,I+3)) C--all other particles ELSE PP = SQRT(HWVDOT(3,P(1,I),P(1,I))) CALL HWVSCA(3,ONE/PP,P(1,I),N) PLAB(4,I+3) = HALF*(P(4,I)-PP) PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I))) CALL HWVSCA(3,PP,N,PLAB(1,I+3)) CALL HWUMAS(PLAB(1,I+3)) PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3)) C--fix to avoid problems if approx massless due to energy IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3)) ENDIF C--now the massless vectors PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I)) DO 4 J=1,4 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3) 3 CALL HWUMAS(PLAB(1,I)) C--change order of momenta for call to HE code DO 5 I=1,3 PM(1,I) = P(3,I) PM(2,I) = P(1,I) PM(3,I) = P(2,I) PM(4,I) = P(4,I) 5 PM(5,I) = P(5,I) DO 6 I=1,6 PCM(1,I)=PLAB(3,I) PCM(2,I)=PLAB(1,I) PCM(3,I)=PLAB(2,I) PCM(4,I)=PLAB(4,I) 6 PCM(5,I)=PLAB(5,I) C--compute the S functions CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D) DO 7 I=1,6 DO 7 J=1,6 S(I,J,2) = -S(I,J,2) 7 D(I,J) = TWO*D(I,J) C--now compute the F functions needed CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2)) CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1)) CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2)) CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3)) CALL HWH2F1(6,F1F,5,PM(1,2), MA(2)) CALL HWH2F3(6,F2 ,PM(1,3),ZERO ) CALL HWH2F3(6,F0B ,PM(1,1),ZERO ) C--now compute the diagrams C--fermion --> fermion scalar IF(I2DRTP(IMODE).EQ.1) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5)) PRE = HALF/SQRT(PRE) DO 10 P0=1,2 DO 10 P1=1,2 ME(P0,P1,2) = (0.0D0,0.0D0) 10 ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0( P1 ,O(P0),2) & +A( P1 )*MA(2)* F0(O(P1),O(P0),5)) C--fermion --> scalar fermion diagrams ELSEIF(I2DRTP(IMODE).EQ.2) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6)) PRE = HALF/SQRT(PRE) DO 20 P0=1,2 DO 20 P2=1,2 ME(P0,2,P2) = (0.0D0,0.0D0) 20 ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0( P2 ,O(P0),3) & +A( P2 )*MA(3)* F0(O(P2),O(P0),6)) C--fermion --> scalar antifermion ELSEIF(I2DRTP(IMODE).EQ.3) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6)) PRE =-HALF/SQRT(PRE) DO 30 P0=1,2 DO 30 P2=1,2 ME(P0,2,P2) = (0.0D0,0.0D0) 30 ME(P0,1,P2) = PRE*( A( P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1) & -A(O(P0))*MA(1) *F2M( P0 ,O(P2),4)) C--fermion --> fermion gauge boson ELSEIF(I2DRTP(IMODE).EQ.4) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))* & HWULDO(PM(1,3),PCM(1,6)) PRE = HALF/SQRT(PRE) DO 40 P0=1,2 DO 40 P1=1,2 ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3) 40 ME(P0,P1,2) = PRE* F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3) C--scalar --> fermion antifermion ELSEIF(I2DRTP(IMODE).EQ.5) THEN PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6)) PRE =-HALF/SQRT(PRE) DO 50 P1=1,2 DO 50 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 50 ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M( P1 ,O(P2),2) & +A( P1 )*MA(2)* F2M(O(P1),O(P2),5)) C--scalar --> fermion fermion ELSEIF(I2DRTP(IMODE).EQ.6) THEN PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6)) PRE = HALF/SQRT(PRE) DO 60 P1=1,2 DO 60 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 60 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,P1,3) & +A( P2 )*MA(3)* F1M(O(P2),P1,6)) C--fermion --> fermion pion ELSEIF(I2DRTP(IMODE).EQ.7) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5)) PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2 DO 70 P0=1,2 DO 70 P1=1,2 ME(P0,P1,2) = (0.0D0,0.0D0) 70 ME(P0,P1,1) =PRE*( & MA(1)*A(O(P0))*( S(5,2,O(P1))*F2( P1 ,O(P0),2,4) & +MA(2)*F2(O(P1),O(P0),5,4)) & +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2( P1 , P0 ,2,1) & +MA(2)*F2(O(P1), P0 ,5,1))) C--scalar --> antifermion fermion ELSEIF(I2DRTP(IMODE).EQ.8) THEN PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6)) PRE =-HALF/SQRT(PRE) DO 80 P1=1,2 DO 80 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 80 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,O(P1),3) & +A( P2 )*MA(3)* F1M(O(P2),O(P1),6)) C--neutralino --> gravitino photon ELSEIF(I2DRTP(IMODE).EQ.9) THEN PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6)) PRE = TWO/SQRT(PRE) DO 90 P1=1,2 DO 90 P2=1,2 ME(P1,P2,O(P2)) = (0.0D0,0.0D0) 90 ME(P1,P2, P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))* & S(3,2,P2)*F0(O(P2),P1,2) C--neutralino --> gravitino scalar ELSEIF(I2DRTP(IMODE).EQ.10) THEN PRE = TWO*HWULDO(PM(1,1),PCM(1,4)) PRE = ONE/SQRT(PRE) DO 100 P1=1,2 DO 100 P2=1,2 ME(P1,P2,2) = (0.0D0,0.0D0) 100 ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2) C--sfermion --> fermion gravitino ELSEIF(I2DRTP(IMODE).EQ.11) THEN PRE = TWO*HWULDO(PM(1,2),PCM(1,5)) PRE = ONE/SQRT(PRE) DO 110 P1=1,2 DO 110 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 110 ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3) C--antisfermion --> antifermion gravitino ELSEIF(I2DRTP(IMODE).EQ.12) THEN PRE = TWO*HWULDO(PM(1,2),PCM(1,5)) PRE = ONE/SQRT(PRE) DO 120 P1=1,2 DO 120 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 120 ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3) C--scalar --> antifermion antifermion ELSEIF(I2DRTP(IMODE).EQ.13) THEN PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6)) PRE = HALF/SQRT(PRE) DO 130 P1=1,2 DO 130 P2=1,2 ME(2,P1,P2) = (0.0D0,0.0D0) 130 ME(1,P1,P2) = PRE*( A( P1 )*S(5,2, P1 )*F2M(O(P1),O(P2),2) & +A(O(P1))*MA(2) *F2M( P1 ,O(P2),5)) C--antifermion --> scalar antifermion ELSEIF(I2DRTP(IMODE).EQ.14) THEN PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6)) PRE = HALF/SQRT(PRE) DO 140 P0=1,2 DO 140 P2=1,2 ME(P0,2,P2) = (0.0D0,0.0D0) 140 ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M( P0 ,O(P2),1) & -A( P0 )*MA(1) *F2M(O(P0),O(P2),4)) C--unrecognized type of diagram ELSE CALL HWWARN('HWDSM2',500) ENDIF C--now compute the weight WGT = ZERO DO 500 P0 =1,2 DO 500 P0P=1,2 DO 500 P1 =1,2 DO 500 P2 =1,2 500 WGT = WGT+PHS*P2MODE(IMODE)*DREAL( & ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*RHOIN(P0,P0P)) IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR. & I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300 C--issue warning if greater than maximum IF(WGT.GT.WTMAX) THEN CALL HWWARN('HWDSM2',1) WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))), & RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))), & WTMAX,1.1D0*WGT WT2MAX(IMODE) = 1.1D0*WGT WTMAX = WT2MAX(IMODE) ENDIF IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000 IF(NTRY.GE.NSNTRY) THEN CALL HWWARN('HWDSM2',100) GOTO 999 ENDIF C--now enter the momenta in the common block 300 CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1)) CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2)) C--set up the spin information C--setup for all decays JMOSPN(NSPN+1) = IDSPIN JMOSPN(NSPN+2) = IDSPIN JDASPN(1,IDSPIN) = NSPN+1 JDASPN(2,IDSPIN) = NSPN+2 IDSPN(NSPN+1) = IOUT1 IDSPN(NSPN+2) = IOUT2 DO 11 I=1,2 DECSPN(NSPN+I) = .FALSE. DO 11 J=1,2 11 JDASPN(I,NSPN+J) = 0 ISNHEP(IOUT1) = NSPN+1 ISNHEP(IOUT2) = NSPN+2 DO 12 I=1,2 IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN RHOSPN(1,1,NSPN+I) = ONE RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = ZERO ELSE RHOSPN(1,1,NSPN+I) = HALF RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = HALF ENDIF 12 CONTINUE NSPN = NSPN+2 C--now enter the matrix element DO 150 P0=1,2 DO 150 P1=1,2 DO 150 P2=1,2 MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0) 150 MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2) SPNCFC(1,1,IDSPIN) = ONE NCFL(IDSPIN) = 1 RETURN C--format statements 2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX', & /10X,' MAXIMUM WEIGHT =',1PG24.16, & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16) 999 RETURN END CDECK ID>, HWDSM3. *CMZ :- -09/04/02 13:46:07 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN) C----------------------------------------------------------------------- C Master subroutine for three body SUSY and spin ME's C Uses HWD3ME to generate the momenta etc C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8), & F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8) DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR, & P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX) INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN, & DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE, & DRCF(NDIAGR) COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR), & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4), & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF EXTERNAL HWRGEN SAVE PZ,IOUT,ITYPE,ID1,ID2 C--calculate the matrix element for a three body decay IF(NPR.EQ.3) THEN C--set up the decay products, if a SUSY decay the SUSY particle C--must be the first decay product IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN IOUT(1) = IOUT1 IOUT(2) = IOUT2 IOUT(3) = IOUT3 ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN IOUT(1) = IOUT2 IOUT(2) = IOUT1 IOUT(3) = IOUT3 ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN IOUT(1) = IOUT3 IOUT(2) = IOUT1 IOUT(3) = IOUT3 C--special for top decay (bottom must be first) ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN IOUT(1) = IOUT3 IOUT(2) = IOUT1 IOUT(3) = IOUT2 ELSE IOUT(1) = IOUT2 IOUT(2) = IOUT1 IOUT(3) = IOUT3 ENDIF C--fermion must be second and antifermion third IF(IDHEP(IOUT(2)).LT.0.AND. & (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN I = IOUT(2) IOUT(2) = IOUT(3) IOUT(3) = I ENDIF C--setup the OFF SHELL MASSES MA(1) = PHEP(5,ID) DO 1 I=1,3 1 MA(I+1) = PHEP(5,IOUT(I)) DO 2 I=1,4 2 MA2(I) = MA(I)**2 C--call to ME code CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN) IF(IERROR.NE.0) RETURN C--juggle the momenta for the RPV BV gluino if needed IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN IF(NCFL(IDSPIN).EQ.2) THEN IOUT(1) = IOUT1 IOUT(2) = IOUT2 IOUT(3) = IOUT3 ELSEIF(NCFL(IDSPIN).EQ.3) THEN IOUT(1) = IOUT3 IOUT(2) = IOUT2 IOUT(3) = IOUT1 ENDIF DO I=1,3 IDHW(IOUT(I)) = IDP(I+1) ENDDO ENDIF C--copy momenta into event record DO 3 I=1,3 3 CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I))) C--enter the spin information in the common block IF(SYSPIN) THEN C--set up if start of new spin chain IF(NSPN.EQ.0) THEN C--zero the elements CALL HWVZRI( NMXHEP,ISNHEP) CALL HWVZRI( NMXSPN,JMOSPN) CALL HWVZRI(2*NMXSPN,JDASPN) CALL HWVZRI( NMXSPN, IDSPN) NSPN = NSPN+1 JMOSPN(NSPN) = 0 IDSPN (NSPN) = ID DECSPN(NSPN) = .FALSE. C--set up spin density matrix for particle IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN RHOSPN(1,1,NSPN) = ONE RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = ZERO ELSE RHOSPN(1,1,NSPN) = HALF RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = HALF ENDIF ISNHEP(ID) = NSPN ENDIF C--enter the decay products JDASPN(1,IDSPIN) = NSPN+1 JDASPN(2,IDSPIN) = NSPN+3 DO 7 I=1,3 JMOSPN(NSPN+I ) = IDSPIN IDSPN (NSPN+I ) = IOUT(I) DECSPN(NSPN+I ) = .FALSE. ISNHEP(IOUT(I) ) = NSPN+I IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN RHOSPN(1,1,NSPN+I) = ONE RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = ZERO ELSE RHOSPN(1,1,NSPN+I) = HALF RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = HALF ENDIF DO 7 J=1,2 7 JDASPN(J,NSPN+I) = 0 NSPN = NSPN+3 ENDIF C--select the decay mode and generate the decay for a two body mode ELSEIF(NPR.EQ.2) THEN IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN IB = IDHW(IOUT2) IOUT(1) = IOUT1 IOUT(2) = IOUT2 ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN IB = IDHW(IOUT1) IOUT(1) = IOUT2 IOUT(2) = IOUT1 ELSE CALL HWWARN('HWDSM3',501) ENDIF C--setup the off shell masses and particle ids for me code MA(1) = PHEP(5,ID) MA(2) = PHEP(5,IOUT(1)) CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0) ITYPE = ID1 IF(IB.EQ.199) ITYPE = ITYPE+1 IF(ITYPE.GT.120) ITYPE = ITYPE-114 IF(IB.NE.200) ITYPE = ITYPE/2 C--generate momenta of decay products CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN) CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1))) CALL HWVSUM(4,P(1,3),P(1,4),PZ) CALL HWUMAS(PZ) CALL HWVEQU(5,PZ,PHEP(1,IOUT(2))) C--enter the spin information in the common block if starting new chain IF(SYSPIN.AND.NSPN.EQ.0) THEN C--zero elements of common block CALL HWVZRI( NMXHEP,ISNHEP) CALL HWVZRI( NMXSPN,JMOSPN) CALL HWVZRI(2*NMXSPN,JDASPN) CALL HWVZRI( NMXSPN, IDSPN) NSPN = NSPN+1 JMOSPN(NSPN) = 0 IDSPN (NSPN) = ID DECSPN(NSPN) = .FALSE. IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN RHOSPN(1,1,NSPN) = ONE RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = ZERO ELSE RHOSPN(1,1,NSPN) = HALF RHOSPN(2,1,NSPN) = ZERO RHOSPN(1,2,NSPN) = ZERO RHOSPN(2,2,NSPN) = HALF ENDIF ISNHEP(ID) = NSPN ENDIF IF(SYSPIN) THEN IDSPN (NSPN+1 ) = IOUT(1) ISNHEP(IOUT(1)) = NSPN+1 ENDIF C--put the boson decay products into the event record for a two body mode ELSEIF(NPR.EQ.-1) THEN IOUT(1) = JDAHEP(1,IOUT(2)) IOUT(2) = NHEP+1 IOUT(3) = NHEP+2 C--set up the status of the particles ISTHEP(IOUT(1)) = 195 JDAHEP(1,IOUT(1)) = NHEP+1 JDAHEP(2,IOUT(1)) = NHEP+2 C--find the ID's of the particles IF(IDHW(IOUT(1)).EQ.200) THEN ID1 = ITYPE IF(ITYPE.GT.6) ID1 = ID1+114 ID2 = ID1+6 ELSE ID1 = 2*ITYPE-1 IF(ITYPE.GT.3) ID1 = ID1+114 ID2 = ID1+7 IF(IDHW(IOUT(1)).EQ.198) THEN I = ID1+6 ID1 = ID2-6 ID2 = I ENDIF ENDIF C--put id's of decay products into the event record IDHW(NHEP+1) = ID1 IDHW(NHEP+2) = ID2 IDHEP(NHEP+1) = IDPDG(ID1) IDHEP(NHEP+2) = IDPDG(ID2) C--boost decay products momenta to rest frame of boson CALL HWULOF(PZ,P(1,3),P(1,3)) CALL HWULOF(PZ,P(1,4),P(1,4)) C--boost back to lab using new boson CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1)) CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2)) C--setup for decay to quarks IF(ID1.LE.12) THEN ISTHEP(NHEP+1) = 113 ISTHEP(NHEP+2) = 114 JMOHEP(2,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+2 JMOHEP(2,NHEP+2) = NHEP+1 JDAHEP(2,NHEP+2) = NHEP+1 JMOHEP(1,NHEP+1) = IOUT(1) JMOHEP(1,NHEP+2) = IOUT(1) C--setup for decay to leptons ELSE ISTHEP(NHEP+1) = 193 ISTHEP(NHEP+2) = 193 JMOHEP(1,NHEP+1) = IOUT(1) JMOHEP(1,NHEP+2) = IOUT(1) JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1)) JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1)) JDAHEP(1,NHEP+1) = 0 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+1) = 0 JDAHEP(2,NHEP+2) = 0 ENDIF NHEP=NHEP+2 C--finish entering the spin information in the common block IF(SYSPIN) THEN JDASPN(1,IDSPIN) = NSPN+1 JDASPN(2,IDSPIN) = NSPN+3 DO 6 I=1,3 JMOSPN(NSPN+I ) = IDSPIN DECSPN(NSPN+I ) = .FALSE. IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN RHOSPN(1,1,NSPN+I) = ONE RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = ZERO ELSE RHOSPN(1,1,NSPN+I) = HALF RHOSPN(2,1,NSPN+I) = ZERO RHOSPN(1,2,NSPN+I) = ZERO RHOSPN(2,2,NSPN+I) = HALF ENDIF DO 6 J=1,2 6 JDASPN(J,NSPN+I) =0 NSPN = NSPN+3 IDSPN (NSPN-1) = NHEP-1 IDSPN (NSPN ) = NHEP ISNHEP(NHEP-1) = NSPN-1 ISNHEP(NHEP ) = NSPN ENDIF C--perform the parton shower for the decay products of the gauge boson IF(ID1.LE.12) CALL HWBGEN C--error issue warning ELSE CALL HWWARN('HWDSM3',500) ENDIF END CDECK ID>, HWDSM4. *CMZ :- -11/10/01 14:03:42 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE) C----------------------------------------------------------------------- C Subroutine to perform the four body decays C IOPT = 1 select decay mode and generate momenta C IOPT = 2 enter first decays and perform parton shower C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE, & IDP(4+NDIAGR),ID1,ID2,J DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP SAVE PW,ITYPE C--generate the decay IF(IOPT.EQ.1) THEN IB(1) = IDHW(IOUT1) IB(2) = IDHW(IOUT2) C--select the decays of the bosons DO 1 I=1,2 CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1) ITYPE(I) = IDF(2*I-1) IF(IB(I).EQ.199) ITYPE(I) = ITYPE(I)+1 IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114 1 IF(IB(I).NE.200) ITYPE(I) = ITYPE(I)/2 C--generate the momenta of the decay products CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE) DO 2 I=1,2 CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I)) 2 CALL HWUMAS(PW(1,I)) CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1)) CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2)) IF(SYSPIN) THEN IDSPN(1) = JDAHEP(1,ID) DECSPN(1) = .FALSE. ISNHEP(JDAHEP(1,ID)) = 1 JDASPN(1,1) = 2 JDASPN(2,1) = 5 DO 4 I=2,5 DECSPN(I) = .FALSE. 4 JMOSPN(I) = 1 ENDIF ELSEIF(IOPT.EQ.2) THEN IB(1) = JDAHEP(1,IOUT1) IB(2) = JDAHEP(1,IOUT2) DO 3 I=1,2 ISTHEP(IB(I)) = 195 JDAHEP(1,IB(I)) = NHEP+1 JDAHEP(2,IB(I)) = NHEP+2 C--find the ID's of the particles IF(IDHW(IB(I)).EQ.200) THEN ID1 = ITYPE(I) IF(ITYPE(I).GT.6) ID1 = ID1+114 ID2 = ID1+6 ELSE ID1 = 2*ITYPE(I)-1 IF(ITYPE(I).GT.3) ID1 = ID1+114 ID2 = ID1+7 IF(IDHW(IB(I)).EQ.198) THEN J = ID1+6 ID1 = ID2-6 ID2 = J ENDIF ENDIF C--put id's of decay products into the event record IDHW(NHEP+1) = ID1 IDHW(NHEP+2) = ID2 IDHEP(NHEP+1) = IDPDG(ID1) IDHEP(NHEP+2) = IDPDG(ID2) C--boost decay products momenta to rest frame of boson CALL HWULOF(PW(1,I),P(1,2*I ),P(1,2*I )) CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1)) C--boost back to lab using new boson CALL HWULOB(PHEP(1,IB(I)),P(1,2*I ),PHEP(1,NHEP+1)) CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2)) C--setup for decay to quarks IF(ID1.LE.12) THEN ISTHEP(NHEP+1) = 113 ISTHEP(NHEP+2) = 114 JMOHEP(2,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+2 JMOHEP(2,NHEP+2) = NHEP+1 JDAHEP(2,NHEP+2) = NHEP+1 JMOHEP(1,NHEP+1) = IB(I) JMOHEP(1,NHEP+2) = IB(I) C--setup for decay to leptons ELSE ISTHEP(NHEP+1) = 193 ISTHEP(NHEP+2) = 193 JMOHEP(1,NHEP+1) = IB(I) JMOHEP(1,NHEP+2) = IB(I) JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I)) JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I)) ENDIF C--enter the information in the spin common block IF(SYSPIN) THEN IDSPN(2*I ) = NHEP+1 IDSPN(2*I+1) = NHEP+2 ISNHEP(NHEP+1) = 2*I ISNHEP(NHEP+2) = 2*I+1 ENDIF NHEP=NHEP+2 C--perform the parton shower for the decay products of the gauge boson IF(ID1.LE.12) CALL HWBGEN 3 CONTINUE ENDIF END CDECK ID>, HWDTAU. *CMZ :- -17/10/01 09:42:21 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWDTAU(IOPT,IHEP,POL) C----------------------------------------------------------------------- C HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather C than HERWIG C IOPT =-1 initialises C IOPT = 1 performs decay C IOPT = 2 write outs final TAUOLA information C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO DOUBLE PRECISION POL REAL POL1(4) CHARACTER *8 DUMMY C--common block for PHOTOS LOGICAL QEDRAD COMMON /PHOQED/ QEDRAD(NMXHEP) C--common blocks for TAUOLA INTEGER NP1,NP2 COMMON /TAUPOS/ NP1, NP2 DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4) COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4 DOUBLE PRECISION DIST(4),VERTX(4) C--initialisation IF(IOPT.EQ.-1) THEN C--initialise TAUOLA CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT) CALL INIMAS CALL INIPHX(0.01d0) CALL INITDK C--generate a decay ELSEIF(IOPT.EQ.1) THEN ISTHEP(IHEP)=195 ID = IDHW(IHEP) IMO = IHEP 1 IMO = JMOHEP(1,IMO) IF(IDHW(IMO).EQ.ID) GOTO 1 C--id of tau for tauola IF(ID.EQ.125) THEN ITAU = 2 NP1 = IHEP NP2 = IHEP ELSEIF(ID.EQ.131) THEN ITAU = 1 NP1 = IHEP NP2 = IHEP ELSE CALL HWWARN('HWDTAU',501) ENDIF C--set up the tau polarization POL1(1) = 0. POL1(2) = 0. POL1(3) = REAL(POL) POL1(4) = 0. C--tau momentum C--three components DO I=1,3 IF(ID.EQ.125) THEN P1(I) =-PHEP(I,IHEP) P2(I) = PHEP(I,IHEP) ELSE P1(I) = PHEP(I,IHEP) P2(I) =-PHEP(I,IHEP) ENDIF C--we measure tau spins in lab frame Q1(I) = ZERO ENDDO C--energies P1(4)=PHEP(4,IHEP) P2(4)=PHEP(4,IHEP) Q1(4)=P1(4)+P2(4) C--perform the decay and generate QED radiation if needed NHEPPO=NHEP CALL DEXAY(ITAU,POL1) C--add tau decay vertex info. CALL HWUDKL(125,PHEP(1,IHEP),DIST) CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX) IF(IFPHOT.EQ.1) THEN IF(ID.EQ.1) THEN CALL PHOTOS(NP1) ELSE CALL PHOTOS(NP2) ENDIF ENDIF IF(NHEPPO.NE.NHEP) THEN DO 2 I=NHEPPO+1,NHEP CALL HWVEQU(4,VERTX,VHEP(1,I)) 2 CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY) ENDIF C--write out info at end ELSEIF(IOPT.EQ.2) THEN CALL DEXAY(100,POL1) C--otherwise issue warning ELSE CALL HWWARN('HWDTAU',500) ENDIF END CDECK ID>, HWDTHR. *CMZ :- -26/04/91 14.55.44 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT) C----------------------------------------------------------------------- C GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED C ACCORDING TO PHASE SPACE * WEIGHT C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW, & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO EXTERNAL HWRGEN,HWRUNI,WEIGHT PARAMETER (TWO=2.D0) A=P0(5)+P1(5) B=P0(5)-P1(5) C=P2(5)+P3(5) IF (B.LT.C) THEN CALL HWWARN('HWDTHR',100) GOTO 999 ENDIF D=ABS(P2(5)-P3(5)) AA=A*A BB=B*B CC=C*C DD=D*D EE=(B-C)*(A-D) A=0.5*(AA+BB) B=0.5*(CC+DD) C=4./(A-B)**2 C C CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION C 10 FF=HWRUNI(0,BB,CC) PP=(AA-FF)*(BB-FF) QQ=(CC-FF)*(DD-FF) WW=WEIGHT(FF,A,B,C)**2 RR=EE*FF*HWRGEN(0) IF (PP*QQ*WW.LT.RR*RR) GOTO 10 C C FF IS MASS SQUARED OF SUBSYSTEM 23. C C DO 2-BODY DECAYS 0->1+23, 23->2+3 C P23(5)=SQRT(FF) PCM1=SQRT(PP)*0.5/P0(5) PC23=SQRT(QQ)*0.5/P23(5) CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.) CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.) 999 RETURN END CDECK ID>, HWDTOP. *CMZ :- -09/12/92 11.03.46 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWDTOP(DECAY) C----------------------------------------------------------------------- C DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' LOGICAL DECAY DECAY=RMASS(6).GT.130D0 END CDECK ID>, HWDTWO. *CMZ :- -27/01/94 17.38.49 by Mike Seymour *-- Author : Bryan Webber & Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS) C----------------------------------------------------------------------- C GENERATES DECAY 0 -> 1+2 C C PCM IS CM MOMENTUM C C COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC) C IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS C IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5), & PP(5),R(9) LOGICAL ZAXIS EXTERNAL HWRUNI PARAMETER (ZERO=0.D0, ONE=1.D0) C--CHOOSE C.M. ANGLES C=COSTH IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE) S=SQRT(ONE-C*C) CALL HWRAZM(PCM*S,PP(1),PP(2)) C--PP IS MOMENTUM OF 2 IN C.M. PP(3)=-PCM*C PP(4)=SQRT(P2(5)**2+PCM**2) PP(5)=P2(5) C--ROTATE IF NECESSARY IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN CALL HWUROT(P0,ONE,ZERO,R) CALL HWUROB(R,PP,PP) ENDIF C--BOOST FROM C.M. TO LAB FRAME CALL HWULOB(P0,PP,P2) CALL HWVDIF(4,P0,P2,P1) END CDECK ID>, HWDWWT. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWDWWT(EMSQ,A,B,C) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWDWWT,EMSQ,A,B,C HWDWWT=(A-EMSQ)*(EMSQ-B)*C END CDECK ID>, HWDHWT. *CMZ :- -26/06/01 14.44.53 by Stefano Moretti *-- Author : Stefano Moretti C----------------------------------------------------------------------- FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/FFS/TB,BT COMMON/SFF/IT1,IB1,IT2,IB2 DOUBLE PRECISION TB,BT INTEGER IT1,IB1,IT2,IB2 DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2 DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC DOUBLE PRECISION HWDHWT,EMSQ CB1=RMASS(IT1)**2 TB1=RMASS(IB1)**2 CB2=RMASS(IT2)**2 TB2=RMASS(IB2)**2 C use formula (4.52) page 217 of `Higgs Hunter Guide'. TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1 C use formula (B. 1) page 411 of `Higgs Hunter Guide'. HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2 HWDHWT=TBH*HBT HWDHWT=ABS(HWDHWT)*SQRT(EMSQ) END CDECK ID>, HWDXLM. *CMZ :- -07/09/00 10:06:23 by Peter Richardson *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWDXLM(DKVRTX,STAB) C----------------------------------------------------------------------- C Sets STAB=.TRUE. if DKVRTX lies outside the specified region. C Revised 05/09/00 by BRW to put parameters in common C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION DKVRTX(4),RR LOGICAL STAB STAB=.FALSE. RR=DKVRTX(1)**2+DKVRTX(2)**2 IF (IOPDKL.EQ.1) THEN C Cylindrical geometry IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE. ELSEIF (IOPDKL.EQ.2) THEN C Spherical geometry RR=RR+DKVRTX(3)**2 IF (RR.GE.DXRSPH**2) STAB=.TRUE. ELSE C User supplied geometry -- missing CALL HWWARN('HWDXLM',500) ENDIF END CDECK ID>, HWECIR. *CMZ :- -11/05/01 15.44.55 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWECIR(Y) C----------------------------------------------------------------------- C INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION C NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE EXTERNAL CIRCEE ETA=0.6D0 Z=1-Y**(1/(1-ETA)) HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0)) END CDECK ID>, HWEFIN. *CMZ :- -15/07/02 17.56.53 by Peter Richardson *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWEFIN C----------------------------------------------------------------------- C TERMINAL CALCULATIONS ON ELEMENTARY PROCESS C Modified 28/03/01 by BRW to handle negative weights C Modified 15/07/02 by PR for Les Houches Accord C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I DOUBLE PRECISION RNWGT,SPWGT,ERWGT C--Les Houches Common Block INTEGER MAXPUP PARAMETER(MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP), & XMAXUP(MAXPUP),LPRUP(MAXPUP) IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0) IF (NWGTS.EQ.0) THEN WRITE (6,1) WRITE (6,10) 10 FORMAT(10X,'NO WEIGHTS GENERATED') RETURN ENDIF C--output Les Houches common block information IF(IPROC.LE.0) THEN C--WRITE THE HEADER WRITE(6,13) WRITE(6,14) C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION IF(ABS(IDWTUP).EQ.1) THEN DO I=1,NPRUP RNWGT = 1.0D0/DBLE(LHIWGT(I)) LHXSCT(I) = LHWGT(I)*RNWGT LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO)) LHXERR(I) = LHXERR(I)*SQRT(RNWGT) LHXSCT(I) = LHXSCT(I)*1.0D3 LHXERR(I) = LHXERR(I)*1.0D3 LHXMAX(I) = LHXMAX(I)*1.0D3 ENDDO C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT ELSEIF(ABS(IDWTUP).EQ.2) THEN DO I=1,NPRUP LHXMAX(I) = LHXMAX(I)*1.0D3 ENDDO ENDIF IF(ABS(IDWTUP).LE.2) THEN AVWGT = ZERO ERWGT = ZERO DO I=1,NPRUP WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3, & LHNEVT(I) AVWGT = AVWGT+LHXSCT(I) ERWGT = ERWGT+LHXERR(I)**2 ENDDO AVWGT = AVWGT*1.0D-3 ERWGT = SQRT(ERWGT)*1.0D-3 ELSE RNWGT=1./FLOAT(NWGTS) IF (NEGWTS) AVABW=ABWSUM*RNWGT AVWGT=WGTSUM*RNWGT SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO)) ERWGT=SPWGT*SQRT(RNWGT) IF (.NOT.NOWGT) WGTMAX=AVWGT IF (WGTMAX.EQ.ZERO) WGTMAX=ONE ENDIF C--STANDARD HERWIG OPTION ELSE RNWGT=1./FLOAT(NWGTS) IF (NEGWTS) AVABW=ABWSUM*RNWGT AVWGT=WGTSUM*RNWGT SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO)) ERWGT=SPWGT*SQRT(RNWGT) IF (.NOT.NOWGT) WGTMAX=AVWGT IF (WGTMAX.EQ.ZERO) WGTMAX=ONE ENDIF C--PRINT OUT THE INFO WRITE (6,1) 1 FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/) IF (NEGWTS) THEN WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT, & AVABW,WBIGST,WGTMAX,IPROC, & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX ELSE WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX, & IPROC, & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX ENDIF 11 FORMAT(1P, & 10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'// & 10X,'NUMBER OF EVENTS = ',I11/ & 10X,'NUMBER OF WEIGHTS = ',I11/ & 10X,'MEAN VALUE OF WGT =',E12.4/ & 10X,'RMS SPREAD IN WGT =',E12.4/ & 10X,'ACTUAL MAX WEIGHT =',E12.4/ & 10X,'ASSUMED MAX WEIGHT =',E12.4// & 10X,'PROCESS CODE IPROC = ',I11/ & 10X,'CROSS SECTION (PB) =',G12.4/ & 10X,'ERROR IN C-S (PB) =',G12.4/ & 10X,'EFFICIENCY PERCENT =',G12.4) 12 FORMAT(1P, & 10X,'N.B. NEGATIVE WEIGHTS ALLOWED'// & 10X,'NUMBER OF EVENTS = ',I11/ & 10X,'NEGATIVE EVENTS = ',I11/ & 10X,'NUMBER OF WEIGHTS = ',I11/ & 10X,'NEGATIVE WEIGHTS = ',I11/ & 10X,'MEAN VALUE OF WGT =',E12.4/ & 10X,'RMS SPREAD IN WGT =',E12.4/ & 10X,'MEAN ABS WEIGHT =',E12.4/ & 10X,'ACTUAL MAX ABS WGT =',E12.4/ & 10X,'ASSUMED MAXABS WGT =',E12.4// & 10X,'PROCESS CODE IPROC = ',I11/ & 10X,'CROSS SECTION (PB) =',G12.4/ & 10X,'ERROR IN C-S (PB) =',G12.4/ & 10X,'EFFICIENCY PERCENT =',G12.4) 13 FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/) 14 FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb) ',1X, & ' XERR(pb) ',1X,' Max wgt(nb)',1X,'No. of events'/) 15 FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7) END CDECK ID>, HWEGAM. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber & Luca Stanco C----------------------------------------------------------------------- SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA) C----------------------------------------------------------------------- C GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR C ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU- C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA, & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A INTEGER IHEP,IHADIS LOGICAL WWA EXTERNAL HWRGEN,HWRUNI SAVE EGMIN DATA EGMIN/5.D0/ IF (IERROR.NE.0) RETURN IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500) SS=PHEP(5,3) IF (IHEP.EQ.1) THEN IHADIS=2 ELSE IHADIS=1 IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS) ENDIF C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN CALL HWEGAS(S0) IF (S0.GT.ZERO) THEN S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2 S0 = MAX(S0,WHMIN**2) ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2) ZMAX = ONE ELSE C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER IF (FSTWGT) CALL HWWARN('HWEGAM',1) ZMIN = EGMIN / PHEP(4,IHEP) ZMAX = ONE ENDIF ELSE ZMIN=ZMI ZMAX=ZMA ENDIF C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z IF (.NOT.WWA) THEN ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP))) ZMAX=MIN(ZMAX,YWWMAX) ELSE ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP)) ENDIF IF (ZMIN.GE.ZMAX) THEN GAMWT=ZERO RETURN ENDIF C---GENERATE GAMMA MOMENTUM FRACTION A=HALF 10 IF (HWRGEN(2).LT.A) THEN ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX ELSE ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN ENDIF GAMWT = GAMWT * .5*ALPHEM/PIFAC * + (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM) IF (WWA) THEN GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2) ELSE C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2) QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM)) IF (QQMIN.GT.QQMAX) THEN CALL HWWARN('HWEGAM',50) GOTO 10 ENDIF Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX))) GAMWT = GAMWT * LOG(QQMAX/QQMIN) ENDIF IF (GAMWT.LT.ZERO) GAMWT=ZERO C---FILL PHOTON NHEP=NHEP+1 IDHW(NHEP)=59 ISTHEP(NHEP)=3 IDHEP(NHEP)=22 JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 JDAHEP(1,IHEP)=NHEP IF (WWA) THEN C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT( & (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP)) PHEP(2,NHEP)=0 PHEP(1,NHEP)=0 CALL HWUMAS(PHEP(1,NHEP)) ELSE C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ) PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP)) QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2 PMI=(QT2-Q2)/PPL PHEP(5,NHEP)=-SQRT(Q2) PHEP(4,NHEP)=(PPL+PMI)/TWO PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP)) CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP)) ENDIF C---UPDATE OVERALL CM FRAME JMOHEP(IHEP,3)=NHEP CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3)) CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3)) CALL HWUMAS(PHEP(1,3)) C---FILL OUTGOING LEPTON NHEP=NHEP+1 IDHW(NHEP)=IDHW(IHEP) ISTHEP(NHEP)=1 IDHEP(NHEP)=IDHEP(IHEP) JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 JDAHEP(2,IHEP)=NHEP CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP)) PHEP(5,NHEP)=PHEP(5,IHEP) END CDECK ID>, HWEGAS. *CMZ :- -18/04/04 10.45.55 by Mike Seymour *-- Author : Bryan Webber & Luca Stanco C----------------------------------------------------------------------- SUBROUTINE HWEGAS(S0) C----------------------------------------------------------------------- C FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION S0,RPM(2) INTEGER HQ,I IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN S0 = EMMIN**2 ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR. & IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN S0 = 4.D0*PTMIN**2 ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN HQ = MOD(IPROC,100) S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2) ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR. & IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27.OR. & IPRO.EQ.95) THEN S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2 ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2 ELSEIF (IPRO.EQ.33) THEN IF((MOD(IPROC,10000).EQ.3350).OR. & (MOD(IPROC,10000).EQ.3355))THEN S0 = MAX(2*RMASS(1),RMASS(206))**2 ELSEIF(MOD(IPROC,10000).EQ.3315)THEN S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2 ELSEIF(MOD(IPROC,10000).EQ.3325)THEN S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2 ELSEIF(MOD(IPROC,10000).EQ.3335)THEN S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2 ELSEIF(MOD(IPROC,10000).EQ.3365)THEN S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2 ELSEIF(MOD(IPROC,10000).EQ.3375)THEN S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2 ELSE S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2 END IF ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2 ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2 ELSEIF (IPRO.EQ.38) THEN IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN S0 = MAX(RMASS(6),RMASS(206))**2 ELSE S0 = RMASS(201+IHIGGS)**2 END IF ELSEIF (IPRO.EQ.23) THEN S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2 S0 = (PTMIN+SQRT(PTMIN**2+S0))**2 ELSEIF (IPRO.EQ.20) THEN S0 = RMASS(6)**2 ELSEIF (IPRO.EQ.21) THEN S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2 C--PR MOD 7/7/99 ELSEIF (IPRO.EQ.30) THEN S0 = 4.0D0*(PTMIN**2+RMMNSS**2) ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN HQ = MOD(IPROC,100) RPM(1) = RMMNSS RPM(2) = ZERO IF(HQ.GE.10.AND.HQ.LT.20) THEN RPM(1) = ABS(RMASS(450)) IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10))) ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN RPM(1) = ABS(RMASS(454)) IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20))) ELSEIF(HQ.EQ.30) THEN RPM(1) = RMASS(449) ELSEIF(HQ.EQ.40) THEN IF(IPRO.EQ.40) THEN RPM(1) = RMASS(425) DO I=1,5 RPM(1) = MIN(RPM(1),RMASS(425+I)) ENDDO ELSE RPM(1) = MIN(RMASS(405),RMASS(406)) ENDIF RPM(2) = RMASS(198) ELSEIF(HQ.EQ.50) THEN IF(IPRO.EQ.40) THEN RPM(1) = RMASS(425) DO I=1,5 RPM(1) = MIN(RPM(1),RMASS(425+I)) ENDDO DO I=1,3 RPM(2) = MIN(RPM(1),RMASS(433+2*I)) ENDDO RPM(1) = MIN(RPM(1),RPM(2)) RPM(2) = RMASS(203) DO I=1,2 RPM(2) = MIN(RPM(2),RMASS(204+I)) ENDDO ELSE RPM(1) = RMASS(401) RPM(2) = RMASS(413) DO I=1,5 RPM(1) = MIN(RPM(1),RMASS(401+I)) RPM(2) = MIN(RPM(2),RMASS(413+I)) ENDDO RPM(1) = MIN(RPM(1),RPM(2)) RPM(2) = RMASS(203) DO I=1,2 RPM(2) = MIN(RPM(2),RMASS(204+I)) ENDDO ENDIF RPM(2) = RMASS(203) DO I=1,2 RPM(2) = MIN(RPM(2),RMASS(204+I)) ENDDO ELSEIF(HQ.GE.60) THEN RPM(1) = ZERO ENDIF RPM(1) = RPM(1)**2 RPM(2) = RPM(2)**2 S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+ & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))) C--end of mod C--PR MOD 9/9/00 ELSEIF (IPRO.EQ.42) THEN S0 = EMMIN**2 ELSEIF (IPRO.EQ.52) THEN HQ = MOD(IPROC,100) S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2 ELSEIF (IPRO.EQ.60) THEN HQ = MOD(IPROC,100) IF (HQ.EQ.0) THEN S0 = 4.D0*PTMIN**2 ELSE IF (HQ.GT.6) HQ=2*HQ+107 IF (HQ.EQ.127) HQ=198 S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2) ENDIF ELSEIF (IPRO.EQ.80) THEN S0 = WHMIN**2 ELSEIF (IPRO.EQ.90) THEN S0 = Q2MIN ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN S0 = Q2MIN+4.D0*PTMIN**2 HQ = MOD(IPROC,100) IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2 IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2) ELSE S0 = 0 ENDIF END CDECK ID>, HWEINI. *CMZ :- -26/04/91 12.42.30 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWEINI C----------------------------------------------------------------------- C INITIALISES ELEMENTARY PROCESS C Modified 28/03/01 by BRW to handle negative weights C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRSET,DUMMY,SAFETY EXTERNAL HWRSET PARAMETER (SAFETY=1.001) INTEGER NBSH,I C---NO OF WEIGHT GENERATED NWGTS=0 NNEGWT=0 C---ACCUMULATED WEIGHTS WGTSUM=ZERO ABWSUM=ZERO C---ACCUMULATED WEIGHT-SQUARED WSQSUM=ZERO C---CURRENT MAX WEIGHT WBIGST=ZERO C---LAST VALUE OF SCALE EMLST=ZERO C---NUMBER OF ERRORS REPORTED NUMER=0 C---NUMBER OF ERRORS UNREPORTED NUMERU=0 C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED IF (NOWGT) THEN IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN NBSH=IBSH DUMMY = HWRSET(IBRN) WRITE(6,10) IPROC,IBRN,NBSH 10 FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'// & 10X,'PROCESS CODE IPROC = ',I11/ & 10X,'RANDOM NO. SEED 1 = ',I11/ & 10X,' SEED 2 = ',I11/ & 10X,'NUMBER OF SHOTS = ',I11) NEVHEP=0 DO 11 I=1,NBSH CALL HWEPRO 11 CONTINUE WRITE(6,20) 20 FORMAT(/10X,'INITIAL SEARCH FINISHED') IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM) & WGTMAX=SAFETY*WBIGST CALL HWEFIN NWGTS=0 NNEGWT=0 WGTSUM=ZERO WSQSUM=ZERO ABWSUM=ZERO WBIGST=ZERO ELSE WRITE(6,21) AVWGT,WGTMAX 21 FORMAT(/1P,10X,'INPUT EVT WEIGHT =',E12.4/ & 10X,'INPUT MAX WEIGHT =',E12.4) ENDIF ENDIF C---RESET RANDOM NUMBER DUMMY = HWRSET(NRN) ISTAT=5 END CDECK ID>, HWEISR. *CMZ :- -01/04/99 19.55.17 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWEISR(IHEP) C----------------------------------------------------------------------- C GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU- C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION CIRCKP(2) COMMON /HWCIR2/CIRCKP DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8, $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS INTEGER IHEP,I,J EXTERNAL HWRGEN SAVE Z,QSQ,PHI C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6) & .OR.IPRO.GT.12.OR.IPROC.EQ.850) RETURN C---CHECK CONSISTENCY OF TMNISR AND ZMXISR IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200) C---CALCULATE VIRTUALITY LIMITS QSQMAX=4*PHEP(4,IHEP)**2 QSQMIN=PHEP(5,IHEP)**2 C---AND THEREFORE THE Z DEPENDENCE A=ALPHEM/PIFAC B=A*(LOG(QSQMAX/QSQMIN)-1) C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE IF (IHEP.EQ.1) THEN IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN AA=10 ELSEIF (IPRO.EQ.2) THEN AA=0 ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN AA=1 ELSEIF (IPRO.EQ.9) THEN AA=0 IF((MOD(IPROC,10000).EQ.960).OR. & (MOD(IPROC,10000).EQ.970))THEN AA=1 ELSE CONTINUE ENDIF ELSE RETURN ENDIF C--set up the parameters for the resonance IF(IPRO.NE.8) THEN C--first the standard parameters if smoothing the Z resonance T0=RMASS(200)**2/QSQMAX T1=GAMZ*RMASS(200)/QSQMAX ELSE C--now the parameters for a resonant sneutrino in RPV C--uses the average of the muon and tau sneutrino mass and either the C--larger width or the difference in masses (whichever is larger) NMASS = HALF*(RMASS(428)+RMASS(430)) NWID = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430)) NWID = MAX(NWID,ABS(RMASS(428)-RMASS(430))) T0 = NMASS**2/QSQMAX T1 = NWID*NMASS/QSQMAX ENDIF IF (T0.GT.ONE) THEN T0=0 AA=0 ENDIF AA=AA*(1-T0) C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO: C ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t C +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t) C +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t C +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr-t) C +( (1-zmxisr)**(2*b) ) *delta(1-t) B1=(1-ZMXISR)**(2*B) B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B) B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR) B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1) $ *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1)) B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B)) B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR) B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2 B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1) $ *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1)) R=B8*HWRGEN(0) IF (R.LE.B1) THEN C---NEITHER EMITS T=1 GAMWT=GAMWT*B8/B1 Z(1)=1 ELSEIF (R.LE.B4) THEN C---ONE EMITS IF (R.LE.B2) THEN R=(R-B1)/(B2-B1) T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B) ELSEIF (R.LE.B3) THEN R=(R-B2)/(B3-B2) T=(TMNISR/ZMXISR)**R*ZMXISR ELSE R=(R-B3)/(B4-B3) T=T0+T1*TAN( $ ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R)) ENDIF GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+ $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2))) Z(1)=1 IF (HWRGEN(1).GT.HALF) Z(1)=T GAMWT=GAMWT*2 ELSE C---BOTH EMIT IF (R.LE.B5) THEN R=(R-B4)/(B5-B4) T=1-(1-TMNISR)* $ (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B) ELSEIF (R.LE.B6) THEN R=(R-B5)/(B6-B5) T=(TMNISR/ZMXISR**2)**R*ZMXISR**2 ELSEIF (R.LE.B7) THEN R=(R-B6)/(B7-B6) T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2 ELSE R=(R-B7)/(B8-B7) T=T0+T1*TAN( $ ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R)) ENDIF GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T $ + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+ $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2))) C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO: C 1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1) C1=LOG(ZMXISR**2/T) C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B) IF (C2.GT.ZERO) THEN R=C2*HWRGEN(4) IF (R.LE.C1) THEN Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR ELSE Z(1)=1-(1-T/ZMXISR)* $ (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B) IF (2*R.LE.C2+C1) Z(1)=T/Z(1) ENDIF ELSE Z(1)=SQRT(T) ENDIF GAMWT=GAMWT*C2/Z(1) $ /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1)) ENDIF C---INCLUDE DISTRIBUTION FUNCTIONS Z(2)=T/Z(1) DO 10 I=1,2 IF (Z(I).GT.ZMXISR) THEN Z(I)=1 CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12) ELSE CIRCKP(I)=(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2 $ *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12) $ +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I))) $ -4*LOG(Z(I))/(1-Z(I)))) ENDIF GAMWT=GAMWT*CIRCKP(I) 10 CONTINUE C---CHOOSE BOTH QSQ VALUES DO 30 I=1,2 IF (Z(I).GT.ZMXISR .OR. COLISR) THEN QSQ(I)=0 ELSE J=3-I C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX 20 QSQ(I)=(((1-Z(I))*(T/(Z(I)+T)) $ *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2 IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20 ENDIF 30 CONTINUE C---CHOOSE BOTH AZIMUTHS PHI(1)=HWRGEN(9)*2*PIFAC PHI(2)=HWRGEN(10)*2*PIFAC C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES I=0 IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1 IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2 IF (I.GT.0) THEN J=3-I Z(I)=Z(I)+QSQ(I)/QSQMAX IF (QSQ(J).GT.ZERO) THEN Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX $ -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I) C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I)) $ *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2 ENDIF ENDIF ELSEIF (IHEP.EQ.2) THEN C---EVERYTHING WAS GENERATED LAST TIME ELSE C---ROUTINE CALLED UNEXPECTEDLY CALL HWWARN('HWEISR',201) ENDIF C---IF Z IS TOO LARGE THERE IS NO EMISSION IF (Z(IHEP).GT.ZMXISR) RETURN C---PUT NEW LEPTON IN EVENT RECORD NHEP=NHEP+1 IDHW(NHEP)=IDHW(IHEP) IDHEP(NHEP)=IDHEP(IHEP) ISTHEP(NHEP)=3 JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 JDAHEP(1,IHEP)=NHEP C---AND OUTGOING PHOTON NHEP=NHEP+1 IDHW(NHEP)=59 IDHEP(NHEP)=22 ISTHEP(NHEP)=1 JMOHEP(1,NHEP)=IHEP JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 JDAHEP(2,IHEP)=NHEP C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION) PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP)) PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP)) PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP)) IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP) PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP)) PHEP(5,NHEP)=0 C---AND LEPTON CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1)) CALL HWUMAS(PHEP(1,NHEP-1)) C---UPDATE OVERALL CM FRAME JMOHEP(IHEP,3)=NHEP-1 CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3)) CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3)) CALL HWUMAS(PHEP(1,3)) END CDECK ID>, HWEONE. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWEONE C----------------------------------------------------------------------- C SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PA INTEGER ICMF,I,IBM,IHEP C---INCOMING LINES ICMF=NHEP+3 DO 15 I=1,2 IBM=I C---FIND BEAM AND TARGET IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I) IHEP=NHEP+I IDHW(IHEP)=IDN(I) IDHEP(IHEP)=IDPDG(IDN(I)) ISTHEP(IHEP)=110+I JMOHEP(1,IHEP)=ICMF JMOHEP(I,ICMF)=IHEP JDAHEP(1,IHEP)=ICMF C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP)) IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP) ELSE PHEP(1,IHEP)=0. PHEP(2,IHEP)=0. PHEP(5,IHEP)=RMASS(IDN(I)) PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM))) PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA) PHEP(3,IHEP)=PA-PHEP(4,IHEP) ENDIF 15 CONTINUE PHEP(3,NHEP+2)=-PHEP(3,NHEP+2) C---HARD CENTRE OF MASS IDHW(ICMF)=IDCMF IDHEP(ICMF)=IDPDG(IDCMF) ISTHEP(ICMF)=110 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) C---SET UP COLOUR STRUCTURE LABELS JMOHEP(2,NHEP+1)=NHEP+2 JDAHEP(2,NHEP+1)=NHEP+2 JMOHEP(2,NHEP+2)=NHEP+1 JDAHEP(2,NHEP+2)=NHEP+1 JDAHEP(1,NHEP+3)=NHEP+3 JDAHEP(2,NHEP+3)=NHEP+3 NHEP=NHEP+3 END CDECK ID>, HWEPRO. *CMZ :- -15/07/02 17.56.53 by Peter Richardson *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWEPRO C----------------------------------------------------------------------- C WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC C OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS C modifications for Les Houches accord by PR (7/15/02) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION CIRCKP(2) COMMON /HWCIR2/CIRCKP DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA, $ HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST INTEGER IHAD SAVE MISS DOUBLE PRECISION HWRGEN EXTERNAL HWRGEN,HWECIR C--Les Houches Common Block INTEGER MAXPUP PARAMETER(MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP), & XMAXUP(MAXPUP),LPRUP(MAXPUP) IF (IERROR.NE.0) RETURN C--pick the type of event to generate if using Les Houches accord C--first choice according to maxiumum weight IF(IPROC.LT.0) THEN IF(ABS(IDWTUP).EQ.1) THEN IF(ITYPLH.EQ.0) THEN TEST = HWRGEN(1)*LHMXSM DO ITYPLH=1,NPRUP IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5 TEST = TEST-ABS(LHXMAX(ITYPLH)) ENDDO 5 WGTMAX = ABS(LHXMAX(ITYPLH)) WBIGST = ABS(LHXMAX(ITYPLH)) ENDIF C--second choice according to cross section ELSEIF(ABS(IDWTUP).EQ.2) THEN IF(ITYPLH.EQ.0) THEN TEST = HWRGEN(1)*LHMXSM DO ITYPLH=1,NPRUP IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6 TEST = TEST-ABS(LHXSCT(ITYPLH)) ENDDO 6 WGTMAX = ABS(LHXMAX(ITYPLH)) WBIGST = ABS(LHXMAX(ITYPLH)) ENDIF ELSE WGTMAX = 1.0D0 WBIGST = 1.0D0 ITYPLH = 1 ENDIF ENDIF C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED 10 GENEV=.FALSE. C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE FSTWGT=NWGTS.EQ.0 C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT FSTEVT=NEVHEP.EQ.1 C---SET COLOUR CORRECTION TO FALSE COLUPD = .FALSE. HRDCOL(1,1)=0 HRDCOL(1,3)=0 C---SET UP INITIAL STATE NHEP=1 ISTHEP(NHEP)=101 PHEP(1,NHEP)=0. PHEP(2,NHEP)=0. PHEP(3,NHEP)=PBEAM1 PHEP(4,NHEP)=EBEAM1 PHEP(5,NHEP)=RMASS(IPART1) JMOHEP(1,NHEP)=0 JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHW(NHEP)=IPART1 IDHEP(NHEP)=IDPDG(IPART1) NHEP=NHEP+1 ISTHEP(NHEP)=102 PHEP(1,NHEP)=0. PHEP(2,NHEP)=0. PHEP(3,NHEP)=-PBEAM2 PHEP(4,NHEP)=EBEAM2 PHEP(5,NHEP)=RMASS(IPART2) JMOHEP(1,NHEP)=0 JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHW(NHEP)=IPART2 IDHEP(NHEP)=IDPDG(IPART2) C---NEXT ENTRY IS OVERALL CM FRAME NHEP=NHEP+1 IDHW(NHEP)=14 IDHEP(NHEP)=0 ISTHEP(NHEP)=103 JMOHEP(1,NHEP)=NHEP-2 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) C Select a primary interaction point IF (PIPSMR) THEN CALL HWRPIP ELSE CALL HWVZRO(4,VTXPIP) ENDIF CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP)) VHEP(4,NHEP)=0.0 C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX) C FOR HADRONIC PROCESSES WITH LEPTON BEAMS GAMWT=ONE IF (IPRO.GT.12.AND.IPRO.LT.90) THEN IF (CIRCOP.EQ.0) THEN IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13) & CALL HWEGAM(1,ZERO, ONE,.FALSE.) IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13) & CALL HWEGAM(2,ZERO, ONE,.FALSE.) ELSE C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP $ 'This version only works for e+e- annihilation' IF (FSTWGT) THEN RS=NINT(PHEP(5,3)*10)/1D1 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH) ENDIF CALL HWEGAM(1,ZERO, ONE,.TRUE.) CALL HWEGAM(2,ZERO, ONE,.TRUE.) Z1=PHEP(4,4)/PHEP(4,1) Z2=PHEP(4,6)/PHEP(4,2) C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0)) C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0)) C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1* $ LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2)) $ /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2* $ LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2)) C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2) QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1)) QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2) QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2)) B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1) B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2) IF (CIRCOP.EQ.1) THEN GAMWT=GAMWT*B1*B2 ELSEIF (CIRCOP.EQ.2) THEN GAMWT=GAMWT*C1*C2 ELSEIF (CIRCOP.EQ.3) THEN GAMWT=GAMWT*(C1+B1)*(C2+B2) ELSE STOP 'Illegal value of circop!' ENDIF ENDIF ELSEIF (IPRO.GE.90) THEN IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes' IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13) & CALL HWEGAM(2,ZERO, ONE,.FALSE.) ENDIF C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES IF (IPRO.GT.0.AND.IPRO.LE.12) THEN IF (CIRCOP.EQ.0) THEN CALL HWEISR(1) CALL HWEISR(2) ELSE C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP $ 'This version only works for e+e- annihilation' IF (FSTWGT) THEN RS=NINT(PHEP(5,3)*10)/1D1 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH) C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1 ETA=0.6D0 MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12) ENDIF COLISR=.TRUE. CALL HWEISR(1) CALL HWEISR(2) IHAD=1 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) Z1=PHEP(4,IHAD)/PHEP(4,1) IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) Z2=PHEP(4,IHAD)/PHEP(4,2) C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0)) C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0)) IF (Z1.EQ.ONE) C1=C1+MISS IF (Z2.EQ.ONE) C2=C2+MISS C---REMOVE WEIGHT GIVEN IN HWEISR B1=CIRCKP(1) B2=CIRCKP(2) GAMWT=GAMWT/(B1*B2) C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG IF (CIRCOP.EQ.1) THEN GAMWT=GAMWT*B1*B2 ELSEIF (CIRCOP.EQ.2) THEN GAMWT=GAMWT*C1*C2 ELSEIF (CIRCOP.EQ.3) THEN C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM IF (Z1.EQ.ONE) C1=C1-1 IF (Z2.EQ.ONE) C2=C2-1 C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501) IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502) GAMWT=GAMWT*(C1+B1)*(C2+B2) ELSE STOP 'Illegal value of circop!' ENDIF ENDIF ENDIF C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE IF (GAMWT.LE.ZERO) GOTO 30 C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY, C BOOST EVENT RECORD BACK TO CMF IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1) C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED 20 CONTINUE IPRO=MOD(IPROC/100,100) C---PROCESS GENERATED BY LES HOUCHES INTERFACE IF(IPRO.LE.0) THEN CALL HWHGUP ELSEIF (IPRO.EQ.1) THEN IF (IPROC.LT.110.OR.IPROC.GE.120) THEN C--- E+E- -> Q-QBAR OR L-LBAR CALL HWHEPA ELSE C--- E+E- -> Q-QBAR-GLUON CALL HWHEPG ENDIF ELSEIF (IPRO.EQ.2) THEN C--- E+E- -> W+ W- CALL HWHEWW ELSEIF (IPRO.EQ.3) THEN C---E+E- -> Z H CALL HWHIGZ ELSEIF (IPRO.EQ.4) THEN C---E+E- -> NUEB NUE H CALL HWHIGW ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN C---EE -> EE GAMGAM -> EE FFBAR/WW CALL HWHEGG ELSEIF (IPRO.EQ.5) THEN C---EE -> ENU GAMW -> ENU FF'BAR/WZ CALL HWHEGW ELSEIF (IPRO.EQ.6) THEN C---EE -> FOUR JETS CALL HWH4JT ELSEIF(IPRO.EQ.7) THEN C--EE -> SUSY PARTICLES(PAIR PRODUCTION) CALL HWHESP ELSEIF(IPRO.EQ.8) THEN C--EE -> RPV SUSY PARTICLE PRODUCTION CALL HWHREP ELSEIF (IPRO.EQ.9) THEN IF((MOD(IPROC,10000).EQ.955).OR. & (MOD(IPROC,10000).EQ.965).OR. & (MOD(IPROC,10000).EQ.975))THEN C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0. CALL HWHIHH ELSEIF((MOD(IPROC,10000).EQ.910).OR. & (MOD(IPROC,10000).EQ.920))THEN C---MSSM scalar Higgs production from vector-vector fusion. CALL HWHIGW ELSEIF((MOD(IPROC,10000).EQ.960).OR. & (MOD(IPROC,10000).EQ.970))THEN C---MSSM scalar Higgs production from Higgs-strahlung. CALL HWHIGZ END IF ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN C---SM/MSSM Higgs production with heavy quark flavours via e+e-. CALL HWHIGE ELSEIF (IPRO.EQ.13) THEN C---GAMMA/Z0/Z' DRELL-YAN PROCESS CALL HWHDYP ELSEIF (IPRO.EQ.14) THEN C---W+/- PRODUCTION VIA DRELL-YAN PROCESS CALL HWHWPR ELSEIF (IPRO.EQ.15) THEN C---QCD HARD 2->2 PROCESSES CALL HWHQCD ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION CALL HWHIGS ELSEIF (IPRO.EQ.17) THEN C---QCD HEAVY FLAVOUR PRODUCTION CALL HWHHVY ELSEIF (IPRO.EQ.18) THEN C---QCD DIRECT PHOTON + JET PRODUCTION CALL HWHPHO ELSEIF ((IPRO.EQ.19).OR.(IPRO.EQ.37)) THEN C---SM/MSSM HIGGS PRODUCTION VIA W/Z FUSION CALL HWHIGW ELSEIF (IPRO.EQ.20) THEN C---TOP PRODUCTION FROM W EXCHANGE CALL HWHWEX ELSEIF (IPRO.EQ.21) THEN C---VECTOR BOSON + JET PRODUCTION CALL HWHV1J ELSEIF (IPRO.EQ.22) THEN C QCD direct photon pair production CALL HWHPH2 ELSEIF (IPRO.EQ.23) THEN C QCD Higgs plus jet production CALL HWHIGJ ELSEIF (IPRO.EQ.24) THEN C---COLOUR-SINGLET EXCHANGE CALL HWHSNG ELSEIF (IPRO.EQ.25) THEN C---SM Higgs production with heavy quark flavours via qq and gg. CALL HWHIGQ ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN C---SM Higgs production with heavy gauge bosons via qq('). CALL HWHIGV C---Gauge boson pair in hadron hadron ELSEIF (IPRO.EQ.28) THEN IF (MOD(IPROC,10000).LT.2850) THEN CALL HWHGBP ELSE CALL HWHVVJ ENDIF C--Vector boson + two jets ELSEIF(IPRO.EQ.29) THEN CALL HWHV2J ELSEIF (IPRO.EQ.30) THEN C---HADRON-HADRON SUSY PROCESSES CALL HWHSSP ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN C---MSSM charged/neutral Higgs production in association with squarks. CALL HWHISQ ELSEIF (IPRO.EQ.33) THEN IF(MOD(IPROC,10000).EQ.3350)THEN C---MSSM charged Higgs production in association with W: W+H- + W-H+. CALL HWHIBK ELSEIF((MOD(IPROC,10000).EQ.3310).OR. & (MOD(IPROC,10000).EQ.3320).OR. & (MOD(IPROC,10000).EQ.3360).OR. & (MOD(IPROC,10000).EQ.3370))THEN C---MSSM Higgs production with heavy gauge bosons via qq('). CALL HWHIGV ELSE C---MSSM charged/neutral Higgs pair production. CALL HWHIGH END IF ELSEIF (IPRO.EQ.34) THEN C---MSSM charged/neutral Higgs production via bg fusion. CALL HWHIBG ELSEIF (IPRO.EQ.35) THEN C---MSSM charged Higgs production via bq fusion. CALL HWHIBQ ELSEIF (IPRO.EQ.38) THEN C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg. CALL HWHIGQ ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES CALL HWHRSP ELSEIF (IPRO.EQ.42) THEN C---SPIN-TWO RESONANCE CALL HWHGRV ELSEIF (IPRO.EQ.50) THEN C Point-like photon two-jet production CALL HWHPPT ELSEIF (IPRO.EQ.51) THEN C Point-like photon/QCD heavy flavour pair production CALL HWHPPH ELSEIF (IPRO.EQ.52) THEN C Point-like photon/QCD heavy flavour single excitation CALL HWHPPE ELSEIF (IPRO.EQ.53) THEN C Compton scattering of point-like photon and (anti)quark CALL HWHPQS ELSEIF (IPRO.EQ.55) THEN C Point-like photon/higher twist meson production CALL HWHPPM ELSEIF (IPRO.EQ.60) THEN C---QPM GAMMA-GAMMA-->QQBAR CALL HWHQPM ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES CALL HVHBVI ELSEIF (IPRO.EQ.80) THEN C---MINIMUM-BIAS: NO HARD SUBPROCESS C FIND WEIGHT CALL HWMWGT ELSEIF (IPRO.EQ.90) THEN C---DEEP INELASTIC CALL HWHDIS ELSEIF(IPRO.EQ.91) THEN C---BOSON - GLUON(QUARK) FUSION --> ANTIQUARK(GLUON) + QUARK CALL HWHBGF ELSEIF(IPRO.EQ.92) THEN C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS WRITE (6,40) 40 FORMAT (1X,' IPROC=92** is no longer supported.' & /1X,' Please use IPROC=91** instead.') CALL HWWARN('HWEPRO',500) ELSEIF(IPRO.EQ.95) THEN C---HIGGS PRODUCTION VIA W FUSION IN E P CALL HWHIGW ELSE C---UNKNOWN PROCESS CALL HWWARN('HWEPRO',102) GOTO 999 ENDIF 30 IF (GENEV) THEN IF (NOWGT) THEN IF (NEGWTS) THEN IF (EVWGT.LT.ZERO) THEN EVWGT=-AVABW ELSE EVWGT= AVABW ENDIF ELSE EVWGT=AVWGT ENDIF ENDIF ISTAT=10 C--New call spin correlation code if needed IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR. & IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR. & IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR. & IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN C--generate additional photon radition in top production IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT RETURN ELSE C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT IF (IERROR.NE.0) THEN EVWGT=ZERO IERROR=0 ENDIF EVWGT=EVWGT*GAMWT NWGTS=NWGTS+1 ABWGT=ABS(EVWGT) IF (EVWGT.LT.ZERO) THEN IF (NEGWTS) THEN NNEGWT=NNEGWT+1 ELSE IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3) EVWGT=ZERO ABWGT=ZERO ENDIF ENDIF WGTSUM=WGTSUM+EVWGT WSQSUM=WSQSUM+EVWGT**2 ABWSUM=ABWSUM+ABWGT C--weight addition for Les Houches accord IF(IPROC.LE.0) THEN IF(ABS(IDWTUP).EQ.1) THEN LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2 LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1 ENDIF ENDIF IF (ABWGT.GT.WBIGST) THEN WBIGST=ABWGT IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1) WGTMAX=WBIGST*1.1 WRITE (6,99) WGTMAX C--additional for Les Houche accord IF(IPROC.LE.0) THEN IF(ABS(IDWTUP).EQ.1) & LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT LHXMAX(ITYPLH) = EVWGT ENDIF ENDIF ENDIF IF (NEVHEP.NE.0) THEN C---LOW EFFICIENCY WARNINGS: C WARN AT 10*EFFMIN, STOP AT EFFMIN IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN IF (EFFMIN*NWGTS.GT.NEVHEP) CALL HWWARN('HWEPRO',200) IF (EFFMIN.GT.ZERO) THEN IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN CALL HWWARN('HWEPRO',2) WRITE (6,98) WGTMAX ENDIF ENDIF ENDIF IF (NOWGT) THEN GENEV=ABWGT.GT.WGTMAX*HWRGEN(0) ELSE GENEV=ABWGT.NE.ZERO ENDIF IF (GENEV) GOTO 20 GOTO 10 ENDIF ENDIF 98 FORMAT(10X,' MAXIMUM WEIGHT =',1PG24.16) 99 FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16) 999 RETURN END CDECK ID>, HWETWO. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWETWO(SMR3,SMR4) C----------------------------------------------------------------------- C SETS UP 2->2 HARD SUBPROCESS c BRW change 18/8/04: BW smearing of mass i only if SMRi is true C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUMBW,HWUPCM,PCM INTEGER ICMF,IBM,I,J,K,IHEP,NTRY LOGICAL SMR3,SMR4 EXTERNAL HWUPCM C---INCOMING LINES ICMF=NHEP+3 DO 15 I=1,2 IBM=I C---FIND BEAM AND TARGET IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I) IHEP=NHEP+I IDHW(IHEP)=IDN(I) IDHEP(IHEP)=IDPDG(IDN(I)) ISTHEP(IHEP)=110+I JMOHEP(1,IHEP)=ICMF JMOHEP(I,ICMF)=IHEP JDAHEP(1,IHEP)=ICMF C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP)) IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP) ELSE PHEP(1,IHEP)=0. PHEP(2,IHEP)=0. PHEP(5,IHEP)=RMASS(IDN(I)) C--BRW fix 5/11/08: define x as fraction of p_3 not p_+ PHEP(3,IHEP)=XX(I)*PHEP(3,IBM) PHEP(4,IHEP)=SQRT(PHEP(3,IHEP)**2+PHEP(5,IHEP)**2) C--End BRW fix 5/11/08 ENDIF 15 CONTINUE C---HARD CENTRE OF MASS IDHW(ICMF)=IDCMF IDHEP(ICMF)=IDPDG(IDCMF) ISTHEP(ICMF)=110 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) C---OUTGOING LINES NTRY=0 DO 16 I=3,4 IHEP=NHEP+I+1 IDHW(IHEP)=IDN(I) IDHEP(IHEP)=IDPDG(IDN(I)) ISTHEP(IHEP)=110+I JMOHEP(1,IHEP)=ICMF 16 JDAHEP(I-2,ICMF)=IHEP 19 CONTINUE IF (SMR3) THEN PHEP(5,NHEP+4)=HWUMBW(IDN(3)) ELSE PHEP(5,NHEP+4)=RMASS(IDN(3)) ENDIF IF (SMR4) THEN PHEP(5,NHEP+5)=HWUMBW(IDN(4)) ELSE PHEP(5,NHEP+5)=RMASS(IDN(4)) ENDIF PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5)) IF (PCM.LT.ZERO) THEN NTRY=NTRY+1 IF (NTRY.LE.NETRY) GO TO 19 CALL HWWARN('HWETWO',103) GOTO 999 ENDIF IHEP=NHEP+4 PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP)=PCM*COSTH PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5)) C---SET UP COLOUR STRUCTURE LABELS DO 30 I=1,4 J=I IF (J.GT.2) J=J+1 K=ICO(I) IF (K.GT.2) K=K+1 JMOHEP(2,NHEP+J)=NHEP+K 30 JDAHEP(2,NHEP+K)=NHEP+J NHEP=NHEP+5 999 RETURN END CDECK ID>, HWH2BK. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST) C----------------------------------------------------------------------- C...Matrix element for q(1) + q-bar(2) -> W+/-(3) + H-/+(4), C...all masses retained. C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2 C C...First release: 1-APR-1998 by Stefano Moretti C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3) DOUBLE PRECISION P(0:3) DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2, & MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST DOUBLE PRECISION TT,UU,KKT2,TL DOUBLE COMPLEX Z,PV,PA DOUBLE PRECISION RMB,RMT,RMW,RMH DOUBLE PRECISION RMH01,GAMH01, & RMH02,GAMH02, & RMH03,GAMH03 DOUBLE PRECISION VP,CFC EQUIVALENCE (RMB ,RMASS( 5)),(RMT ,RMASS( 6)) EQUIVALENCE (RMH01,RMASS(204)), & (RMH02,RMASS(203)), & (RMH03,RMASS(205)) PARAMETER (Z=(0D0,1D0),NC=3) C...Higgs widths. GAMH01=RMASS(204)/DKLTM(204) GAMH02=RMASS(203)/DKLTM(203) GAMH03=RMASS(205)/DKLTM(205) C...constant terms. MB2=RMB*RMB MT2=RMT*RMT MW2=RMW*RMW MHP2=RMH *RMH MH02=RMH01*RMH01 MA02=RMH03*RMH03 MSH2=RMH02*RMH02 MGAMH0=RMH01*GAMH01 MGAMA0=RMH03*GAMH03 MGAMSH=RMH02*GAMH02 C...Mandelstam invariants. S=(P1(0)+P2(0))**2 T=(P1(0)-P3(0))**2 U=(P1(0)-P4(0))**2 DO I=1,3 S=S-(P1(I)+P2(I))**2 T=T-(P1(I)-P3(I))**2 U=U-(P1(I)-P4(I))**2 END DO C...propagators and couplings. PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH) & -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB PA= TANB/(S-MA02+Z*MGAMA0) PT= 1./(T-MT2) KT2=(U*T-MHP2*MW2)/S C...Total ME. RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)* & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+ & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+ & PT**2*((MT2/TANB)**2*(2.*MW2+KT2) & +MB2*TANB**2*(2.*MW2*KT2+T**2))) & *2. C...Extracts spin dependence. VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2) CFC=P3(0)/VP DO I=1,3 P(I)=P3(I)*CFC END DO P(0)=VP**2/P3(0)*CFC TT=(P1(0)-P(0))**2 UU=(P2(0)-P(0))**2 DO I=1,3 TT=TT-(P1(I)-P(I))**2 UU=UU-(P2(I)-P(I))**2 END DO KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T) & +MW2*((MW2-T)*(MW2-U)-S*MW2))/S C...Longitudinal ME (along V direction). RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)* & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+ & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+ & PT**2*((MT2/TANB)**2*(KKT2) & +MB2*TANB**2*(TL))) & *2. C...Transverse ME (perpendicular to V direction). REST=RES-RESL END CDECK ID>, HWH2DD. *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2) C----------------------------------------------------------------------- C Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262 C N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS C SECTION ROUTINE C I-L are the particles (all outgoing) C Z1 and Z2 are the decay products of the Z C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ND,I,J,K,L,Z1,Z2 DOUBLE COMPLEX HWH2DD,ZI,S,D,F PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHZBB/F(8,8) IF(ND.EQ.1) THEN HWH2DD = ZI ELSEIF(ND.EQ.2) THEN HWH2DD = ZI/F(J,K)/SQRT(TWO*D(I,K)) ELSEIF(ND.EQ.3) THEN HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K)) ELSEIF(ND.EQ.4) THEN HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2)) ELSEIF(ND.EQ.5) THEN HWH2DD = ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2)) ELSEIF(ND.EQ.6) THEN HWH2DD = ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L) ELSEIF(ND.EQ.7) THEN HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L) ELSEIF(ND.EQ.8) THEN HWH2DD = ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L) ELSEIF(ND.EQ.9) THEN HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L)) ELSEIF(ND.EQ.10) THEN HWH2DD = ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L)) ENDIF END CDECK ID>, HWH2BH. *CMZ :- -30/06/01 18.21.35 by Stefano Moretti *-- Author : Kosuke Odagiri & Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWH2BH(P1,P2,P3,P4,P5, & EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM, & GAMT,M2) C----------------------------------------------------------------------- C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C., C...q(q') massless incoming(outgoing) quark, all other masses retained. C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW. C C...First release: 01-APR-1998 by Kosuke Odagiri C...First modified: 12-APR-1998 by Stefano Moretti C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER MU,IRES,IFL DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03 DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM DOUBLE PRECISION QW(0:3),QS(0:3) DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234 DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT23 DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H DOUBLE PRECISION PT2,PV2,PA2 DOUBLE PRECISION M2 DOUBLE COMPLEX PV,PA,PT,PW,Z PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0) PARAMETER (Z=(0.D0,1.D0)) DOUBLE PRECISION SC,RICCI EXTERNAL SC,RICCI C DO 670 MU=0,3 QW(MU)=P2(MU)-P4(MU) QS(MU)=P1(MU)-P3(MU) 670 CONTINUE C DOTHH=EMH*EMH DOTSS=SC(QS,QS) DOTWW=SC(QW,QW) DOT13=EMB*EMB-DOTSS/2.D0 DOT24=-DOTWW/2.D0 DOT2H=SC(P2,P5) DOT4H=SC(P4,P5) C IF(IFL.EQ.1)THEN DOT12=SC(P1,P2) DOT14=SC(P1,P4) DOT23=SC(P2,P3) DOT34=SC(P3,P4) DOT3H=SC(P3,P5) E1234=RICCI(P1,P2,P3,P4) ELSE IF(IFL.EQ.-1)THEN DOT12=-SC(P3,P2) DOT14=-SC(P3,P4) DOT23=-SC(P2,P1) DOT34=-SC(P1,P4) DOT3H=-SC(P1,P5) E1234=-RICCI(P1,P2,P3,P4) END IF C DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H C PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+ 1 SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02) PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03) PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP) C REMOVE TOP DIAGRAM. IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT) IF(IRES.EQ.0)PT=(0.D0,0.D0) PT=PT*CKM PT2 =DREAL(DCONJG(PT)*PT) PV2 =DREAL(DCONJG(PV)*PV) PA2 =DREAL(DCONJG(PA)*PA) C N0=ABS(PW) C M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13* & (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+ T 2.D0*PT2*DOT12* O (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+ P EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+ & EMB*EMB*TANB/COSB*DREAL(PV+PA)* X (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13- T (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+ M DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) ) END C DOUBLE PRECISION FUNCTION SC(A,B) IMPLICIT NONE DOUBLE PRECISION A(0:3),B(0:3) SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3) END C DOUBLE PRECISION FUNCTION RICCI(A,B,C,D) IMPLICIT NONE DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3) RICCI= & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)- & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+ & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)- & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+ & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)- & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+ & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)- & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1) END CDECK ID>, HWH2F1 *CMZ :- -27/02/01 17:04:16 by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2F1(NP,F,I,P,MQ) C----------------------------------------------------------------------- C Subroutine to implement the F function of Eijk and Kliess C fixed first momenta and all second momenta C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2) INTEGER I,J,NP EXTERNAL HWULDO COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) PARAMETER(EPS=1D-10) C--find the massless momentum we need PDOT = HWULDO(PCM(1,I),P) P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN PDOT = HALF ELSE PDOT = HALF*P(5)/PDOT ENDIF DO J=1,4 PM(J) = P(J)-PDOT*PCM(J,I) ENDDO IF(P(5).GT.ZERO) THEN P(5)=SQRT(P(5)) ELSE P(5)=ZERO ENDIF PM(5) = ZERO C--calculate its spinor product with the fixed momentum CALL HWH2SS(SIP,PCM(1,I),PM) C--calculate the F functions DO J=1,NP CALL HWH2SS(SJP,PM,PCM(1,J)) F(1,1,J) = SIP(1)*SJP(2) F(1,2,J) = MQ*S(I,J,1) F(2,1,J) = MQ*S(I,J,2) F(2,2,J) = SIP(2)*SJP(1) ENDDO END CDECK ID>, HWH2F2 *CMZ :- -27/02/01 17:04:16 by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2F2(NP,F,I,P,MQ) C----------------------------------------------------------------------- C Subroutine to implement the F function of Eijk and Kliess C fixed second momenta and all first momenta C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2) INTEGER I,J,NP EXTERNAL HWULDO COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) PARAMETER(EPS=1D-10) C--find the massless momentum we need PDOT = HWULDO(PCM(1,I),P) P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN PDOT = HALF ELSE PDOT = HALF*P(5)/PDOT ENDIF DO J=1,4 PM(J) = P(J)-PDOT*PCM(J,I) ENDDO IF(P(5).GT.ZERO) THEN P(5)=SQRT(P(5)) ELSE P(5)=ZERO ENDIF PM(5) = ZERO C--calculate its spinor product with the fixed momentum CALL HWH2SS(SIP,PM,PCM(1,I)) C--calculate the F functions DO J=1,NP CALL HWH2SS(SJP,PCM(1,J),PM) F(1,1,J) = SIP(2)*SJP(1) F(1,2,J) = MQ*S(J,I,1) F(2,1,J) = MQ*S(J,I,2) F(2,2,J) = SIP(1)*SJP(2) ENDDO END CDECK ID>, HWH2F3 *CMZ :- -27/02/01 17:04:16 by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2F3(NP,F,P,MQ) C----------------------------------------------------------------------- C Subroutine to implement the F function of Eijk and Kliess C All first and second momenta C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D INTEGER I,J,NP COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO PARAMETER(EPS=1D-10) C--find the massless momentum we need DO I=1,NP PDOT = HWULDO(PCM(1,I),P) P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN PDOT = HALF ELSE PDOT = HALF*P(5)/PDOT ENDIF DO J=1,4 PM(J) = P(J)-PDOT*PCM(J,I) ENDDO IF(P(5).GT.ZERO) THEN P(5)=SQRT(P(5)) ELSE P(5)=ZERO ENDIF PM(5) = ZERO C--calculate its spinor product with the fixed momentum CALL HWH2SS(SIP,PCM(1,I),PM) C--calculate the F functions DO J=I,NP CALL HWH2SS(SJP,PM,PCM(1,J)) F(1,1,I,J) = SIP(1)*SJP(2) F(1,2,I,J) = MQ*S(I,J,1) F(2,1,I,J) = MQ*S(I,J,2) F(2,2,I,J) = SIP(2)*SJP(1) ENDDO ENDDO DO I=1,NP DO J=I+1,NP F(1,1,J,I) = F(2,2,I,J) F(1,2,J,I) = -F(1,2,I,J) F(2,1,J,I) = -F(2,1,I,J) F(2,2,J,I) = F(1,1,I,J) ENDDO ENDDO END CDECK ID>, HWH2HE. *CMZ :- -13/10/02 09.43.05 by Peter Richardson *-- Author : Kosuke Odagiri and Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC, & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5, & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5, & RML,GAML,RMH,GAMH,RMA,GAMA, & RMZ,GAMZ,CFAC,RES) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR C e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5) C (SAME QUARK MASSES IN YUKAWA AND KINEMATICS) C----------------------------------------------------------------------- IMPLICIT NONE LOGICAL FIRST,GAUGE DOUBLE PRECISION HFC,HBC DOUBLE PRECISION CFAC DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2 DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1) DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3 DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF DOUBLE PRECISION BE,SA,CA,SB,CB INTEGER I,LE,L,IFL,IH DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6 DOUBLE COMPLEX PROP7(-1:1) DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0) SAVE XW,GE,G3,G4,G5,RM,PREFAC C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE IF(FIRST)THEN C SOME COMMON INITIALISATIONS DO I=-1,1 RM(I)=ZERO RN1(I)=ZERO RN2(I)=ZERO END DO RN3=ZERO XW=TWO*S2W GE( 0)=-ONE GE(+1)=-GE(0)*XW GE(-1)=-ONE+GE(1) IF(IH.LE.3)THEN G3( 0)=Q3 G3(+1)=-G3(0)*XW G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1) G4( 0)=G3( 0) G4(+1)=G3(+1) G4(-1)=G3(-1) G5( 0)=ZERO G5(+1)=ONE G5(-1)=ONE C HIGGS ANGLES BE=ATAN(TANB) SA=SIN(AL) CA=COS(AL) SB=SIN(BE) CB=COS(BE) C MSSM SCALING FACTORS FOR COUPLINGS IF(IH.LE.2)THEN RM(-1)=+YM3/RMW*HFC RM(+1)=+YM4/RMW*HFC ELSE IF(IH.EQ.3)THEN RM(-1)=+YM3/RMW*HFC RM(+1)=-YM4/RMW*HFC END IF IF(IH.LE.2)THEN IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB) & *(-SQRT(ABS(ONE-HBC**2))) IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB) & *(-SQRT(ABS(ONE-HBC**2))) IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB) & *(+SQRT(ABS(ONE-HBC**2))) IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB) & *(+SQRT(ABS(ONE-HBC**2))) RN2(-1)=ZERO RN2(+1)=ZERO IF(IH.EQ.0)RN3=1.D0 IF(IH.EQ.1)RN3=HBC IF(IH.EQ.2)RN3=HBC ELSE IF(IH.EQ.3)THEN RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB)) & *COS(BE-AL) RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB)) & *COS(BE-AL) RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB)) & *SIN(BE-AL) RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB)) & *SIN(BE-AL) RN3=ZERO END IF PREFAC=E**6/(XW*S)*CFAC/TWO ELSE G3( 0)=Q3 G3(+1)=-G3(0)*XW G3(-1)=-ONE+G3(1) G4( 0)=ONE+G3(0) G4(+1)=-G4(0)*XW G4(-1)=ONE+G4(1) G5( 0)=ONE G5(+1)=ONE-XW G5(-1)=ONE-XW RM(-1)=YM3*TANB/RMW RM(+1)=YM4/TANB/RMW RN1(-1)=RM(-1) RN1(+1)=RM(+1) RN2(-1)=ZERO RN2(+1)=ZERO RN3=ZERO PREFAC=E**6/(XW*S)*CFAC END IF FIRST=.FALSE. END IF C SOME ENERGY CONSTANTS SQS=DSQRT(S) TWOSQS=TWO*SQS HLFSQS=HLF*SQS PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ)) C SOME KINEMATICS P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3) M34=RM3*RM4 RES=ZERO C FF(')-BAR PROPAGATOR Q2=RM3**2+RM4**2+TWO*P34 C CONSTRUCT AMPLITUDE DO LE=-1,1,2 RLE=DFLOAT(LE) IF(IH.LE.2)THEN PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/ & DCMPLX(Q2-RMA**2,-RMA*GAMA) PROP6=(0.D0,0.D0) ELSE IF(IH.EQ.3)THEN PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/ & DCMPLX(Q2-RML**2,-RML*GAML) PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/ & DCMPLX(Q2-RMH**2,-RMH*GAMH) ELSE PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/ & DCMPLX(Q2-RM5**2,-RM5*GAM5) END IF ZP3=DCMPLX(P3(1),-RLE*P3(2)) ZP4=DCMPLX(P4(1),-RLE*P4(2)) ZP5=-ZP3-ZP4 DO L=-1,1,2 PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/ & DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3) PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/ & DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4) PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ) END DO DO L=-1,1,2 PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L)) MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L)) & +RM4*RM(-L)*(PROP4(L)-PROP4(-L)) & +TWO*RMZ**2/RMW*RN3*PROP7(L) IF(GAUGE)THEN ZP3=P3(0)-HLFSQS ZP4=P4(0)-HLFSQS ZP5=P5(0)-HLFSQS PP(L)=DCMPLX(ZERO,ZERO) MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS* & (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4) END IF QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4) & +RN1(L)*PROP5*ZP5 & -RN2(L)*PROP6*ZP5 & +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5 RLLE=DFLOAT(L*LE) EP3(L)=P3(0)+RLLE*P3(3) EP4(L)=P4(0)+RLLE*P4(3) END DO DO L=-1,1,2 RES=RES+DREAL( & EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+ & EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)- & TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)- & TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+ & M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L)) & +TWO*DCONJG(QQ(-L)) & *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4- & (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+ & P34*QQ(-L)-M34*QQ(+L))) END DO END DO RES=PREFAC*RES END CDECK ID>, HWH2M0. *CMZ :- -14/03/01 09:03:25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ) C----------------------------------------------------------------------- C Massless matrix elements for gg-->qqZ and qq-->qqZ C using the matrix elements given in Nucl. Phys. B262 (1985) 235-242 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC, & CGFC,CGIFC DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5, & HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD, & MGAMP(2,2,2,2,2),TRPGL(2) EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6, & HWH2T7,HWH2T8,HWH2T9 PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0, & CGIFC=-2.0D0/3.0D0) COMMON /HWHZBC/G SAVE OZ,ID DATA OZ/6,5,5,6/ DATA ID/1,2/ C--flavour of the final-state quark (1 is down-type and 2 is up-type) IQI = MOD(IQ,2) IF(IQI.EQ.0) IQI=2 C--calculate qqbar---> q'q'barZ DCF(1) = HWH2DD(4,2,1,3,4,5,6) DCF(2) = HWH2DD(5,2,1,3,4,5,6) DCF(3) = HWH2DD(4,3,4,2,1,5,6) DCF(4) = HWH2DD(5,3,4,2,1,5,6) DCF(5) = HWH2DD(4,3,1,2,4,5,6) DCF(6) = HWH2DD(5,3,1,2,4,5,6) DCF(7) = HWH2DD(4,2,4,3,1,5,6) DCF(8) = HWH2DD(5,2,4,3,1,5,6) DO I=1,3 DO J=1,3 FLOW(I,J) = ZERO ENDDO ENDDO DO I=1,2 C--calculate the matrix element, N.B. two possibe colour flows DO P1=1,2 DO P2=1,2 DO P3=1,2 MQAMP(1)= G(IDZ,P3)*( & G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2) & +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)) & +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1) & +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1))) IF(ID(I).NE.IQI) THEN MQAMP(2)=ZERO ELSE MQAMP(2)= G(IDZ,P3)*( & G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2) & +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)) & +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1) & +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1))) ENDIF FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1))) FLOW(I,2) = ZERO FLOW(I,3) = ZERO IF(IQI.EQ.ID(I)) THEN FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1))) FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2))) IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3) & -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2))) ENDIF ENDDO ENDDO ENDDO ENDDO DO I=1,3 FLOW(I,1) = CQFC*FLOW(I,1) FLOW(I,2) = CQFC*FLOW(I,2) FLOW(I,3) = CQIFC*FLOW(I,3) ENDDO C--now find the matrix elements DO I=1,5 K = MOD(I,2) IF(K.EQ.0) K=2 IF(I.EQ.IQ) K=3 DO J=1,2 IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)* & (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2))) ENDDO ENDDO C--calculate gg---> bbbarZ C--coefficients for the diagrams DCF(1) = HWH2DD( 6,3,4,1,2,5,6) DCF(2) = HWH2DD( 7,3,4,1,2,5,6) DCF(3) = HWH2DD( 8,3,4,1,2,5,6) DCF(4) = HWH2DD( 6,3,4,2,1,5,6) DCF(5) = HWH2DD( 7,3,4,2,1,5,6) DCF(6) = HWH2DD( 8,3,4,2,1,5,6) DCF(7) = HWH2DD( 9,3,4,1,2,5,6) DCF(8) = HWH2DD(10,3,4,1,2,5,6) C--helicity amplitudes DO P1=1,2 DO P2=1,2 DO P3=1,2 DO P4=1,2 TRPGL(1)= & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2) & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2) TRPGL(2)= & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1) & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1) MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*( & TRPGL(1) & +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2) & +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2) & +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2) & ) MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2) & +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2) & +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2) & +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)) ENDDO ENDDO ENDDO ENDDO C--square to obtain the matrix element DO I=1,3 FLOW(1,I) = ZERO ENDDO DO P1=1,2 DO P2=1,2 DO P3=1,2 DO P4=1,2 FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)* & DCONJG(MGAMP(1,P1,P2,P3,P4))) FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)* & DCONJG(MGAMP(2,P1,P2,P3,P4))) FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)* & DCONJG(MGAMP(2,P1,P2,P3,P4))) ENDDO ENDDO ENDDO ENDDO FLOW(1,1) = CGFC*FLOW(1,1) FLOW(1,2) = CGFC*FLOW(1,2) FLOW(1,3) = CGIFC*FLOW(1,3) DO I=1,2 MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2))) ENDDO END CDECK ID>, HWH2MQ. *CMZ :- -14/03/01 09:03:25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ) C----------------------------------------------------------------------- C Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC, & PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB, & Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L, & Q1LB,Q2LB,MQB(2,3),QBB DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2), & FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8), & F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2), & MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8) COMMON/HWHZBC/G COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0, & CGIFC=-2.0D0/3.0D0) EXTERNAL HWULDO SAVE DL,O DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/ DATA O /2,1/ C--mass of the final-state quark QM = RMASS(IQ) QM2 = RMASS(IQ)**2 C--first calculate the F functions we will need DO I=1,4 PTMP(I,1) = PCM(I,9)+PCM(I,5)+PCM(I,6) PTMP(I,2) = -PCM(I,10)-PCM(I,5)-PCM(I,6) PTMP(I,3) = PCM(I,9)-PCM(I,1) PTMP(I,4) = PCM(I,1)-PCM(I,10) PTMP(I,5) = PCM(I,9)-PCM(I,2) PTMP(I,6) = PCM(I,2)-PCM(I,10) PTMP(I,7) = PCM(I,9) PTMP(I,8) = -PCM(I,10) PTMP(I,9) = PCM(I,1)-PCM(I,5)-PCM(I,6) PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6) ENDDO CALL HWH2F3(8,FBLL , PTMP(1, 1),QM) CALL HWH2F3(8,FBBLL, PTMP(1, 2),QM) CALL HWH2F3(8,F1B , PTMP(1, 3),QM) CALL HWH2F3(8,F1BB , PTMP(1, 4),QM) CALL HWH2F3(8,F2B , PTMP(1, 5),QM) CALL HWH2F3(8,F2BB , PTMP(1, 6),QM) CALL HWH2F1(8,FBB ,3,PTMP(1, 7),QM) CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM) CALL HWH2F3(8,F1LL , PTMP(1, 9),QM) CALL HWH2F3(8,F2LL , PTMP(1,10),QM) C--calculate the momenta squared for the denominators QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10))) QBL = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2) QBBL = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2) Q1B = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2) Q1BB = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2) Q2B = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2) Q2BB = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2) Q1L = HWULDO(PTMP(1, 9),PTMP(1, 9)) Q2L = HWULDO(PTMP(1,10),PTMP(1,10)) Q1LB = ONE/(Q1L-QM2) Q2LB = ONE/(Q2L-QM2) Q1L = ONE/Q1L Q2L = ONE/Q2L C--first construct the massless momenta PBQB = HWULDO(PCM(1,3),PCM(1,9)) PBBQBB = HWULDO(PCM(1,4),PCM(1,10)) C--first gg --> q qbar Z C--calculate the denominators due gluon polaizations and massive quarks PG = 0.25D0/(PBQB*PBBQBB*DREAL(D(1,2)*D(1,2))) C--and the denominators DCF(1) = FOUR*QBL*Q2BB DCF(2) = FOUR*QBL*Q1BB DCF(3) = FOUR*Q1B*Q2BB DCF(4) = FOUR*Q2B*Q1BB DCF(5) = FOUR*Q1B*QBBL DCF(6) = FOUR*Q2B*QBBL DCF(7) = TWO*QBL/D(1,2) DCF(8) = TWO*QBBL/D(1,2) C--now calculate the matrix elements we need DO I=1,3 FLOW(1,I) = ZERO ENDDO DO P1=1,2 DO P2=1,2 DO PL=1,2 DO PB=1,2 DO PBB=1,2 C--first amplitude from notes MGAMP(1) = DCF(1)*( & ( G(IQ,O(PL))*FBB(PB, PL,6)*FBLL( PL ,P1,5,2) & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))* & (F2BB( P1 , P2 ,1,1)*FBBB( P2 ,PBB,2)+ & F2BB( P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1)) & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL,O(P1),5,1) & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))* & (F2BB(O(P1), P2 ,2,1)*FBBB( P2 ,PBB,2)+ & F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1))) C--second amplitude from notes (1st with gluons interchanged) MGAMP(2) = DCF(2)*( & ( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL , P2 ,5,1) & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL), P2 ,6,1))* & (F1BB( P2 , P1 ,2,2)*FBBB( P1 ,PBB,1)+ & F1BB( P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2)) & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL ,O(P2),5,2) & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))* & (F1BB(O(P2), P1 ,1,2)*FBBB( P1 ,PBB,1)+ & F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2))) C--third amplitude from notes MGAMP(1) = MGAMP(1)+DCF(3)*( & G(IQ,O(PL))*( FBB(PB, P1 ,2)*F1B( P1 , PL ,1,6) & +FBB(PB,O(P1),1)*F1B(O(P1), PL ,2,6))* & (F2BB(PL, P2 ,5,1)*FBBB( P2 ,PBB,2)+ & F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1)) & +G(IQ, PL )*( FBB(PB, P1 ,2)*F1B( P1 ,O(PL),1,5) & +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))* & (F2BB(O(PL), P2 ,6,1)*FBBB( P2 ,PBB,2)+ & F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1))) C--fourth amplitude from notes (3rd with gluons interchanged) MGAMP(2) = MGAMP(2)+DCF(4)*( & G(IQ,O(PL))*( FBB(PB, P2 ,1)*F2B( P2 , PL ,2,6) & +FBB(PB,O(P2),2)*F2B(O(P2), PL ,1,6))* & (F1BB( PL , P1 ,5,2)*FBBB( P1 ,PBB,1)+ & F1BB( PL ,O(P1),5,1)*FBBB(O(P1),PBB,2)) & +G(IQ, PL )*( FBB(PB, P2 ,1)*F2B( P2 ,O(PL),2,5) & +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))* & ( F1BB(O(PL), P1 ,6,2)*FBBB( P1 ,PBB,1) & +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2))) C--fifth amplitude from notes MGAMP(1) = MGAMP(1)+DCF(5)*( & ( G(IQ,O(PL))*FBBLL( P2 , PL ,2,6)*FBBB( PL ,PBB,5) & +G(IQ, PL )*FBBLL( P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))* & ( FBB(PB, P1 ,2)*F1B( P1 , P2 ,1,1) & +FBB(PB,O(P1),1)*F1B(O(P1), P2 ,2,1)) & +( G(IQ,O(PL))*FBBLL(O(P2), PL ,1,6)*FBBB( PL ,PBB,5) & +G(IQ, PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))* & ( FBB(PB, P1 ,2)*F1B( P1 ,O(P2),1,2) & +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2))) C--sixth amplitude from notes (5th with gluons interchanged) MGAMP(2) = MGAMP(2)+DCF(6)*( & ( G(IQ,O(PL))*FBBLL( P1 , PL ,1,6)*FBBB( PL ,PBB,5) & +G(IQ, PL )*FBBLL( P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))* & ( FBB(PB, P2 ,1)*F2B( P2 , P1 ,2,2) & +FBB(PB,O(P2),2)*F2B(O(P2), P1 ,1,2)) & +( G(IQ,O(PL))*FBBLL(O(P1), PL ,2,6)*FBBB( PL ,PBB,5) & +G(IQ, PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))* & ( FBB(PB, P2 ,1)*F2B( P2 ,O(P1),2,1) & +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1))) C--seventh amplitude from notes (first non-Abelian one) MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*( & G(IQ,O(PL))*FBB(PB, PL ,6)* & ( FBLL( PL ,1,5,1)*FBBB(1,PBB,1) & +FBLL( PL ,2,5,1)*FBBB(2,PBB,1) & -FBLL( PL ,1,5,2)*FBBB(1,PBB,2) & -FBLL( PL ,2,5,2)*FBBB(2,PBB,2)) & +G(IQ, PL )*FBB(PB,O(PL),5)* & ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1) & +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1) & -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2) & -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2))) C--eighth amplitude from notes (second non-Abelian one) C--bug fix 12/7/03 by PR (too many continuations for NAG) MGAMP(3) = MGAMP(3) & + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*( & G(IQ,O(PL))*FBBB( PL ,PBB,5)* & ( FBB(PB,1,1)*FBBLL(1,PL,1,6) & +FBB(PB,2,1)*FBBLL(2,PL,1,6) & -FBB(PB,1,2)*FBBLL(1,PL,2,6) & -FBB(PB,2,2)*FBBLL(2,PL,2,6)) & +G(IQ, PL )*FBBB(O(PL),PBB,6)* & ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5) & +FBB(PB,2,1)*FBBLL(2,O(PL),1,5) & -FBB(PB,1,2)*FBBLL(1,O(PL),2,5) & -FBB(PB,2,2)*FBBLL(2,O(PL),2,5))) MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3)) MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3)) C--now square them FLOW(1,1) = FLOW(1,1)+DREAL(MGAMP(1)*DCONJG(MGAMP(1))) FLOW(1,2) = FLOW(1,2)+DREAL(MGAMP(2)*DCONJG(MGAMP(2))) FLOW(1,3) = FLOW(1,3)+TWO*DREAL(MGAMP(1)*DCONJG(MGAMP(2))) ENDDO ENDDO ENDDO ENDDO ENDDO C--add up the diagrams to obtain the amplitudes for the two colour flows FLOW(1,1) = CGFC*FLOW(1,1) FLOW(1,2) = CGFC*FLOW(1,2) FLOW(1,3) = CGIFC*FLOW(1,3) DO I=1,2 IF(FLOW(1,3).NE.ZERO) THEN MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2))) ELSE MG(I) = PG*FLOW(1,I) ENDIF ENDDO C--now q qbar --> q qbar Z C--calculate the denominators DCF(1) = -TWO*QBL/D(1,2) DCF(2) = -TWO*QBBL/D(1,2) DCF(3) = -TWO*Q1L*QBB DCF(4) = +TWO*Q2L*QBB DCF(5) = TWO*Q1LB*Q2BB DCF(6) = -TWO*Q2LB*Q1B DCF(7) = TWO*QBL*Q2BB DCF(8) = -TWO*QBBL*Q1B PQ = ONE/PBQB/PBBQBB DO P1=1,2 DO PL=1,2 DO PB=1,2 DO PBB=1,2 C--first the amplitudes for q qbar --> q' q'bar Z C--the first two amplitudes have Z off the final state and therefore C--the flavour of the incoming quarks doesn't matter C--first amplitude from notes MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*( & DCF(1)*(G(IQ,O(PL))*FBB(O(PB), PL ,6)* & ( FBLL( PL , P1 ,5,1)*FBBB( P1 ,O(PBB),2) & +FBLL( PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1)) & +G(IQ, PL )*FBB(O(PB),O(PL),5)* & ( FBLL(O(PL), P1 ,6,1)*FBBB( P1 ,O(PBB),2) & +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1))) C--second amplitide from notes & +DCF(2)*(G(IQ,O(PL))*FBBB( PL ,O(PBB),5)* & ( FBB(O(PB), P1 ,1)*FBBLL( P1 , PL ,2,6) & +FBB(O(PB),O(P1),2)*FBBLL(O(P1), PL ,1,6)) & +G(IQ, PL )*FBBB(O(PL),O(PBB),6)* & ( FBB(O(PB), P1 ,1)*FBBLL( P1 ,O(PL),2,5) & +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5)))) C--third amplitide from notes DO I=1,2 MQAMP(I,P1,PL,PB,PBB) = & DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1, PL )*( & S(1,6,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1)) & -S(5,6,O(PL))*( FBB(O(PB), P1 ,5)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5))) & +G(I, PL )*DL(P1, PL )*S(6,1,O(PL))*( & S(1,5, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1)) & -S(6,5, PL )*( FBB(O(PB), P1 ,6)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6)))) C--fourth amplitude from notes MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB) & +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6, P1 )*( & S(5,2, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1)) & -S(5,6, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),6) & +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1))) & +G(I, PL )*DL(P1, PL )*S(2,5, P1 )*( & S(6,2,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2) & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1)) & -S(6,5,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),5) & +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1)))) MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB) ENDDO C--now the extra amplitudes for q qbar --> q qbar Z DO P2=1,2 C--first amplitude for notes MQQAMP(P1,P2,PL,PB,PBB) = & DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*( & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1, PL )* & ( FBB(O(PB), PBB,8)*F1LL( P2 , PL ,2,6) & +FBB(O(PB),O(P2),2)*F1LL(O(PBB), PL ,8,6)) & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))* & ( FBB(O(PB), PBB ,8)*F1LL( P2 ,O(PL),2,5) & +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5))) & -QM*DL(P2,O(PBB))*( & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)* & ( FBB(O(PB),O(PBB),8)*F1LL( P2 , PL ,2,6) & +FBB(O(PB),O(P2) ,2)*F1LL( PBB , PL ,8,6)) & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))* & ( FBB(O(PB),O(PBB),8)*F1LL( P2 ,O(PL),2,5) & +FBB(O(PB), O(P2),2)*F1LL( PBB ,O(PL),8,5)))) C--second amplitude from notes MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB) & +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*( & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )* & ( F2LL( PL , P1 ,5,1)*FBBB( PB ,O(PBB),7) & +F2LL( PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1)) & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )* & ( F2LL(O(PL), P1 ,6,1)*FBBB( PB ,O(PBB),7) & +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1))) & -QM*DL(P1,O(PB))*( & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )* & ( F2LL( PL , P1 ,5,1)*FBBB(O(PB),O(PBB),7) & +F2LL( PL , PB ,5,7)*FBBB(O(P1),O(PBB),1)) & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )* & ( F2LL(O(PL), P1 ,6,1)*FBBB(O(PB),O(PBB),7) & +F2LL(O(PL), PB ,6,7)*FBBB(O(P1),O(PBB),1)))) C--third amplitude from notes MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB) & +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*( & G(IQ,O(PL))*FBB(O(PB), PL ,6)* & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL , PBB ,5,8) & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL( PL ,O(P2),5,2)) & +G(IQ, PL )*FBB(O(PB),O(PL),5)* & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL(O(PL), PBB ,6,8) & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2))) & -QM*DL(P2,O(PBB))*( & G(IQ,O(PL))*FBB(O(PB),PL,6)* & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL ,O(PBB),5,8) & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL( PL ,O(P2) ,5,2)) & +G(IQ, PL )*FBB(O(PB),O(PB),5)* & ( DL(P2,O(PL) )*S(2,1, P2 )*FBLL(O(PL),O(PBB),6,8) & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL(O(PL),O(P2) ,6,2)))) C--fourth amplitude from notes MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB) & +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*( & DL(P1,O(P2))*S(2,1,P2)* & ( G(IQ,O(PL))*FBBLL(PB, PL ,7,6)*FBBB( PL ,O(PBB),5) & +G(IQ, PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6)) & +DL(P2,PB)*S(2,7,P2)* & (G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5) & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))) & +QM*DL(P1,O(PB))*( & DL(P2,O(P1))*S(2,1,P2)* & ( G(IQ,O(PL))*FBBLL(O(PB), PL ,3,6)*FBBB( PL ,O(PBB),5) & +G(IQ, PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6)) & +DL(P2,O(PB))*S(2,3,P2)* & ( G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5) & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))) MQQAMP(P1,P2,PL,PB,PBB) = G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB) ENDDO ENDDO ENDDO ENDDO ENDDO C--now obtain the matrix elements squared for the quarks DO I=1,3 DO J=1,3 FLOW(I,J) = ZERO ENDDO ENDDO IF(MOD(IQ,2).EQ.1) THEN IQI = 1 ELSE IQI = 2 ENDIF DO P1=1,2 DO PL=1,2 DO PB=1,2 DO PBB=1,2 C--different quarks in inital and final states DO I=1,2 MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB) FLOW(I,1) = FLOW(I,1)+DREAL(DCONJG(MQP(I))*MQP(I)) ENDDO C--same quark in inital and final state DO P2=1,2 FLOW(3,2) = FLOW(3,2)+DREAL( & DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB)) IF(P1.EQ.P2) THEN FLOW(3,1) = FLOW(3,1)+DREAL(DCONJG(MQP(IQI))*MQP(IQI)) FLOW(3,3) = FLOW(3,3)-TWO* & DREAL(DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB)) ENDIF ENDDO ENDDO ENDDO ENDDO ENDDO C--split up the non-planar pieces according to Kosuke's prescription DO I=1,3 FLOW(I,1) = CQFC*FLOW(I,1) FLOW(I,2) = CQFC*FLOW(I,2) FLOW(I,3) = CQIFC*FLOW(I,3) DO J=1,2 IF(FLOW(I,J).NE.ZERO) THEN MQB(J,I) = PQ*FLOW(I,J)* & (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2))) ELSE MQB(J,I) = ZERO ENDIF ENDDO ENDDO C--now set them DO I=1,5 IF(I.EQ.IQ) THEN DO J=1,2 MQ(J,I) = MQB(J,3) ENDDO ELSEIF(MOD(I,2).EQ.1) THEN DO J=1,2 MQ(J,I) = MQB(J,1) ENDDO ELSE DO J=1,2 MQ(J,I) = MQB(J,2) ENDDO ENDIF ENDDO END CDECK ID>, HWH2PS. *CMZ :- -14/03/01 09:03:25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2) C----------------------------------------------------------------------- C Phase Space for vector boson plus 2 jets C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND, & HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT, & STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C, & PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3), & MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU, & FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH) COMMON /HWPSOM/ WI INTEGER I,ICH,J COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) LOGICAL GEN EXTERNAL HWRGEN,HWRUNI,HWUPCM PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0) IF(IERROR.NE.0) RETURN TWOPI2 = FOUR*PIFAC**2 WEIGHT = ZERO IF(OPTM) THEN DO I=1,IMAXCH WI(I) = ZERO ENDDO ENDIF GEN = .FALSE. C--centre of mass energy ETOT = PHEP(5,3) STOT = ETOT**2 C--first select the channel to be used RAND=HWRGEN(0) DO ICH=1,IMAXCH IF(CHON(ICH)) THEN IF(CHNPRB(ICH).GT.RAND) GOTO 10 RAND = RAND-CHNPRB(ICH) ENDIF ENDDO 10 CONTINUE C--generate the phase space according to the channel selected C--FIRST CHANNEL IF(ICH.EQ.1) THEN C--first generate the mass of 35 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2) M35 = SQRT(M35S) PS35 = HWUPCM(M35,MQ(1),MQ(3)) MJAC = HALF*MJAC*PS35/M35/TWOPI2 C--the generate the PT of 4 CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2) MT (2) = SQRT(MT2(2)) PT2(2) = MT2(2)-MQ2(2) PT(2) = SQRT(PT2(2)) MT35 = SQRT(M35S+PT2(2)) C--generate the rapidities of 4 and 35 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35)) IF(YMAX.LT.YMIN) RETURN Y35 = HWRUNI(1,YMIN,YMAX) EY35 = EXP(Y35) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2))) IF(YMAX.LT.YMIN) RETURN Y(2) = HWRUNI(2,YMIN,YMAX) YJAC = (YMAX-YMIN)*YJAC EY(2) = EXP(Y(2)) C--generate the incoming quark momentum fractions XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT STOT = XX(1)*XX(2)*STOT C--azimuthal angle of 4 and 35 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC) C--construct the momenta of 4 and 35 PLAB(1,4) = PT(2)*SIN(PHI(1)) PLAB(2,4) = PT(2)*COS(PHI(1)) PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2)) PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2)) PLAB(5,4) = MQ(2) PLAB(1,6) =-PT(2)*SIN(PHI(1)) PLAB(2,6) =-PT(2)*COS(PHI(1)) PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35) PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35) PLAB(5,6) = M35 C--perform the decay 35 --> 3+5 PLAB(5,3) = MQ(1) PLAB(5,5) = MQ(3) CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.) C--phase space weight FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2 C--SECOND CHANNEL ELSEIF(ICH.EQ.2) THEN C--first generate the pt's and azimuthal angles of 3 and 4 DO I=1,2 CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2) PT2(I) = MT2(I)-MQ2(I) MT(I) = SQRT(MT2(I)) PT(I) = SQRT(PT2(I)) PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC) ENDDO C--find the pt and azimuth of 5 by conservation of transverse momentum A = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2)) C = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2)) PT(3) = A**2+C**2 MT(3) = SQRT(PT(3)+MQ2(3)) PT(3) = SQRT(PT(3)) PHI(3) = -ACOS(-C/PT(3)) IF(A.LT.ZERO) PHI(3)=-PHI(3) C--generate the rapidities of 3,4 and 5 XX(1) = ZERO XX(2) = ZERO YJAC = ONE DO I=1,3 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I))) IF(YMAX.LT.YMIN) RETURN Y(I) = HWRUNI(I+2,YMIN,YMAX) EY(I) = EXP(Y(I)) XX(1) = XX(1)+MT(I)*EY(I) XX(2) = XX(2)+MT(I)/EY(I) YJAC = YJAC*(YMAX-YMIN) ENDDO C--generate the incoming quark momentum fractions XX(1) = XX(1)/PHEP(5,3) XX(2) = XX(2)/PHEP(5,3) IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN C--Construct the 4-momenta of the outgoing particles DO I=1,3 PLAB(1,I+2) = PT(I)*SIN(PHI(I)) PLAB(2,I+2) = PT(I)*COS(PHI(I)) PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I)) PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I)) PLAB(5,I+2) = MQ(I) ENDDO C--phase space weight STOT = XX(1)*XX(2)*STOT FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2 C--THIRD CHANNEL ELSEIF(ICH.EQ.3) THEN C--first generate the mass of 45 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2) M45 = SQRT(M45S) PS45 = HWUPCM(M45,MQ(2),MQ(3)) MJAC = HALF*MJAC*PS45/M45/TWOPI2 C--the generate the PT of 4 CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2) MT (1) = SQRT(MT2(1)) PT2(1) = MT2(1)-MQ2(1) PT(1) = SQRT(PT2(1)) MT45 = SQRT(M45S+PT2(1)) C--generate the rapidities of 3 and 45 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45)) IF(YMAX.LT.YMIN) RETURN Y45 = HWRUNI(1,YMIN,YMAX) EY45 = EXP(Y45) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1))) IF(YMAX.LT.YMIN) RETURN Y(1) = HWRUNI(2,YMIN,YMAX) YJAC = (YMAX-YMIN)*YJAC EY(1) = EXP(Y(1)) C--generate the incoming quark momentum fractions XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT STOT = XX(1)*XX(2)*STOT C--azimuthal angle of 3 and 45 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC) C--construct the momenta of 3 and 45 PLAB(1,3) = PT(1)*SIN(PHI(1)) PLAB(2,3) = PT(1)*COS(PHI(1)) PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1)) PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1)) PLAB(5,3) = MQ(1) PLAB(1,6) =-PT(1)*SIN(PHI(1)) PLAB(2,6) =-PT(1)*COS(PHI(1)) PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45) PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45) PLAB(5,6) = M45 C--perform the decay 45 --> 4+5 PLAB(5,4) = MQ(2) PLAB(5,5) = MQ(3) CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.) C--phase space weight FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2 C--FOURTH CHANNEL ELSEIF(ICH.EQ.4) THEN C--generate shat according to a power law CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2, & (MQ(1)+MQ(2)+MQ(3))**2) ETOT = SQRT(STOT) C--generate x1 TAU = STOT/PHEP(5,3)**2 XJAC = -LOG(TAU) XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO)) XX(2) = TAU/XX(1) C--generate m35 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2, & (MQ(1)+MQ(3))**2) M35 = SQRT(M35S) PS35 = HWUPCM(M35,MQ(1),MQ(3)) MJAC = HALF*MJAC*PS35/M35/TWOPI2 C--generate the momenta of 4 and 35 PST = HWUPCM(ETOT,M35,MQ(2)) PLAB(1,7) = ZERO PLAB(2,7) = ZERO PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3) PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3) PLAB(5,7) = ETOT PLAB(5,3) = MQ(1) PLAB(5,6) = M35 PLAB(5,4) = MQ(2) CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.) C--perform the decay 35 --> 3+5 PLAB(5,4) = MQ(2) PLAB(5,5) = MQ(3) CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.) C--phase space weight FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC C--FIFTH CHANNEL ELSEIF(ICH.EQ.5) THEN C--generate shat according to a power law CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2, & (MQ(1)+MQ(2)+MQ(3))**2) ETOT = SQRT(STOT) C--generate x1 TAU = STOT/PHEP(5,3)**2 XJAC = -LOG(TAU) XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO)) XX(2) = TAU/XX(1) C--generate m45 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2) M45 = SQRT(M45S) PS45 = HWUPCM(M45,MQ(2),MQ(3)) MJAC = HALF*MJAC*PS45/M45/TWOPI2 C--generate the momenta of 4 and 35 PST = HWUPCM(ETOT,M45,MQ(1)) PLAB(1,7) = ZERO PLAB(2,7) = ZERO PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3) PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3) PLAB(5,7) = ETOT PLAB(5,3) = MQ(1) PLAB(5,6) = M45 CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.) C--perform the decay 45 --> 4+5 PLAB(5,4) = MQ(2) PLAB(5,5) = MQ(3) CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.) C--phase space weight FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC C--SIXTH CHANNEL ELSEIF(ICH.EQ.6) THEN C--first generate the mass of 34 CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2) M34 = SQRT(M34S) PS34 = HWUPCM(M34,MQ(1),MQ(2)) MJAC = HALF*MJAC*PS34/M34/TWOPI2 C--the generate the PT of 5 CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3)) MT (3) = SQRT(MT2(3)) PT2(3) = MT2(3)-MQ2(3) PT(3) = SQRT(PT2(3)) MT34 = SQRT(M34S+PT2(3)) C--generate the rapidities of 5 and 34 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34)) IF(YMAX.LT.YMIN) RETURN Y34 = HWRUNI(1,YMIN,YMAX) EY34 = EXP(Y34) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3))) IF(YMAX.LT.YMIN) RETURN Y(3) = HWRUNI(2,YMIN,YMAX) YJAC = (YMAX-YMIN)*YJAC EY(3) = EXP(Y(3)) C--generate the incoming quark momentum fractions XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT STOT = XX(1)*XX(2)*STOT C--azimuthal angle of 3 and 45 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC) C--construct the momenta of 5 and 34 PLAB(1,5) = PT(3)*SIN(PHI(1)) PLAB(2,5) = PT(3)*COS(PHI(1)) PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3)) PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3)) PLAB(5,5) = MQ(3) PLAB(1,6) =-PT(3)*SIN(PHI(1)) PLAB(2,6) =-PT(3)*COS(PHI(1)) PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34) PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34) PLAB(5,6) = M34 C--perform the decay 34 --> 3+4 PLAB(5,3) = MQ(1) PLAB(5,4) = MQ(2) CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.) C--phase space weight FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2 ELSE CALL HWWARN('HWH2PS',500) ENDIF C--calculate the variables we need for the smoothing functions C--pt,mt and y for outgoing particles DO I=1,3 J=I+2 PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2 PT(I) = SQRT(PT2(I)) MT2(I) = MQ2(I)+PT2(I) MT(I) = SQRT(MT2(I)) Y(I) = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J))) EY(I) = EXP(Y(I)) IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN ENDDO IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN C--masses of composite particles M34S = (PLAB(4,3)+PLAB(4,4))**2 M45S = (PLAB(4,4)+PLAB(4,5))**2 M35S = (PLAB(4,3)+PLAB(4,5))**2 DO I=1,3 M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2 M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2 M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2 ENDDO M34 = SQRT(M34S) M45 = SQRT(M45S) M35 = SQRT(M35S) IF(M34.LT.MJJMIN) RETURN C--tramsverse masses of the composite particles MT34 = ZERO MT35 = ZERO MT45 = ZERO DO I=1,2 MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2 MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2 MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2 ENDDO MT34 = SQRT(M34S+MT34) MT35 = SQRT(M35S+MT35) MT45 = SQRT(M45S+MT45) C--final the momenta PS34 = HWUPCM(M34,MQ(1),MQ(2)) PS35 = HWUPCM(M35,MQ(1),MQ(3)) PS45 = HWUPCM(M45,MQ(2),MQ(3)) C--the rapidities of the composite particles ETMP = PLAB(4,3)+PLAB(4,4) PZTMP = PLAB(3,3)+PLAB(3,4) Y34 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP)) EY34 = EXP(Y34) ETMP = PLAB(4,3)+PLAB(4,5) PZTMP = PLAB(3,3)+PLAB(3,5) Y35 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP)) EY35 = EXP(Y35) ETMP = PLAB(4,4)+PLAB(4,5) PZTMP = PLAB(3,4)+PLAB(3,5) Y45 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP)) EY45 = EXP(Y45) C--find the pdf's and set the scale ETOT = SQRT(STOT) EMSCA = ETOT CALL HWSGEN(.FALSE.) C--construct the incoming momenta DO I=1,2 PLAB(1,I) = ZERO PLAB(2,I) = ZERO PLAB(3,I) = HALF*XX(I)*PHEP(5,3) PLAB(4,I) = HALF*XX(I)*PHEP(5,3) PLAB(5,I) = ZERO ENDDO PLAB(3,2) = -PLAB(3,2) TAU = XX(1)*XX(2) C--find the smoothing functions for the different channels C--function for first channel IF(CHON(1)) THEN CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2, & (MQ(1)+MQ(3))**2) MJAC = MJAC/PS35*M35 CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2) YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35)) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2))) YJAC = (YMAX-YMIN)*YJAC G(1) = 2.0D0*MJAC*PTJ(1)/YJAC ENDIF C--function for second channel IF(CHON(2)) THEN DO I=1,2 CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2) ENDDO XT1 = ZERO XT2 = ZERO YJAC = ONE DO I=1,3 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I))) XT1 = XT1+MT(I)*EY(I) XT2 = XT2+MT(I)/EY(I) YJAC = YJAC*(YMAX-YMIN) ENDDO G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC ENDIF C--function for third channel IF(CHON(3)) THEN CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2, & (MQ(2)+MQ(3))**2) MJAC = MJAC/PS45*M45 CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2) YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45)) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1))) YJAC = (YMAX-YMIN)*YJAC G(3) = 2.0D0*MJAC*PTJ(1)/YJAC ENDIF C--function for fourth channel IF(CHON(4)) THEN CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2, & (MQ(1)+MQ(2)+MQ(3))**2) XJAC = -LOG(TAU) CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2) M35 = SQRT(M35S) MJAC = MJAC/PS35*M35 PST = HWUPCM(ETOT,M35,MQ(2)) G(4) = SJAC*MJAC/XJAC*ETOT/PST ENDIF C--function for fifth channel IF(CHON(5)) THEN CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2, & (MQ(1)+MQ(2)+MQ(3))**2) XJAC = -LOG(TAU) CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2) MJAC = MJAC/PS45*M45 PST = HWUPCM(ETOT,M45,MQ(1)) G(5) = SJAC/XJAC*MJAC/PST*ETOT ENDIF C--function for sixth chaneel IF(CHON(6)) THEN CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2) MJAC = MJAC/PS34*M34 CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3)) YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34)) YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34)) YJAC = (YMAX-YMIN) YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3))) YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3))) YJAC = (YMAX-YMIN)*YJAC G(6) = 2.0D0*MJAC/YJAC*PTJ(1) ENDIF C--add them all up DEM = ZERO DO I=1,IMAXCH IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I) ENDDO C--now the weight WEIGHT = FLUX*GEV2NB*G(ICH)/DEM GEN = .TRUE. C--compute the weights for the different channels if optimizing IF(OPTM) THEN DO I=1,IMAXCH IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM ENDDO ENDIF END CDECK ID>, HWH2P1. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN) C----------------------------------------------------------------------- C Subroutine to select virtual quark mass for HWH2PS C IOPT=1 return the function at M2 C IOPT=2 calculate M2 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOPT DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX EXTERNAL HWRGEN C--smooth a powerlaw IF(EMPOW.EQ.TWO) THEN A01 = LOG(MMN-MQ2) A1 = LOG(MMX-MQ2)-A01 IF(IOPT.EQ.1) THEN FJAC = ONE/(M2-MQ2)/A1 ELSE M2 = EXP(A01+A1*HWRGEN(2)) FJAC = A1*M2 M2 = M2+MQ2 ENDIF ELSE MPOW = -EMPOW/TWO QPOW = ONE+MPOW RPOW = ONE/QPOW A01 = (MMN-MQ2)**QPOW A1 = (MMX-MQ2)**QPOW-A01 IF(IOPT.EQ.1) THEN FJAC = QPOW*(M2-MQ2)**MPOW/A1 ELSE M2 = (A01+A1*HWRGEN(2))**RPOW FJAC = A1*RPOW/M2**MPOW M2 = M2+MQ2 ENDIF ENDIF END CDECK ID>, HWH2P2. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2) C----------------------------------------------------------------------- C Subroutine to select virtual quark mass for HWH2PS C IOPT=1 return the function at M2 C IOPT=2 calculate M2 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOPT DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2, & PPOW,PTMN2,PTMX2,Z EXTERNAL HWRGEN C--smooth a powerlaw PPOW = HALF*PTPOW IF(PPOW.EQ.ONE) THEN A01 = LOG(PTMN2) A1 = LOG(PTMX2)-A01 IF(IOPT.EQ.1) THEN FJAC = ONE/PT2/A1 ELSE PT2 = EXP(A01+A1*HWRGEN(2)) FJAC = A1*PT2 ENDIF ELSE MPOW = -PPOW QPOW = ONE+MPOW RPOW = ONE/QPOW A01 = PTMN2**QPOW A1 = PTMX2**QPOW-A01 IF(IOPT.EQ.1) THEN FJAC = QPOW*PT2**MPOW/A1 ELSE Z = A01+A1*HWRGEN(2) PT2 = Z**RPOW FJAC = A1*RPOW/Z*PT2 ENDIF ENDIF END CDECK ID>, HWH2QH. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3, & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS C----------------------------------------------------------------------- C NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE: C FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB C FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB C MGM3 = (TOP MASS)*(TOP WIDTH) C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1) C PREFACTORS: C GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC) C QQQQHTOT = (G_S**4)*(QQQQH )*(1.-1./CAFAC**2)/4. C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ... C----------------------------------------------------------------------- IMPLICIT NONE C --- SUBPROCESS INTEGER IGG,IQQ C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3) DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS C --- SPINORS DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2) DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2) C --- MOMENTUM PROJECTION OPERATORS DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4) DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4) C --- SPINOR INDICES AND PERMUTATION MATRICES INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4) C --- CHIRALITY PROJECTION OPERATORS: 1 = - , 2 = + DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2) C --- GG AMPLITUDES DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2) DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2) DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2) DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2 DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH C --- QQ AMPLITUDES DOUBLE PRECISION RM3452 DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34, & PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452 DOUBLE COMPLEX PROP3,PROP4,PROP C --- CONSTANTS DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC DOUBLE COMPLEX CZERO,CONE INTEGER LEFT,RIGHT C --- PARAMETER DEFINITIONS PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2) PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0)) SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0 DATA MGM4,U0,FAC0 /ZERO, 4*CONE , ONE,ZERO, ZERO, ONE / DATA PERM0 ,PERMU0 / 1,2, 3,4 , 1,0, 0,4 / DATA PL ,PR / 0,3, 0,1, 4,0, 2,0, 4,0, 2,0, 0,3, 0,1 / DATA FACL ,FACR /MONE, ONE, ONE,MONE, ONE,MONE, MONE, ONE / C --- INITIALIZE GGQQHT=ZERO GGQQHU=ZERO GGQQHNP=ZERO QQQQH=ZERO C --- GG ME. IF(IGG.EQ.0)GOTO 100 TWOSQS = 0.5D0/SQS DO I = 0, 3 Q3(I) = P3(I)-P1(I) Q4(I) = P4(I)-P2(I) R3(I) = P3(I)-P2(I) R4(I) = P4(I)-P1(I) K3(I) = P3(I)+P5(I) K4(I) = P4(I)+P5(I) END DO CALL HWUMPO(P3, RM3, (P3(0)-P3(3)) ,ZERO,P3PROJ, .FALSE.) CALL HWUMPO(P4,-RM4, (P4(0)+P4(3)) ,ZERO,P4PROJ, .FALSE.) CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3)) ,ZERO,Q3PROJ, .FALSE.) CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3)) ,ZERO,Q4PROJ, .FALSE.) CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3)) ,ZERO,R3PROJ, .FALSE.) CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3)) ,ZERO,R4PROJ, .FALSE.) CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.) CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.) DO I=1,2 CALL HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0 ,F3(1,I) , LEFT) CALL HWUMPP(K3PROJ,FACGPM ,PERM0 ,F3(1,I),F3K(1,I) , LEFT) CALL HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0 ,F4(1,I) , RIGHT) CALL HWUMPP(K4PROJ,FACGPM ,PERM0 ,F4(1,I),F4K(1,I) , RIGHT) DO J=1,2 CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT) CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT) CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT) CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT) END DO END DO DO I=1,2 DO J=1,2 AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J) & + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS AMPS2(I,J)=( - F3(1,I)*F4K(3,J) + F3(2,I)*F4K(4,J) & + F3(3,I)*F4K(1,J) - F3(4,I)*F4K(2,J) ) * TWOSQS DO K=1,2 AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K) AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K) AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J) AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J) AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K) AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K) AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J) AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J) DO L=1,2 AMPT2(K,L,I,J) & = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) ) & + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) ) AMPU2(L,K,I,J) & = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) ) & + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) ) END DO END DO END DO END DO AMPST2 = ZERO AMPSU2 = ZERO AMPTU2 = ZERO DO I = 1, 2 DO J = 1, 2 DO K = 1, 2 DO L = 1, 2 IF (I.NE.J) THEN AMPS = AMPS1(K,L) - AMPS2(K,L) ELSE AMPS = CZERO END IF AMPT = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L) AMPU = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L) AMPST = AMPS - AMPT AMPSU = AMPS + AMPU AMPTU = AMPT + AMPU AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST) AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU) AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU) END DO END DO END DO END DO FAC = (P3(0)-P3(3))*(P4(0)+P4(3)) GGQQHT = FAC*AMPST2 GGQQHU = FAC*AMPSU2 GGQQHNP = FAC*AMPTU2 100 CONTINUE C --- QQ ME. IF(IQQ.EQ.0)GOTO 200 S = SQS**2 PT32 = P3(1)**2+P3(2)**2 PT42 = P4(1)**2+P4(2)**2 PT52 = P5(1)**2+P5(2)**2 PT3452 = (PT32+PT42-PT52)/TWO RM3452 = (RM3**2+RM4**2-RM5**2)/TWO GLAMBDA = FACGPM(1)**2+FACGPM(2)**2 LAMBDA = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA LA34 = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4 PROP3 = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO) PROP4 = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3) PROP = PROP3+PROP4 PROP2 = DREAL(DCONJG(PROP)*PROP) PROP3R = DREAL(DCONJG(PROP)*PROP3) PROP3I = DIMAG(DCONJG(PROP)*PROP3) PROP4R = DREAL(DCONJG(PROP)*PROP4) PROP4I = DIMAG(DCONJG(PROP)*PROP4) PROP34R = DREAL(DCONJG(PROP3)*PROP4) QQQQH = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)- & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*(( & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452) & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1)))) 200 CONTINUE END CDECK ID>, HWH2SH. *CMZ :- -30/06/01 18.25.35 by Stefano Moretti *-- Author : Kosuke Odagiri & Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4, & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH) C----------------------------------------------------------------------- C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS C----------------------------------------------------------------------- C NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2 C MGM3, MGM4 = MASS * WIDTH C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1) C PREFACTORS: C GGSQHTOT = C (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC) C QQSQHTOT = C (G_S**4)*(G_HIGGS**2)*(QQSQH )*(1.-1./CAFAC**2)/4. C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ... C C...First release: 08-OCT-1999 by Kosuke Odagiri C...First modified: 12-NOV-1999 by Stefano Moretti C----------------------------------------------------------------------- IMPLICIT NONE C --- SUBPROCESS INTEGER IGG,IQQ C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4 C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES INTEGER I,J DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU C --- QQ AMPLITUDES DOUBLE PRECISION QQSQH DOUBLE PRECISION PT32,PT42,PT34 DOUBLE COMPLEX PROP3,PROP4 C --- CONSTANT PARAMETERS DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0) SQTWO=SQRT(TWO) MSQTWO=-SQTWO/4.D0 GGSQHT = ZERO GGSQHU = ZERO GGSQHN = ZERO QQSQH = ZERO IF(IGG.EQ.0)GOTO 100 C -- GG SCATTERING. MSQS = -SQTWO/SQS G13 = MSQS/(P3(0)-P3(3)) G23 = MSQS/(P3(0)+P3(3)) G14 = MSQS/(P4(0)-P4(3)) G24 = MSQS/(P4(0)+P4(3)) G35 = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4) G45 = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3) AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45) AMPC = MSQTWO*(G35+G45) DO 10 I = 1,2 DO 20 J = 1,2 AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45 AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45 IF (I.EQ.J) THEN AMPST = AMPT-AMPS+AMPC AMPSU = AMPU+AMPS+AMPC ELSE AMPST = AMPT AMPSU = AMPU END IF AMPTU = AMPST+AMPSU GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST) GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU) GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU) 20 CONTINUE 10 CONTINUE 100 CONTINUE IF(IQQ.EQ.0)GOTO 200 C -- QQ SCATTERING. PT32 = P3(1)**2+P3(2)**2 PT42 = P4(1)**2+P4(2)**2 PT34 = P3(1)*P4(1)+P3(2)*P4(2) PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3) PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4) QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+ & PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4) 200 CONTINUE END CDECK ID>, HWH2SS *CMZ :- -27/02/01 17:04:16 by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWH2SS(S,K,KK) C----------------------------------------------------------------------- C Subroutine to calculate the spinor products in the notation of C Kleiss and Strirling S(1) is S and S(2) is T C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI, & PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP INTEGER I,II,JJ EPS=0.0000001 ZI=DCMPLX(ZERO,ONE) Z1=DCMPLX(ONE,ZERO) C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING DO I=1,4 P(I,2) = K(I) P(I,1) = KK(I) ENDDO DO 2 II=1,2 WRN(II)=ONE IF(P(4,II).LT.ZERO) WRN(II)=-ONE DO 2 JJ=1,4 P(JJ,II)=WRN(II)*P(JJ,II) 2 CONTINUE C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES Q1=P(4,1)+P(1,1) QP=ZERO IF(Q1.GT.EPS) QP=SQRT(Q1) Q2=P(4,1)-P(1,1) QM=0.0 IF(Q2.GT.EPS)QM=SQRT(Q2) P1=P(4,2)+P(1,2) PP=ZERO IF(P1.GT.EPS)PP=SQRT(P1) P2=P(4,2)-P(1,2) PM=ZERO IF(P2.GT.EPS)PM=SQRT(P2) DMP=PM*QP ZDMP=DCMPLX(DMP,ZERO) DPM=PP*QM ZDPM=DCMPLX(DPM,ZERO) C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING PT=SQRT(P(2,2)**2+P(3,2)**2) QT=SQRT(P(2,1)**2+P(3,1)**2) IF(PT.GT.EPS) GOTO 99 ZP=Z1 GOTO 98 99 PTI=ONE/PT ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2)) 98 ZPS=DCONJG(ZP) IF(QT.GT.EPS) GOTO 89 ZQ=Z1 GOTO 88 89 QTI=ONE/QT ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1)) 88 ZQS=DCONJG(ZQ) ZT=Z1 IF(WRN(1).LT.ZERO) ZT=ZT*ZI IF(WRN(2).LT.ZERO) ZT=ZT*ZI S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT END CDECK ID>, HWH2T1. *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1) C----------------------------------------------------------------------- C Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T1,S,D INTEGER I,J,K,L,Z1,Z2,P1 COMMON/HWHEWS/S(8,8,2),D(8,8) IF(P1.EQ.1) THEN HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2) ELSEIF(P1.EQ.2) THEN HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1) ELSE CALL HWWARN('HWH2T1',500) ENDIF END CDECK ID>, HWH2T2 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2) C----------------------------------------------------------------------- C Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T2,S,D INTEGER I,J,K,L,Z1,Z2,P1,P2 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P1.EQ.1.AND.P2.EQ.1) THEN HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2) ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1) & +B(K)*S(Z1,K,2)*S(K,I,1)) ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2) & +B(K)*S(Z2,K,1)*S(K,I,2)) ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1) ELSE CALL HWWARN('HWH2T2',500) ENDIF END CDECK ID>, HWH2T3. *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2) C----------------------------------------------------------------------- C Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T3,S,D INTEGER I,J,K,L,Z1,Z2,P1,P2 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P1.EQ.1.AND.P2.EQ.1) THEN HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2) ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN HWH2T3 = ZERO ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN HWH2T3 = ZERO ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1) ELSE CALL HWWARN('HWH2T3',500) ENDIF END CDECK ID>, HWH2T4 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2) C----------------------------------------------------------------------- C Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the line K,L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T4,AP,AM,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)* & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1)) AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)* & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2)) IF(P1.EQ.1.AND.P2.EQ.1) THEN HWH2T4 = AP(I,J,K,L) ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN HWH2T4 = AP(I,J,L,K) ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN HWH2T4 = AM(I,J,L,K) ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN HWH2T4 = AM(I,J,K,L) ELSE CALL HWWARN('HWH2T4',500) ENDIF END CDECK ID>, HWH2T5 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2) C----------------------------------------------------------------------- C Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the line K,L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T5,AP,AM,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)* & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1)) AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)* & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2)) IF(P1.EQ.1.AND.P2.EQ.1) THEN HWH2T5 = AM(J,I,L,K) ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN HWH2T5 = AM(J,I,K,L) ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN HWH2T5 = AP(J,I,K,L) ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN HWH2T5 = AP(J,I,L,K) ELSE CALL HWWARN('HWH2T5',500) ENDIF END CDECK ID>, HWH2T6 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3) C----------------------------------------------------------------------- C Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C P3 is the polarization of the gluon L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T6,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P1.EQ.1) THEN J1 = Z1 J2 = Z2 ELSE J1 = Z2 J2 = Z1 ENDIF IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)* & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)* & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)* & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))* & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1)) ELSE CALL HWWARN('HWH2T6',500) ENDIF IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6) END CDECK ID>, HWH2T7 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3) C----------------------------------------------------------------------- C Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C P3 is the polarization of the gluon L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T7,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P1.EQ.1) THEN J1 = Z1 J2 = Z2 ELSE J1 = Z2 J2 = Z1 ENDIF IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)* & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)* & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))* & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)* & S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)* & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1)) ELSE CALL HWWARN('HWH2T7',500) ENDIF IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7) END CDECK ID>, HWH2T8 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3) C----------------------------------------------------------------------- C Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262 C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C P3 is the polarization of the gluon L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T8,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P1.EQ.1) THEN J1 = Z1 J2 = Z2 ELSE J1 = Z2 J2 = Z1 ENDIF IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))* & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)* & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)* & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1)) ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR. & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)* & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1)) ELSE CALL HWWARN('HWH2T8',500) ENDIF IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8) END CDECK ID>, HWH2T9 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3) C----------------------------------------------------------------------- C Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262 C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C P3 is the polarization of the gluon L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T9,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P2.NE.P3) THEN HWH2T9 = ZERO ELSE IF(P1.EQ.1) THEN J1 = Z1 J2 = Z2 ELSEIF(P1.EQ.2) THEN J1 = Z2 J2 = Z1 ENDIF HWH2T9 = TWO*S(I,J2,1)*( & B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1) & +B(L)*S(J1,L,2)*S(L,K,1)) & -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1) & +B(K)*S(J1,K,2)*S(K,L,1))) IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9) ENDIF END CDECK ID>, HWH2T0 *CMZ :- -27/02/01 17:04:16 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3) C----------------------------------------------------------------------- C Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262 C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE C I-L are the particles C Z1 and Z2 are the decay products of the Z C P1 is the polarization of the line I,J C P2 is the polarization of the gluon K C P3 is the polarization of the gluon L C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWH2T0,S,D INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3 DOUBLE PRECISION B(6) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE B DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ IF(P2.NE.P3) THEN HWH2T0 = ZERO ELSE IF(P1.EQ.1) THEN J1 = Z1 J2 = Z2 ELSEIF(P1.EQ.2) THEN J1 = Z2 J2 = Z1 ENDIF HWH2T0 = TWO*S(J1,J,2)*( & B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1) & +B(L)*S(K,L,2)*S(L,J2,1)) & -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1) & +B(K)*S(L,K,2)*S(K,J2,1))) IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0) ENDIF END CDECK ID>, HWH2VH. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST) C----------------------------------------------------------------------- C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4), C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks). C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW C...times: C... (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN) if V=Z C... VCKM(q,q') if V=W+/- C C...First release: 1-APR-1998 by Stefano Moretti C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3) DOUBLE PRECISION P(0:3) DOUBLE PRECISION RMV,GAMV,RES,RESL,REST INTEGER I DOUBLE PRECISION S,S12,S13,S23 DOUBLE PRECISION T, T13,T23 DOUBLE PRECISION PV,CFC PARAMETER (GAMV=0.D0) S=(P1(0)+P2(0))**2 DO I=1,3 S=S-(P1(I)+P2(I))**2 END DO S12=P1(0)*P2(0) S13=P1(0)*P3(0) S23=P2(0)*P3(0) DO I=1,3 S12=S12-P1(I)*P2(I) S13=S13-P1(I)*P3(I) S23=S23-P2(I)*P3(I) END DO C...Total ME. RES=(S12+2.D0/RMV/RMV*(S13*S23)) & /((S-RMV**2)**2+GAMV**2*RMV**2) & /12.D0 C...Extracts spin dependence. PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2) CFC=P3(0)/PV DO I=1,3 P(I)=P3(I)*CFC END DO P(0)=PV**2/P3(0)*CFC T=P(0)**2 DO I=1,3 T=T-P(I)**2 END DO T13=P1(0)*P(0) T23=P2(0)*P(0) DO I=1,3 T13=T13-P1(I)*P(I) T23=T23-P2(I)*P(I) END DO C...Longitudinal ME (along V direction). RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV) & /((S-RMV**2)**2+GAMV**2*RMV**2) & /12.D0 C...Transverse ME (perpendicular to V direction). REST=RES-RESL END CDECK ID>, HWH4JT. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWH4JT C----------------------------------------------------------------------- C Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar C IOP4JT controls the treatment of the colour flow interference term C qqbar-gg case: C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421 C qqbar-qqbar (identical quark flavour) case: C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143 C C Matrix elements based on Ellis Ross & Terrano and Catani & Seymour C C WARNING: Phase space factor inaccurate for JADE y_cut > 0.14. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4) DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2, & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT, & X12,X13,X14,X23,X24,X34, & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2, & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1, & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST $ ,EF,QF,E(4) LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4, & HWH4J5,HWH4J6,HWH4J7 SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX, & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT, & Q2NOW,SCUT,YLST SAVE IST DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/ C IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE IF (NHEP+5.GT.NMXHEP) THEN CALL HWWARN('HWH4JT',100) GOTO 999 ENDIF QNOW=PHEP(5,3) IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN QLST=QNOW YLST=Y4JT Q2NOW=QNOW**2 SCUT=Y4JT*Q2NOW C Calculate allowed fraction of Phase Space using parameterization IF (DURHAM) THEN PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT & *(1.+148.3*Y4JT*(1.+3.913*Y4JT)))) & /(1.-8.352*Y4JT*(1.-1102.*Y4JT & *(1.+1603.*Y4JT*(1.+22.99*Y4JT)))) ELSE PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT & *(1.+102.9*Y4JT*(1.-6.579*Y4JT)))) & /(1.-3.392*Y4JT*(1.-946.5*Y4JT & *(1.+423.4*Y4JT*(1.-3.971*Y4JT)))) ENDIF FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC & /(THREE*16*PIFAC) COLA=CFFAC COLB=CFFAC-HALF*CAFAC COLC=HALF LM=1 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM) LP=2 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP) IQK=MOD(IPROC,10) IF (IQK.NE.0) THEN IDMN=IQK IDMX=IQK ELSE IDMN=1 IDMX=6 ENDIF DO 10 I=1,6 CALL HWUCFF(11,I,Q2NOW,CLF(1,I)) IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN INCLQG(I)=.TRUE. ELSE INCLQG(I)=.FALSE. ENDIF DO 10 J=I,6 IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN INCLQQ(I,J)=.TRUE. INCLQQ(J,I)=.TRUE. ELSE INCLQQ(I,J)=.FALSE. INCLQQ(J,I)=.FALSE. ENDIF 10 CONTINUE IF (MOD(IPROC/10,10).EQ.5) THEN ORIENT=.FALSE. ELSE ORIENT=.TRUE. ENDIF ENDIF C Generate phase space point and check it passes cuts CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) DO 20 I=2,5 20 PHEP(5,NHEP+I)=0. 30 CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3), & PHEP(1,NHEP+4),PHEP(1,NHEP+5)) IF(IERROR.NE.0) RETURN IF (DURHAM) THEN P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3)) X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3), & PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12 IF (X12.GT.SCUT) THEN P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4)) X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4), & PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13 IF (X13.GT.SCUT) THEN P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5)) X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5), & PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14 IF (X14.GT.SCUT) THEN P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4)) X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4), & PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23 IF (X23.GT.SCUT) THEN P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5)) X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5), & PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24 IF (X24.GT.SCUT) THEN P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5)) X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5), & PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34 IF (X34.GT.SCUT) GOTO 40 ENDIF ENDIF ENDIF ENDIF ENDIF ELSE P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3)) IF (P12.GT.SCUT) THEN P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4)) IF (P13.GT.SCUT) THEN P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5)) IF (P14.GT.SCUT) THEN P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4)) IF (P23.GT.SCUT) THEN P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5)) IF (P24.GT.SCUT) THEN P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5)) IF (P34.GT.SCUT) GOTO 40 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF C Failed cuts retry GOTO 30 C Passed cuts: calculate contributions to Matrix Elements 40 EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34)) IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34)) IF (FIX4JT) EMSCA=SQRT(SCUT) FACTR=FACT*HWUALF(1,EMSCA)**2 IF (ORIENT) THEN QF=HWULDO(PHEP(1,LP),PHEP(1,3)) EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW)) QF=HALF-EF*QF/Q2NOW DO I=1,4 E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3) ENDDO EP1=HWULDO(E,PHEP(1,NHEP+2)) EP2=HWULDO(E,PHEP(1,NHEP+3)) EP3=HWULDO(E,PHEP(1,NHEP+4)) EP4=HWULDO(E,PHEP(1,NHEP+5)) ENDIF C q-qbar-g-g GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT) & +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT) GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT) & +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT) GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT) & +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT) & +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT) & +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT) GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT) & +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT) GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT) & +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT) GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT) & +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT) C Add up weights GG1 =COLA*(GG1 +GG13) GG2 =COLA*(GG2 +GG23) GGINT=COLB*(GG12-GG13-GG23) WTGG=FACTR*(GG1+GG2+GGINT) C q-qbar-q-qbar QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT) & +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT) & +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT) & +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT) QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT) & +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT) & +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT) & +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT) QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT) & +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT) & +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT) & +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT) & +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT) & +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT) & +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT) & +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT) C Add up weights WTQP=FACTR*COLC*QP/TWO QQ1 =COLC*QP QQ2 =COLC*QQ QQINT=COLB*QQINT WTQQ=FACTR*(QQ1+QQ2+QQINT)/2 ENDIF C HCS=0. DO 60 ID1=IDMN,IDMX IF (INCLQG(ID1)) THEN C Gluon channel HCS=HCS+CLF(1,ID1)*WTGG IF (GENEV.AND.HCS.GT.RCS) THEN C Select colour flow WTAB=GG1 WTBA=GG2 IF (IOP4JT(1).EQ.1) THEN IF (GGINT.GE.ZERO) THEN WTAB=WTAB+GGINT ELSE WTBA=MAX(WTBA,WTBA+GGINT) ENDIF ELSEIF (IOP4JT(1).EQ.2) THEN IF (GGINT.GE.ZERO) THEN WTBA=WTBA+GGINT ELSE WTAB=MAX(WTAB,WTAB+GGINT) ENDIF ELSEIF (IOP4JT(1).NE.0) THEN CALL HWWARN('HWH4JT',101) GOTO 999 ENDIF WTOT=WTAB+WTBA IF (WTAB.GT.HWRGEN(1)*WTOT) THEN CALL HWHQCP( 13, 13,3142,91) GOTO 99 ELSE CALL HWHQCP( 13, 13,4123,92) GOTO 99 ENDIF ENDIF ENDIF C Quark channels DO 50 ID2=1,6 C Identical quark pairs IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN HCS=HCS+CLF(1,ID1)*WTQQ IF (GENEV.AND.HCS.GT.RCS) THEN C Select colour flow WTAB=QQ1 WTBA=QQ2 IF (IOP4JT(2).EQ.1) THEN IF (QQINT.GE.ZERO) THEN WTAB=WTAB+QQINT ELSE WTBA=MAX(WTBA,WTBA+QQINT) ENDIF ELSEIF (IOP4JT(2).EQ.2) THEN IF (QQINT.GE.ZERO) THEN WTBA=WTBA+QQINT ELSE WTAB=MAX(WTAB,WTAB+QQINT) ENDIF ELSEIF (IOP4JT(2).NE.0) THEN CALL HWWARN('HWH4JT',102) GOTO 999 ENDIF WTOT=WTAB+WTBA IF (WTAB.GT.HWRGEN(1)*WTOT) THEN CALL HWHQCP(ID1,ID1+6,4123,93) GOTO 99 ELSE CALL HWHQCP(ID1,ID1+6,2143,94) GOTO 99 ENDIF ENDIF C Unlike quark pairs ELSEIF (INCLQQ(ID1,ID2)) THEN HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID2,ID2+6,4123,95) GOTO 99 ENDIF ENDIF 50 CONTINUE 60 CONTINUE EVWGT=HCS RETURN C Set up labels for selected final state 99 IDN(1)=ID1 IDN(2)=ID1+6 J=NHEP+1 IDHW(J)=200 IDHEP(J)=23 ISTHEP(J)=110 JMOHEP(1,J)=LM JMOHEP(2,J)=LP JDAHEP(1,J)=NHEP+2 JDAHEP(2,J)=NHEP+5 DO 100 I=1,4 J=NHEP+1+I IDHW(J)=IDN(I) IDHEP(J)=IDPDG(IDN(I)) ISTHEP(J)=IST(I) JMOHEP(1,J)=NHEP+1 100 JDAHEP(1,J)=0 C And colour structure pointers DO 110 I=1,4 J=ICO(I) JMOHEP(2,NHEP+1+I)=NHEP+1+J 110 JDAHEP(2,NHEP+1+J)=NHEP+1+I NHEP=NHEP+5 999 RETURN END CDECK ID>, HWH4J1. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles *- Split in 6 files by M. Kirsanov. C----------------------------------------------------------------------- FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J1, & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4 LOGICAL ORIENT S123=S12+S13+S23 S124=S12+S14+S24 S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23)) & +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2) & /(S13*S24*S134*S234) & +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2) & +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24) IF (ORIENT) THEN HWH4J1=HWH4J1 & +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34) & -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23 & +S24*S134+S234*(S13+2*S234)) & +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24) & -EP1*EP4*(S12*S124+S23*(S+S12+S14)) & +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34) & -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234) & +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234) & +EP3*EP3*(S14+2*S234)*S24 & +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23) & +EP4*EP4*S13*S23)*S134 & +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234) ELSE HWH4J1=2*HWH4J1/3 ENDIF END CDECK ID>, HWH4J2. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J2, & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4 LOGICAL ORIENT S123=S12+S13+S23 S124=S12+S14+S24 S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24))) & /(S14*S23*S13*S134) & +S12*(S+S34)*S124/(S24*S234*S14*S134) & -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14) & +S12*S123*S124/(2*S13*S24*S14*S23) IF (ORIENT) THEN HWH4J2=HWH4J2 & +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34) & +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34)) & +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24)) & -4*(S13*S24-S14*S23)*S24) & +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23)) & +EP2*EP2*(S12*S134-4*S13*S24)*S134 & +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24)) & -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24 & +S12*(S12-S13+S23)*S134) & -EP3*EP3*4*S12*S14*S24 & -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234 & +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S)) & -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123) & /(2*S*S13*S14*S234*S23*S24*S134) ELSE HWH4J2=2*HWH4J2/3 ENDIF END CDECK ID>, HWH4J4. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J4, & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4 LOGICAL ORIENT S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23)) & +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2) & -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34)) & +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23) & +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2 IF (ORIENT) THEN HWH4J4=HWH4J4 & +4*((-EP1*EP1*2*(S23+S24)*S34 & -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34) & +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24) & +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23) & -EP2*EP2*2*(S13+S14)*S34 & +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34)) & +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34)) & +EP3*EP3*2*S14*S24 & +EP3*EP4*2*(S12*S34-S13*S24-S14*S23) & +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2) & +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2)) & +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34)) & +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34))) & /(S*(S134*S34)**2)) ELSE HWH4J4=2*HWH4J4/3 ENDIF END CDECK ID>, HWH4J5. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J5, & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4, & SUM LOGICAL ORIENT S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34- $ S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34- $ 2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+ $ 4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+ $ 2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2- $ 2*S12**2*S13)/(2*S13*S134*S234*S34)+ $ (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+ $ 4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+ $ 3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+ $ 2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+ $ 2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+ $ 4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)- $ (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+ $ S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24- $ 4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+ $ S12*S13*S14-S12*S13**2)/(S13*S34*S134**2) IF (ORIENT) THEN SUM= & +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234) & *S24*S134 & +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23) & +S13*(S13+S23)+S24*S34 )*S24*S134 & -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34) & +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134 & + 4*S13**2*S24*S234) & +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234) & +S34*(S234-3*S24))*S24*S134 & +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24 & -(S12*(S13+S134+2*S34)+2*S13*S24 & +(S13-2*S14)*S23)*S234)*S134 & +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34)) & +2*S14*S134*(S24+S234))*S134 SUM=SUM & -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24 & +(S12*(S13+S134)+(S13+S24+2*S234)*S14 & +2*S13*(2*S23+S34))*S234)*S134 & +4*S13**2*S24*S234) & +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24 & -((S-3*S13+S23+2*S24)*S13+2*S12*S14 & +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234) & +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134 & +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24 & -(S12*S134+2*S13*S23)*S234)*S134 & +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134 HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24) ELSE HWH4J5=2*HWH4J5/3 ENDIF END CDECK ID>, HWH4J6. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J6, & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4 LOGICAL ORIENT S123=S12+S13+S23 S124=S12+S14+S24 S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2 & -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34) & -S13*S24*(S234+S13))/(S13**2*S123*S134) IF (ORIENT) THEN HWH4J6=HWH4J6 & +4*(-EP1*EP1*2*S23*S34 & +EP1*EP2*((S12-S23)*S34-S13*(S24-S34)) & +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23) & -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23) & -(EP1+EP2+EP3)*EP4*2 & *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123 & +EP2*EP2*S13*(S14+S34) & +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14) & -EP3*EP3*2*S12*S14 & -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12) & +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2) ELSE HWH4J6=2*HWH4J6/3 ENDIF END CDECK ID>, HWH4J7. *CMZ :- -01/04/99 19.47.55 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT) C----------------------------------------------------------------------- C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWH4J7, & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4 LOGICAL ORIENT S123=S12+S13+S23 S124=S12+S14+S24 S134=S13+S14+S34 S234=S23+S24+S34 S=S12+S13+S14+S23+S24+S34 HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34) & /(S13*S134*S23*S123) & -S12*(S12*S-S123*S124)/(S123**2*S13*S23) & -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234) IF (ORIENT) THEN HWH4J7=HWH4J7 & +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134 & -EP1*EP2*2*S34**2*S123 & +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23)) & +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123 & +2*S134*(S24*(S13-S12)-S23*(S12+S14))) & +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134 & +S123*(S13+S14)*S34) & +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123 & -2*S134*(S12*S234-S13*S24+S14*S23)) & -EP3*EP3*S12*(2*S24*S134+S123*S34) & +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123) & +EP4*EP4*S12*(2*S23*S134-S123*S34)) & /(S*S13*S23*S123*S134*S234) ELSE HWH4J7=2*HWH4J7/3 ENDIF END CDECK ID>, HWHBGF. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Giovanni Abbiendi & Luca Stanco C----------------------------------------------------------------------- SUBROUTINE HWHBGF C----------------------------------------------------------------------- C Order Alpha_s processes in charged lepton-hadron collisions C C Process code IPROC has to be set in the Main Program C the following codes IPROC may be selected C C 9100 : NC BOSON-GLUON FUSION C 9100+IQK (IQK=1,...,6) : produced flavour is IQK C 9107 : produced J/psi + gluon C C 9110 : NC QCD COMPTON C 9110+IQK (IQK=1,...,12) : struck parton is IQK C C 9130 : NC order alpha_s processes (9100+9110) C C Select maximum and minimum generated flavour when IQK=0 C setting IFLMIN and IFLMAX in the Main Program C (allowed values from 1 to 6), default are 1 and 5 C allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar C C CHARGED CURRENT Boson-Gluon Fusion processes C 9141 : CC s cbar (c sbar) C 9142 : CC b cbar (c bbar) C 9143 : CC s tbar (t cbar) C 9144 : CC b tbar (t bbar) C C other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX C when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute C Q2MIN and Q2MAX (EPA is used); ZJMAX cut C C Add 10000 to suppress soft remnant fragmentation C C Mean EVWGT = cross section in nanoBarn C C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP, & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18), & SIGSUM,PROB,PRAN,PVRT(4),X INTEGER LEP INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO EXTERNAL HWRGEN SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE C---Initialization IF (FSTWGT) THEN C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS LEP=0 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN LEP=1 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN LEP=-1 ENDIF IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500) IPROO=MOD(IPROC,100)/10 IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN IQK=MOD(IPROC,10) IFL=IQK IF (IQK.EQ.7) IFL=164 CHARGD=IPROO.EQ.4 ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN IQK=MOD(IPROC,100)-10 IFL=IQK+6 CHARGD=.FALSE. ELSEIF (IPROO.EQ.3) THEN IQK=0 IFL=0 CHARGD=.FALSE. ELSE CALL HWWARN('HWHBGF',501) ENDIF C LEPFIN = IDHW(1) IF(CHARGD) THEN LEPFIN = IDHW(1)+1 IF (IQK.EQ.1) THEN IFLAVU=4 IFLAVD=3 ID1 = 3 ID2 = 10 ELSEIF (IQK.EQ.2) THEN IFLAVU=4 IFLAVD=5 ID1 = 5 ID2 = 10 ELSEIF (IQK.EQ.3) THEN IFLAVU=6 IFLAVD=3 ID1 = 3 ID2 =12 ELSE IFLAVU=6 IFLAVD=5 ID1 = 5 ID2 =12 ENDIF IF (LEP.EQ.-1) THEN IDD=ID1 ID1=ID2-6 ID2=IDD+6 ENDIF ENDIF C IF (IQK.EQ.0) THEN DO I=1,18 INCLUD(I)=.TRUE. ENDDO IMIN=1 IMAX=18 DO I=1,6 IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE. ENDDO DO I=7,18 IF (I.LE.12) THEN IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE. ELSE IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE. ENDIF ENDDO IF (IPROO.EQ.0) THEN DO I=7,18 INCLUD(I)=.FALSE. ENDDO IMIN=IFLMIN IMAX=IFLMAX ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN DO I=1,6 INCLUD(I)=.FALSE. ENDDO IMIN=IFLMIN+6 IMAX=IFLMAX+12 ELSEIF (IPROO.EQ.3) THEN IMIN=IFLMIN IMAX=IFLMAX+12 ENDIF ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN DO I=1,18 INCLUD(I)=.FALSE. ENDDO IF (IFL.LE.18) THEN INCLUD(IFL)=.TRUE. IMIN=IFL IMAX=IFL ELSEIF (IFL.EQ.164) THEN INCLUD(7)=.TRUE. IMIN=7 IMAX=7 ENDIF ENDIF ENDIF C---End of initialization IF(GENEV) THEN IF (.NOT.CHARGD) THEN IF (IQK.EQ.0) THEN PRAN= SIGSUM * HWRGEN(0) PROB=ZERO DO 10 IFL=IMIN,IMAX IF (.NOT.INSIDE(IFL)) GOTO 10 PROB=PROB+FSIGMA(IFL) IF (PROB.GE.PRAN) GOTO 20 10 CONTINUE ENDIF C---at this point the subprocess has been selected (IFL) 20 CONTINUE IF (IFL.LE.6) THEN C---Boson-Gluon Fusion event IDHW(NHEP+1)=IDHW(1) IDHW(NHEP+2)=13 IDHW(NHEP+3)=15 IDHW(NHEP+4)=LEPFIN IDHW(NHEP+5)=IFL IDHW(NHEP+6)=IFL+6 ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN C---QCD_Compton event IDHW(NHEP+1)=IDHW(1) IDHW(NHEP+2)=IFL-6 IDHW(NHEP+3)=15 IDHW(NHEP+4)=LEPFIN IDHW(NHEP+5)=IFL-6 IDHW(NHEP+6)=13 ELSEIF (IFL.EQ.164) THEN C---gamma+gluon-->J/Psi+gluon IDHW(NHEP+1)=IDHW(1) IDHW(NHEP+2)=13 IDHW(NHEP+3)=15 IDHW(NHEP+4)=LEPFIN IDHW(NHEP+5)=164 IDHW(NHEP+6)=13 ELSE CALL HWWARN('HWHBGF',503) ENDIF ELSE C---Charged current event of specified flavours IDHW(NHEP+1)=IDHW(1) IDHW(NHEP+2)=13 IDHW(NHEP+3)=15 IDHW(NHEP+4)=LEPFIN IDHW(NHEP+5)=ID1 IDHW(NHEP+6)=ID2 ENDIF C DO 1 I=NHEP+1,NHEP+6 1 IDHEP(I)=IDPDG(IDHW(I)) C C---Codes common for all processes ISTHEP(NHEP+1)=111 ISTHEP(NHEP+2)=112 ISTHEP(NHEP+3)=110 ISTHEP(NHEP+4)=113 ISTHEP(NHEP+5)=114 ISTHEP(NHEP+6)=114 C DO I=NHEP+1,NHEP+6 JMOHEP(1,I)=NHEP+3 JDAHEP(1,I)=0 ENDDO C---Incoming lepton JMOHEP(2,NHEP+1)=NHEP+4 JDAHEP(2,NHEP+1)=NHEP+4 C---Hard Process C.M. JMOHEP(1,NHEP+3)=NHEP+1 JMOHEP(2,NHEP+3)=NHEP+2 JDAHEP(1,NHEP+3)=NHEP+4 JDAHEP(2,NHEP+3)=NHEP+6 C---Outgoing lepton JMOHEP(2,NHEP+4)=NHEP+1 JDAHEP(2,NHEP+4)=NHEP+1 C IF (IFL.LE.6 .OR. CHARGD) THEN C---Codes for boson-gluon fusion processes C--- Incoming gluon JMOHEP(2,NHEP+2)=NHEP+6 JDAHEP(2,NHEP+2)=NHEP+5 C--- Outgoing quark JMOHEP(2,NHEP+5)=NHEP+2 JDAHEP(2,NHEP+5)=NHEP+6 C--- Outgoing antiquark JMOHEP(2,NHEP+6)=NHEP+5 JDAHEP(2,NHEP+6)=NHEP+2 ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN C---Codes for V+q --> q+g C--- Incoming quark JMOHEP(2,NHEP+2)=NHEP+5 JDAHEP(2,NHEP+2)=NHEP+6 C--- Outgoing quark JMOHEP(2,NHEP+5)=NHEP+6 JDAHEP(2,NHEP+5)=NHEP+2 C--- Outgoing gluon JMOHEP(2,NHEP+6)=NHEP+2 JDAHEP(2,NHEP+6)=NHEP+5 ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN C---Codes for V+qbar --> qbar+g C--- Incoming antiquark JMOHEP(2,NHEP+2)=NHEP+6 JDAHEP(2,NHEP+2)=NHEP+5 C--- Outgoing antiquark JMOHEP(2,NHEP+5)=NHEP+2 JDAHEP(2,NHEP+5)=NHEP+6 C--- Outgoing gluon JMOHEP(2,NHEP+6)=NHEP+5 JDAHEP(2,NHEP+6)=NHEP+2 ELSEIF (IFL.EQ.164) THEN C---Codes for Gamma+gluon --> J/Psi+gluon C--- Incoming gluon JMOHEP(2,NHEP+2)=NHEP+6 JDAHEP(2,NHEP+2)=NHEP+6 C--- Outgoing J/Psi JMOHEP(2,NHEP+5)=NHEP+1 JDAHEP(2,NHEP+5)=NHEP+1 C--- Outgoing gluon JMOHEP(2,NHEP+6)=NHEP+2 JDAHEP(2,NHEP+6)=NHEP+2 ENDIF C---Computation of momenta in Laboratory frame of reference CALL HWHBKI NHEP=NHEP+6 C Decide which quark radiated and assign production vertices IF (IFL.LE.6) THEN C Boson-Gluon fusion case IF (1-Z.LT.HWRGEN(0)) THEN C Gluon splitting to quark CALL HWVZRO(4,VHEP(1,NHEP-1)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT) CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4)) ELSE C Gluon splitting to antiquark CALL HWVZRO(4,VHEP(1,NHEP)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT) CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1)) CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4)) ENDIF ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN C QCD Compton case X=1/(1+SHAT/Q2) IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN C Incoming quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP-1)) CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT) CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4)) ELSE C Outgoing quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP-4)) CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT) CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP)) CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1)) ENDIF ENDIF C---HERWIG gets confused if lepton momentum is different from beam C momentum, which it can be if incoming hadron has negative virtuality C As a temporary fix, simply copy the momentum. C Momentum conservation somehow gets taken care of HWBGEN! call hwvequ(5,phep(1,1),phep(1,nhep-5)) ELSE EVWGT=ZERO C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation C---in the largest phase space avalaible for selected processes and C---filling of logical vector INSIDE to tag contributing ones CALL HWHBRN (IFGO) IF(IFGO) GOTO 999 C---calculate differential cross section corresponding to the chosen C---variables and the weight for MC generation IF (IQK.EQ.0) THEN C---many subprocesses included DO I=1,18 FSIGMA(I)=ZERO ENDDO SIGSUM=ZERO DO I=IMIN,IMAX IF (INSIDE(I)) THEN IFL=I DSIGMA=ZERO CALL HWHBSG FSIGMA(I)=DSIGMA SIGSUM=SIGSUM+DSIGMA ENDIF ENDDO EVWGT=SIGSUM * AJACOB ELSE C---only one subprocess included CALL HWHBSG EVWGT= DSIGMA * AJACOB ENDIF IF (EVWGT.LT.ZERO) EVWGT=ZERO ENDIF 999 RETURN END CDECK ID>, HWHBKI. *CMZ :- -26/04/91 13.19.32 by Federico Carminati *-- Author : Giovanni Abbiendi & Luca Stanco C---------------------------------------------------------------------- SUBROUTINE HWHBKI C---------------------------------------------------------------------- C gives the fourmomenta in the laboratory system for the particles C of the hard 2-->3 subprocess, to match with HERWIG routines of C jet evolution. C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB, & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT, & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE, & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5), & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP LOGICAL CHARGD,INCLUD(18),INSIDE(18) EXTERNAL HWUECM,HWUPCM,HWUSQR COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE C IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) C---Set masses IF (CHARGD) THEN MPART=ZERO MF1=RMASS(IDHW(NHEP+5)) MF2=RMASS(IDHW(NHEP+6)) MREMIN=MP ELSE IS = IFL IF (IFL.EQ.164) IS=IQK MPART=ZERO IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6) MF1=MFIN1(IS) MF2=MFIN2(IS) MREMIN = MREMIF(IS) ENDIF C---Calculation of kinematical variables for the generated event C in the center of mass frame of the incoming boson and parton C with parton along +z EGAM = HWUECM (SHAT, -Q2, MPART**2) PGAM = SQRT( EGAM**2 + Q2 ) EP = RSHAT-EGAM PP = PGAM A = (W2+Q2-MP**2)/TWO PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2 IF (PPROT.LT.ZERO) THEN CALL HWWARN('HWHBKI',101) GOTO 999 ENDIF EPROT = SQRT(PPROT**2+MP**2) IF ((EPROT+PPROT).LT.(EP+PP)) THEN CALL HWWARN('HWHBKI',102) GOTO 999 ENDIF EL = ( PGAM / PPROT * SMA - Q2 ) / TWO + / (EGAM + PGAM / PPROT * EPROT) IF (EL.GT.ME) THEN PL = SQRT ( EL**2 - ME**2 ) ELSE CALL HWWARN ('HWHBKI',103) GOTO 999 ENDIF COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL) IF ( ABS(COSBET) .GE. ONE ) THEN COSBET = SIGN (ONE,COSBET) SINBET = ZERO ELSE SINBET = SQRT (ONE - COSBET**2) ENDIF SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2) THEN CALL HWWARN ('HWHBKI',104) GOTO 999 ENDIF Q1 = HWUPCM( RSHAT, MF1, MF2) E1 = SQRT(Q1**2+MF1**2) E2 = SQRT(Q1**2+MF2**2) IF (Q1 .GT. ZERO) THEN COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1) IF (ABS(COSTHE) .GT. ONE) THEN COSTHE=SIGN(ONE,COSTHE) SINTHE=ZERO ELSE SINTHE=SQRT(ONE-COSTHE**2) ENDIF ELSE COSTHE=ZERO SINTHE=ONE ENDIF C---Initial lepton PHEP(1,NHEP+1)=PL*SINBET PHEP(2,NHEP+1)=ZERO PHEP(3,NHEP+1)=PL*COSBET PHEP(4,NHEP+1)=EL PHEP(5,NHEP+1)=RMASS(IDHW(1)) C---Initial Hadron PROTON(1)=ZERO PROTON(2)=ZERO PROTON(3)=PPROT PROTON(4)=EPROT CALL HWUMAS (PROTON) C---Initial parton PHEP(1,NHEP+2)=ZERO PHEP(2,NHEP+2)=ZERO PHEP(3,NHEP+2)=PP PHEP(4,NHEP+2)=EP PHEP(5,NHEP+2)=MPART C---HARD SUBPROCESS 2-->3 CENTRE OF MASS PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2) PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2) PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2) PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2) CALL HWUMAS ( PHEP(1,NHEP+3) ) C---Virtual boson PGAMMA(1)=ZERO PGAMMA(2)=ZERO PGAMMA(3)=-PGAM PGAMMA(4)=EGAM PGAMMA(5)=HWUSQR(Q2) C---Scattered lepton PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1) PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2) PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3) PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4) PHEP(5,NHEP+4)=RMASS(IDHW(1)) IF (CHARGD) PHEP(5,NHEP+4)=ZERO C---First Final parton: quark (or J/psi) in Boson-Gluon Fusion C--- quark or antiquark in QCD Compton PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI) PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI) PHEP(3,NHEP+5)=Q1*COSTHE PHEP(4,NHEP+5)=E1 PHEP(5,NHEP+5)=MF1 C---Second Final parton: antiquark in Boson-Gluon Fusion C--- gluon in QCD Compton PHEP(1,NHEP+6)=-PHEP(1,NHEP+5) PHEP(2,NHEP+6)=-PHEP(2,NHEP+5) PHEP(3,NHEP+6)=-PHEP(3,NHEP+5) PHEP(4,NHEP+6)=E2 PHEP(5,NHEP+6)=MF2 C---Boost to lepton-hadron CM frame PEP(1) = PHEP(1,NHEP+1) PEP(2) = PHEP(2,NHEP+1) PEP(3) = PHEP(3,NHEP+1) + PPROT PEP(4) = PHEP(4,NHEP+1) + EPROT CALL HWUMAS (PEP) DO I=1,6 CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I)) ENDDO CALL HWULOF (PEP,PROTON,PROTON) CALL HWULOF (PEP,PGAMMA,PGAMMA) C---Rotation around y-axis to align lepton beam with z-axis COSPHI = PHEP(3,NHEP+1) / & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 ) SINPHI = PHEP(1,NHEP+1) / & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 ) DO I=1,3 DO J=1,3 ROT(I,J)=ZERO ENDDO ENDDO ROT(1,1) = COSPHI ROT(1,3) = -SINPHI ROT(2,2) = ONE ROT(3,1) = SINPHI ROT(3,3) = COSPHI DO I=1,6 CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I)) ENDDO CALL HWUROF (ROT,PROTON,PROTON) CALL HWUROF (ROT,PGAMMA,PGAMMA) C---Boost to the LAB frame ICMF=3 DO I=1,6 CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I)) ENDDO CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON) CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA) C---Random azimuthal rotation CALL HWRAZM (ONE,COSAZI,SINAZI) DO I=1,3 DO J=1,3 ROTAZI(I,J)=ZERO ENDDO ENDDO ROTAZI(1,1) = COSAZI ROTAZI(1,2) = SINAZI ROTAZI(2,1) = -SINAZI ROTAZI(2,2) = COSAZI ROTAZI(3,3) = ONE DO I=1,6 CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I)) ENDDO CALL HWUROF (ROTAZI,PROTON,PROTON) CALL HWUROF (ROTAZI,PGAMMA,PGAMMA) 999 RETURN END CDECK ID>, HWHBRN. *CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi *-- Author : Giovanni Abbiendi & Luca Stanco C----------------------------------------------------------------------- SUBROUTINE HWHBRN (IFGO) C---------------------------------------------------------------------- C Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the C corresponding Jacobian factor AJACOB C Fill the logical vector INSIDE to tag contributing subprocesses C to the cross-section C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' LOGICAL IFGO DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB, & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT, & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC, & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX, & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18), & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP, & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1 INTEGER LEP INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG LOGICAL CHARGD,INCLUD(18),INSIDE(18) EXTERNAL HWRUNI,HWRGEN,HWUPCM SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF, & YMIN,YMAX,WMIN,WMIF COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE EQUIVALENCE (EMW,RMASS(198)) C IFGO = .FALSE. IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) C---Initialization IF (FSTWGT.OR.IHAD.NE.2) THEN ME = RMASS(IDHW(1)) MP = RMASS(IDHW(IHAD)) RS = PHEP(5,3) SMA = RS**2-ME**2-MP**2 PINC = HWUPCM(RS,ME,MP) C---Charged current IF (CHARGD) THEN ML=RMASS(IDHW(1)+1) YMAX = ONE - TWO*ML*MP / SMA YMAX = MIN(YMAX,YBMAX) MREMIN=MP IF (LEP.EQ.1) THEN MF1=RMASS(IFLAVD) MF2=RMASS(IFLAVU) ELSE MF1=RMASS(IFLAVU) MF2=RMASS(IFLAVD) ENDIF SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 + + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2) EMLMIN=MAX(EMMIN,SQRT(SHMIN)) EMLMAX=MIN(EMMAX,RS-ML-MREMIN) DEBUG=1 IF (EMLMIN.GT.EMLMAX) GOTO 888 WMIN=EMLMIN+MREMIN PLMAX=HWUPCM(RS,ML,WMIN) YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+ + PINC*PLMAX)/SMA YMIN = MAX(YMIN,YBMIN) DEBUG=2 IF (YMIN.GT.YMAX) GOTO 888 ELSE C---Neutral current ML = ME YMAX = ONE - TWO*ML*MP / SMA YMAX = MIN(YMAX,YBMAX) DO I=1,18 YMIF(I)=ZERO EMMIF(I)=ZERO EMMAF(I)=ZERO WMIF(I)=ZERO IF (I.LE.8) THEN C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d MREMIF(I)=MP IF (I.LE.6) THEN MFIN1(I)=RMASS(I) MFIN2(I)=RMASS(I+6) ELSE MFIN1(I)=RMASS(I-6) MFIN2(I)=ZERO ENDIF ELSE C---QCD Compton with struck non-valence parton MREMIF(I)=MP+RMASS(I-6) MFIN1(I)=RMASS(I-6) MFIN2(I)=ZERO ENDIF ENDDO IF (IFL.EQ.164) THEN C---J/Psi MFIN1(7)=RMASS(164) MFIN2(7)=ZERO ENDIF C---y boundaries for different flavours and processes DO 100 I=IMIN,IMAX IF (INCLUD(I)) THEN MF1=MFIN1(I) MF2=MFIN2(I) MREMIN=MREMIF(I) SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 + + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2) EMMIF(I) = MAX(EMMIN,SQRT(SHMIN)) EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN) IF (EMMIF(I).GT.EMMAF(I)) THEN INCLUD(I)=.FALSE. CALL HWWARN('HWHBRN',3) GOTO 100 ENDIF WMIF(I) = EMMIF(I)+MREMIF(I) WMIN = WMIF(I) PLMAX = HWUPCM(RS,ML,WMIN) YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+ + PINC*PLMAX)/SMA IF (YMIF(I).GT.YMAX) THEN INCLUD(I)=.FALSE. CALL HWWARN('HWHBRN',4) GOTO 100 ENDIF ENDIF 100 CONTINUE C---considering the largest boundaries EMLMIN=EMMIF(IMIN) EMLMAX=EMMAF(IMIN) IF (IPROO.EQ.3) THEN EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6)) EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6)) ENDIF DEBUG=3 IF (EMLMIN.GT.EMLMAX) GOTO 888 YMIN=YMIF(IMIN) IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6)) YMIN = MAX(YMIN,YBMIN) DEBUG=4 IF (YMIN.GT.YMAX) GOTO 888 WMIN = WMIF(IMIN) MREMIN = MREMIF(IMIN) MF1=MFIN1(IMIN) MF2=MFIN2(IMIN) IF (IPROO.EQ.3) THEN WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6)) MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6)) ENDIF ENDIF ENDIF C---Random generation in largest phase space Y=ZERO Q2=ZERO SHAT=ZERO Z=ZERO PHI=ZERO AJACOB=ZERO C---y generation IF (.NOT.CHARGD) THEN IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN SRY0 = SQRT(YMIN) SRY1 = SQRT(YMAX) SRY = HWRUNI(0,SRY0,SRY1) Y = SRY**2 YJAC = TWO*SRY*(SRY1-SRY0) ELSEIF (IFL.EQ.6) THEN Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2)) YJAC = HALF * (YMAX**2-YMIN**2) / Y ELSEIF (IFL.EQ.164) THEN C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon C Approximation 10 NTRY=0 20 NTRY=NTRY+1 IF (NTRY.GT.NETRY) THEN CALL HWWARN('HWHBRN',50) GOTO 10 ENDIF Y = (YMIN/YMAX)**HWRGEN(1)*YMAX IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20 YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN) & +HALF*(YMAX**2-YMIN**2)) ENDIF ELSE IF (IPRO.EQ.5) THEN Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX))) YJAC = Y * LOG(YMAX/YMIN) ELSE Y = HWRUNI(0,YMIN,YMAX) YJAC = YMAX - YMIN ENDIF ENDIF C---Q**2 generation Q2INF = ME**2*Y**2 / (ONE-Y) Q2SUP = MP**2 + SMA*Y - WMIN**2 IF (IFL.EQ.164) THEN Q2INF = MAX(Q2INF,Q2WWMN) Q2SUP = MIN(Q2SUP,Q2WWMX) ELSE Q2INF = MAX(Q2INF,Q2MIN) Q2SUP = MIN(Q2SUP,Q2MAX) ENDIF DEBUG=5 IF (Q2INF .GT. Q2SUP) GOTO 888 C IF (.NOT.CHARGD) THEN IF (IFL.EQ.164) THEN Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP))) Q2JAC = LOG(Q2SUP/Q2INF) ELSEIF (Q2INF.LT.RMASS(4)**2) THEN Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP))) Q2JAC = Q2 * LOG(Q2SUP/Q2INF) ELSE Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP) Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF) ENDIF ELSE EMW2=EMW**2 Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2 Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2)) ENDIF W2 = MP**2 + SMA*Y - Q2 C---s_hat generation SHINF = EMLMIN **2 SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2 DEBUG=6 IF (SHINF .GT. SHSUP) GOTO 888 C IF (IPRO.EQ.91) THEN IF (.NOT.CHARGD) THEN SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP) SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF) ELSE SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP))) SHJAC = SHAT*(LOG(SHSUP/SHINF)) ENDIF ELSE EMW2=EMW**2 IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP) SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF) ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN SHAT = HWRUNI(0,SHINF,SHSUP) SHJAC = SHSUP-SHINF ELSE TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW)) TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW)) SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2 SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN) ENDIF ENDIF DETDSH = ONE/SMA/Y SHJAC=SHJAC*DETDSH RSHAT = SQRT (SHAT) C--- z generation ZMIN = 10E10 ZMAX = -ONE IF (.NOT.CHARGD) THEN DO I=1,18 Q1CM(I) = ZERO ZMIF(I) = ZERO ZMAF(I) = ZERO ENDDO DO 150 I=IMIN,IMAX IF (INCLUD(I)) THEN Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) ) IF (Q1CM(I) .LT. PTMIN) THEN ZMAF(I)=-ONE GOTO 150 ENDIF CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2) GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2 LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 - + 4.D0*MFIN1(I)**2*MFIN2(I)**2 ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT ZMIF(I) = MAX(ZMIF(I),ZERO) ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT ZMAF(I) = MIN(ZMAF(I),ONE) ZMIN = MIN( ZMIN, ZMIF(I) ) ZMAX = MAX( ZMAX, ZMAF(I) ) ENDIF 150 CONTINUE IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX) ELSE Q1 = HWUPCM(RSHAT,MF1,MF2) DEBUG=7 IF (Q1.LT.PTMIN) GOTO 888 CTHLIM = SQRT(ONE-(PTMIN/Q1)**2) GAMMA2 = SHAT+MF1**2-MF2**2 LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2 ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT ZMIN = MAX(ZMIN,1D-6) ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT ZMAX = MIN(ZMAX,ONE-1D-6) ENDIF DEBUG=8 IF (ZMIN .GT. ZMAX) GOTO 888 ZLMIN = LOG(ZMIN/(ONE-ZMIN)) ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN)) ZL = ZLMIN+HWRGEN(0)*ZINT Z = EXP(ZL)/(ONE+EXP(ZL)) ZJAC = Z*(ONE-Z)*ZINT C DEBUG=9 IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR. + (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX)) + GOTO 888 C---Phi generation PHI = HWRUNI(0,ZERO,2*PIFAC) PHIJAC = 2 * PIFAC IF (IFL.EQ.164) PHIJAC=ONE C AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC C IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999 C---contributing subprocesses: filling of logical vector INSIDE DO I=1,18 INSIDE(I)=.FALSE. Q2MAF(I)=ZERO EMMAWF(I)=ZERO ENDDO DO 200 I=IMIN,IMAX IF (INCLUD(I)) THEN IF ( Y.LT.YMIF(I) ) GOTO 200 C Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2 Q2MAF(I) = MIN( Q2MAF(I), Q2MAX) IF (Q2INF .GT. Q2MAF(I)) GOTO 200 IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200 C EMMAWF(I) = SQRT(W2) - MREMIF(I) EMMAWF(I) = MIN( EMMAWF(I), EMLMAX ) C IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200 IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200 C IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200 IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200 INSIDE(I)=.TRUE. ENDIF 200 CONTINUE 999 RETURN 888 EVWGT=ZERO C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE C CALL HWWARN('HWHBRN',DEBUG) IFGO = .TRUE. END CDECK ID>, HWHBSG. *CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi *-- Author : Giovanni Abbiendi & Luca Stanco C---------------------------------------------------------------------- SUBROUTINE HWHBSG C---------------------------------------------------------------------- C Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI) C Scale for structure functions and alpha_s selected by BGSHAT C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA, & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT, & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN, & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3, & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U, & MREMIN,POL,CCOL,ETA INTEGER LEP INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS LOGICAL CHARGD,INCLUD(18),INSIDE(18) EXTERNAL HWUALF,HWUAEM COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE C IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) C---set masses IF (CHARGD) THEN MREMIN=MP IF (LEP.EQ.1) THEN MF1=RMASS(IFLAVD) MF2=RMASS(IFLAVU) ELSE MF1=RMASS(IFLAVU) MF2=RMASS(IFLAVD) ENDIF ELSE IS=IFL IF (IFL.EQ.164) IS=IQK MREMIN = MREMIF(IS) MF1 = MFIN1(IS) MF2 = MFIN2(IS) ENDIF C---choose subprocess scale IF (BGSHAT) THEN EMSCA = RSHAT ELSE S=SHAT+Q2 IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2 T=-S*Z U=-S-T IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2 EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2)) IF (IFL.EQ.164) EMSCA=SQRT(-U) ENDIF ALPHAS = HWUALF(1,EMSCA) IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) THEN CALL HWWARN('HWHBSG',51) GOTO 888 ENDIF C---structure functions ETA = (SHAT+Q2)/SMA/Y IF (ETA.GT.ONE) ETA=ONE CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2) XG = Q2/(SHAT + Q2) SG = ETA*SMA IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888 C IF (IFL.EQ.164) GOTO 200 C C---Electroweak couplings ALPHA=HWUAEM(-Q2) IF (CHARGD) THEN POL = PPOLN(3) - EPOLN(3) DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 * + Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) * + (ONE + POL) DLQ(2)=ZERO DLQ(3)=DLQ(1) ELSE IQ=MOD(IFL-1,6)+1 ILEPT=MOD(IDHW(1)-121,6)+11 CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1)) ENDIF C IF (IFL.LE.6) THEN C---For Boson-Gluon Fusion PDENS = SFUN(13)/ETA CCOL = HALF MSUM = (MF1**2 + MF2**2) / (Y*SG) MDIF = (MF1**2 - MF2**2) / (Y*SG) MPRO = MF1*MF2 / (Y*SG) C FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0 GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF IF ( FFUN .LT. ZERO ) FFUN = ZERO H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF & -MSUM)) / (Z*(1.D0-Z))**2 C H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z)) C H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG & -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2 & +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG & +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG & -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2 C H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z)) C H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM)) & / (Z*(1.D0-Z))**2 C H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z)) C H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG + -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2 C H22 = (-32.D0*MPRO) / (Z*(1.D0-Z)) C G11 = -2.D0*H11 + FFUN*H14 G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 ) G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 ) G1B = FFUN*H14 G21 = -2.D0*H21 G22 = H22 G3 = H41 - GFUN*H43 GC = SQRT( XG*FFUN ) * (-2.D0*XG*H43 ) ELSE C---for QCD Compton, massless matrix element PDENS = SFUN(IFL-6)/ETA CCOL = CFFAC FFUN = XG*(ONE-XG)*Z*(ONE-Z) GFUN = (ONE-XG)*(ONE-Z)+XG*Z G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE)) G12 = 64.D0*XG**2*Z+TWO*XG*G11 G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z)) G1B = 16.D0*XG*Z G3 = -16.D0*(ONE-XG)*(ONE-Z)+G11 GC = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z)) G21 = ZERO G22 = ZERO ENDIF C A11 = XG * Y**2 * G11 + (1.D0-Y) * G12 & - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A * COS( PHI ) & + 2.D0 * XG * (1.D0-Y) * G1B * COS( 2.D0*PHI ) C A12 = XG * Y**2 * G21 + (1.D0-Y) * G22 C A44 = XG * Y * (2.D0-Y) * G3 & - 2.D0 * Y * SQRT( 1.D0-Y ) * GC * COS( PHI ) C IF ( Y*Q2**2 .LT. 1D-38 ) THEN C---prevent numerical uncertainties in DSIGMA computation DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC) & *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44) IF ( DSIGMA .LE. ZERO ) GOTO 888 LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2) DSIGMA = EXP (LDSIG) ELSE DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL & * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44) & / (16.D0*PIFAC*Y*Q2**2) ENDIF IF (DSIGMA.LT.ZERO) GOTO 888 RETURN C 200 CONTINUE C--- J/psi production ALPHA = HWUAEM(-Q2) GAMMA = 4.8D-6 PDENS = SFUN(13)/ETA AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA) BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2) CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2* & ((ONE-XG)*Y*SG-RMASS(164)**2)**2* & ((Z-ONE)*Y*SG-RMASS(164)**2)**2) DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2* & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2) DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS IF (DSIGMA.LT.ZERO ) GOTO 888 RETURN 888 DSIGMA=ZERO END CDECK ID>, HWHDIS. *CMZ :- -26/04/91 14.55.44 by Federico Carminati *-- Author : Giovanni Abbiendi & Luca Stanco C---------------------------------------------------------------------- SUBROUTINE HWHDIS C---------------------------------------------------------------------- C DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2, & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC, & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA, & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS, & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP LOGICAL CHARGD EXTERNAL HWRGEN,HWRUNI,HWUPCM SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2, & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD, & ILEPT,DCHRG,DNEUT,LEP IQK=MOD(IPROC,10) IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) IF (FSTWGT.OR.IHAD.NE.2) THEN C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES) C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME MLEP=PHEP(5,1) MHAD=PHEP(5,IHAD) S=PHEP(5,3)**2 SMA=S-MLEP**2-MHAD**2 PCM=HWUPCM(SQRT(S),MLEP,MHAD) C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN LEP=1 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN LEP=-1 ELSE CALL HWWARN('HWHDIS',500) ENDIF DCHRG=FLOAT(MOD(IDHW(1) ,2)) DNEUT=FLOAT(MOD(IDHW(1)+1,2)) ILEPT=MOD(IDHW(1)-121,6)+11 C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons DLEFT=MAX(LEP,0) DRGHT=MAX(-LEP,0) CHARGD=MOD(IPROC,100)/10.EQ.1 C---Evaluate constant factor in cross section and C find and store scattered lepton identity IF (CHARGD) THEN IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN WRITE(6,5) CALL HWWARN('HWHDIS',501) 5 FORMAT(1X,'WARNING: Cross-section is zero for the', & ' specified lepton helicity') ENDIF FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC & /(SWEIN*RMASS(198)**2)**2 IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT) ELSE FACT=GEV2NB*TWO*PIFAC IDSCAT=IDHW(1) ENDIF MLSCAT=RMASS(IDSCAT) C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT C PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4 C AND D(SIGMA)/D(X) LIKE B1+B2/X A1=0.5 A2=0.5 A3=1. B1=0.1 B2=1. ENDIF IF (GENEV) THEN C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION C ALREADY FOUND) PRAN=SIGMA*HWRGEN(0) IF (CHARGD) THEN C---CHARGED CURRENT PROCESS IF (IQK.EQ.0) THEN C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER) PROB=ZERO DO 10 I=1,6 DUP=MOD(I+1,2) DWN=MOD(I ,2) PROB=PROB+EFACT* & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2) & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1) & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP) & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1)) IF (PROB.GE.PRAN) GOTO 20 10 CONTINUE I=6 20 IQK=I ENDIF DUP=MOD(IQK+1,2) DWN=MOD(IQK ,2) IQKIN=IQK IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0) & .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6 C---FIND FLAVOUR OF THE OUTGOING QUARK PRAN=HWRGEN(0) PROB=ZERO IF (DUP.EQ.ONE) THEN DO 30 I=1,3 PROB=PROB+VCKM(IQK/2,I) IF (PROB.GE.PRAN) GOTO 40 30 CONTINUE I=3 40 IQKOUT=2*I-1 IF (IQKIN.GT.6) IQKOUT=IQKOUT+6 ELSE DO 50 I=1,3 PROB=PROB+VCKM(I,(IQK+1)/2) IF (PROB.GE.PRAN) GOTO 60 50 CONTINUE I=3 60 IQKOUT=2*I IF (IQKIN.GT.6) IQKOUT=IQKOUT+6 ENDIF ELSE C---NEUTRAL CURRENT PROCESS IF (IQK.NE.0) THEN IQKIN=IQK PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+ & FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1)) IF (PROB.LT.PRAN) IQKIN=IQK+6 ELSE C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER) PROB=ZERO SIG=ONE DO 70 I=1,12 IF (I.GT.6) SIG=-ONE PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+ & FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1)) IF (PROB.GE.PRAN) GOTO 80 70 CONTINUE I=12 80 IQKIN=I ENDIF IQKOUT=IQKIN ENDIF IDN(1)=IDHW(1) IDN(2)=IQKIN IDN(3)=IDSCAT IDN(4)=IQKOUT ICO(1)=1 ICO(2)=4 ICO(3)=3 ICO(4)=2 XX(1)=1. XX(2)=XBJ C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE C EVENT IS KILLED. PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD))) EQ=HALF*(PA+RMASS(IDN(2))**2/PA) PZQ=-(PA-EQ) SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2 PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2))) PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4))) IF (PCMLQ.LT.ZERO) THEN CALL HWWARN('HWHDIS',101) GOTO 999 ELSEIF (PCMLQ.EQ.ZERO) THEN COSTH=ZERO ELSE COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2) & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ) ENDIF IF (ABS(COSTH).GT.ONE) THEN CALL HWWARN('HWHDIS',102) GOTO 999 ENDIF IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) ELSE EVWGT=ZERO IF (CHARGD) THEN C---CHOOSE X,Y (CC PROCESS) YMIN=MAX(YBMIN,Q2MIN/SMA) YMAX=MIN(YBMAX,ONE) IF (YMIN.GT.YMAX) GOTO 999 Y=HWRUNI(0,YMIN,YMAX) XXMIN=Q2MIN/S/Y XXMAX=MIN(Q2MAX/SMA/Y,ONE) IF (XXMIN.GT.XXMAX) GOTO 999 XBJ=HWRUNI(0,XXMIN,XXMAX) Q2=XBJ*Y*(S-MLEP**2-MHAD**2) JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ ELSE C---CHOOSE X,Q**2 (NC PROCESS) Q2SUP=MIN(Q2MAX,SMA*YBMAX) IF (Q2MIN.GT.Q2SUP) GOTO 999 SAMP=(A1+A2+A3)*HWRGEN(0) IF (SAMP.LE.A1) THEN Q2=HWRUNI(0,Q2MIN,Q2SUP) ELSEIF (SAMP.LE.(A1+A2)) THEN Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP))) ELSE Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP) ENDIF Q2JAC=(A1+A2+A3)/ & (A1/(Q2SUP-Q2MIN) & +A2/LOG(Q2SUP/Q2MIN)/Q2 & +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2) XXMIN=Q2/SMA/YBMAX XXMAX=ONE IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE) IF (XXMIN.GT.XXMAX) GOTO 999 SAMP=(B1+B2)*HWRGEN(0) IF (SAMP.LE.B1) THEN XBJ=HWRUNI(0,XXMIN,XXMAX) ELSE XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX))) ENDIF XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ) Y=Q2/(S-MLEP**2-MHAD**2)/XBJ JACOBI=Q2JAC*XXJAC ENDIF C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT C RETURN WITH WEIGHT EQUAL TO ZERO. W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ) IF (W.LT.WHMIN) RETURN PCMEP=PCM PCMLW=HWUPCM(SQRT(S),MLSCAT,W) IF (PCMLW.LT.ZERO) THEN EVWGT=ZERO RETURN ELSEIF (PCMLW.EQ.ZERO) THEN COSPHI=ZERO ELSE COSPHI= & (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2) & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW) ENDIF IF (ABS(COSPHI).GT.ONE) THEN EVWGT=ZERO RETURN ENDIF C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS. EMSCA=SQRT(Q2) CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2) C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD DO 90 I=1,12 90 IF (W.LT.2*RMASS(I)) DISF(I,1)=0 C---EVALUATE DIFFERENTIAL CROSS SECTION IF (CHARGD) THEN PROP=RMASS(198)**2/(Q2+RMASS(198)**2) EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ OMY2=(ONE-Y)**2 SIGMA=ZERO DO 100 I=1,6 DUP=MOD(I+1,2) DWN=MOD(I ,2) IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100 SIGMA=SIGMA+EFACT* & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2) & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1) & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP) & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1)) 100 CONTINUE ELSE EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2 YPLUS=ONE+(ONE-Y)**2 YMNUS=ONE-(ONE-Y)**2 DO 110 I=1,6 CALL HWUCFF(ILEPT,I,-Q2,AF(1,I)) AF(1,I+6)=AF(1,I) AF(3,I+6)=AF(3,I) 110 CONTINUE SIGMA=ZERO DO 200 I=1,6 IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200 SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+ & FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1))) 200 CONTINUE ENDIF C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR EVWGT=SIGMA*JACOBI IF (EVWGT.LT.ZERO) EVWGT=ZERO ENDIF 999 RETURN END CDECK ID>, HWHDYP. *CMZ :- -18/05/99 12.41.07 by Mike Seymour *-- Author : Bryan Webber, Ian Knowles and Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHDYP C----------------------------------------------------------------------- C Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME) C Z' exchange. Lepton universality is assumed for photon and Z, and C for Z' if no lepton flavour is specified. C MEAN EVWGT = SIGMA IN NB C C Modified 16/01/01 by BRW to implement Peter Richardson's C fix for bug in lepton mass effects on branching ratio C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ, & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN, & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2, & ID3,ID4,JF EXTERNAL HWRGEN,HWRUNI,HWUAEM SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ, & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF PARAMETER (EPS=1.D-9) SAVE IADD DATA IADD/0,6,6,0/ IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE IF (FSTWGT) THEN C Set limits for which particles to include JLMN=1 JLMX=0 JQMN=1 JQMX=0 IMODE=MOD(IPROC,100) IF (IMODE.EQ.0) THEN JQMN=1 JQMX=6 ELSEIF (IMODE.LE.10) THEN JQMN=IMODE JQMX=IMODE ELSEIF (IMODE.EQ.50) THEN JLMN=11 JLMX=16 ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN JLMN=IMODE-40 JLMX=IMODE-40 ELSEIF (IMODE.EQ.99) THEN JQMN=1 JQMX=6 JLMN=11 JLMX=16 ELSE CALL HWWARN('HWHDYP',500) ENDIF C Set up parameters for importance sampling: C sum of power law and two Breit-Wigners (relative weights C1,C2,C3) C1=ONE C2=ONE C3=ZERO IF (ZPRIME) C3=ONE IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501) IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502) IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503) QPOW=-EMPOW+1 RPOW=1/QPOW EMSQZ=RMASS(200)**2 EMGMZ=RMASS(200)*GAMZ A01=EMMIN**QPOW A1=(EMMAX**QPOW-A01)/C1 A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ) A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2 IF (C3.GT.ZERO) THEN EMSQZP=RMASS(202)**2 EMGMZP=RMASS(202)*GAMZP A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP) A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3 ENDIF ENDIF EVWGT=0. C Select a mass for the produced pair CRAN=(C1+C2+C3)*HWRGEN(1) IF (CRAN.LT.C1) THEN C Use power law EMSCA=(A01+A1*CRAN)**RPOW QSQ=EMSCA**2 ELSEIF (CRAN.LT.C1+C2) THEN C Use Z Breit-Wigner CRAN=CRAN-C1 QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN) EMSCA=SQRT(QSQ) ELSE C Use Z' Breit-Wigner CRAN=CRAN-C1-C2 QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN) EMSCA=SQRT(QSQ) ENDIF EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1 EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2 IF (C3.GT.ZERO) THEN EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3 EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3) ELSE EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2) ENDIF C Select initial momentum fractions XXMIN=QSQ/PHEP(5,3)**2 XLMIN=LOG(XXMIN) CALL HWSGEN(.TRUE.) FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN $ /(3*NCOLO*EMSCA**3) C Store cross-section coefficients DO 50 IQ=1,6 DO 30 JQ=JQMN,JQMX IF (EMSCA.GT.2.*RMASS(JQ)) THEN CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ)) ELSE CALL HWVZRO(7,CQF(1,IQ,JQ)) ENDIF 30 CONTINUE DO 40 JL=JLMN,JLMX IF (EMSCA.GT.2.*RMASS(JL+110)) THEN CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL)) ELSE CALL HWVZRO(7,CQF(1,IQ,JL)) ENDIF 40 CONTINUE 50 CONTINUE ENDIF C HCS=0. DO 90 I=1,2 C I=1 quark first, I=2 anti-quark first DO 80 IQ=1,6 ID1=IQ+IADD(1,I) ID2=IQ+IADD(2,I) IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2) C Quark final states DO 60 JQ=JQMN,JQMX ID3=JQ ID4=JQ+6 IF (IQ.EQ.JQ) THEN HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,50) GOTO 99 ENDIF ELSE HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,50) GOTO 99 ENDIF ENDIF 60 CONTINUE C Lepton final states DO 70 JL=JLMN,JLMX ID3=110+JL ID4=ID3+6 HCS=HCS+FACTR*CQF(1,IQ,JL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF 70 CONTINUE 80 CONTINUE 90 CONTINUE EVWGT=HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=200 IF (ID3.LE.6) THEN JF=JQ ELSE JF=JL ENDIF C Select polar angle from distribution: C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH) IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN EXTRA=TWO*QFCH(ID3)**4/NCOLO ELSE EXTRA=0 ENDIF PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF)) 100 COSTH=HWRUNI(0,-ONE,ONE) PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH & +EXTRA*(ONE+COSTH) IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100 IF (ID1.GT.ID2) COSTH=-COSTH IDCMF=200 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHDYQ. *CMZ :- -14/03/01 09:03:25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS) C----------------------------------------------------------------------- C Drell-Yan production with a q qbar pair C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2) LOGICAL FSTCLL,MASS EXTERNAL HWRGEN COMMON/HWHZBC/G SAVE MQ,MG SAVE MAP,QCFL,GCFL DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/ DATA QCFL/2413,3142,4123,2341/ DATA GCFL/2413,4123/ IF(GENEV) THEN RCS = HCS*HWRGEN(1) ELSE C--to the initalisation IF(FSTCLL) THEN C--G(I,1) is the right charge and G(I,2) is the left charge DO I=1,12 G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1) G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1) ENDDO FSTCLL = .FALSE. ENDIF C--identify the Z decay product IDZ = IDP(5) IF(IDZ.GT.6) IDZ = IDZ-114 C--calculate the matrix elements IF(MASS) THEN C--massive case CALL HWH2MQ(IQ,IDZ,MG,MQ) ELSE C--massless case CALL HWH2M0(IQ,IDZ,MG,MQ) ENDIF ENDIF C--multiply the matrix elements by the PDF's to obtain the cross section HCS = ZERO IDP(3) = IQ IDP(4) = IQ+6 C--first the qqbar initial states DO I=1,5 IDP(1) = I IDP(2) = IDP(1)+6 DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2) DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1) DO ORD=1,2 DO IFL=1,2 IFLOW = QCFL(IFL,ORD) HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0 IF(GENEV.AND.HCS.GT.RCS) RETURN ENDDO ENDDO ENDDO C--then the gluon gluon inital state IDP(1) = 13 IDP(2) = 13 DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2) DO IFL=1,2 IFLOW = GCFL(IFL) HCS = HCS+DIST(1)*MG(IFL)/256.0D0 IF(GENEV.AND.HCS.GT.RCS) RETURN ENDDO END CDECK ID>, HWHEGG. *CMZ :- -19/03/92 10.13.56 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHEGG C---------------------------------------------------------------------- C HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW C MEAN EVENT WEIGHT = CROSS-SECTION IN NB C AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM C AND COS(THETA) IN CENTRE-OF-MASS SYSTEM C AND TIMES BRANCHING FRACTION IF WW C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT, & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF, & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2), & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2), & COLFAC INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM LOGICAL HWRLOG EXTERNAL HWRGEN,HWULDO,HWRLOG SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT, & PCF,PCM,Z,PCMAC,NADD IF (IERROR.NE.0) RETURN C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX IF (FSTWGT) THEN EMLMIN=EMMIN EMLMAX=EMMAX ENDIF IF (.NOT.GENEV) THEN C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION EVWGT=0 C-----FIND FINAL STATE PARTICLES IHPRO=MOD(IPROC,100) IF (IHPRO.EQ.0) THEN ID=1 NQ=6 COLFAC=FLOAT(NCOLO) NADD=6 ELSEIF (IHPRO.LE.6) THEN ID=IHPRO NQ=1 COLFAC=FLOAT(NCOLO) NADD=6 Q=QFCH(ID) ELSEIF (IHPRO.LE.9) THEN ID=119+2*(IHPRO-6) NQ=1 COLFAC=1. NADD=6 Q=QFCH(ID-110) ELSEIF (IHPRO.LE.10) THEN ID=198 NQ=1 NADD=1 ELSE CALL HWWARN('HWHEGG',200) ENDIF C-----SPLIT ELECTRONS TO PHOTONS NHEP=3 GAMWT=1 S=2*HWULDO(PHEP(1,1),PHEP(1,2)) ROOTS=SQRT(S) EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN)) EMCMAX=MIN(EMLMAX,ROOTS) IF (EMCMIN.GT.EMCMAX) RETURN ZMIN=EMCMIN**2/S ZMAX=1-PHEP(5,1)/PHEP(4,1) IF (ZMIN.GT.ZMAX) RETURN CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.) Z(1)=PHEP(4,NHEP-1)/PHEP(4,1) ZMIN=EMCMIN**2/(Z(1)*S) ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2)) IF (ZMIN.GT.ZMAX) RETURN CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.) Z(2)=PHEP(4,NHEP-1)/PHEP(4,2) EMSCA=PHEP(5,3) SHAT=EMSCA**2 C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2)) & *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2))) PCF(1)=Z(1)*PHEP(5,1) PCF(2)=Z(2)*PHEP(5,2) PCFAC=SQRT(PCF(1)*PCF(2)) PCM(1)=(1-Z(1))*PHEP(4,1) PCM(2)=(1-Z(2))*PHEP(4,2) PCMAC=SQRT(PCM(1)*PCM(2)) PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2))) PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) ) IF (PCMIN.GT.PCMAX) RETURN PLOGMI=(LOG(PCMIN/PCFAC))**2 PLOGMA=(LOG(PCMAX/PCFAC))**2 GAMWT=GAMWT*(PLOGMA-PLOGMI) C-----CALCULATE CROSS-SECTION DO 10 IDL=1,NQ WGT(IDL)=EVWGT IF (IHPRO.EQ.0) THEN ID=IDL Q=QFCH(ID) ENDIF EMSQ=RMASS(ID)**2 X=4*EMSQ/SHAT IF (X.GT.ONE) GOTO 10 BETA=SQRT(1-X) BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA IF (IHPRO.LE.9) THEN EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA & /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG & - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) ) WGT(IDL)=EVWGT ELSE CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR & * GAMWT * (-( X-0.5*X**2)*BLOG & + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) ) ENDIF 10 CONTINUE C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER! GAMWT=ONE ELSE C---GENERATE EVENT C-----CHOOSE PT OF THE CMF PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI)) C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT NTRY=0 20 IGAM=1 IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2 JGAM=3-IGAM C-----CHOOSE ITS PT 30 NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWHEGG',100) GOTO 999 ENDIF QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2) PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2 QT(IGAM)=QT(IGAM)*PCF(IGAM) IF (HWRLOG(1-PROB)) GOTO 30 C-----CHOOSE ITS DIRECTION CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM)) C-----CALCULATE THE OTHER PHOTON'S PT QX(JGAM)=PTCMF-QX(IGAM) QY(JGAM)= -QY(IGAM) QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2) IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20 C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS CALL HWRAZM(ONE,PX,PY) IF (PX.EQ.ZERO) PX=1D-20 QX(1)=(QX(1)*PX -QY(1)*PY) QY(1)=(QY(1) +QX(1)*PY)/PX QX(2)=(QX(2)*PX -QY(2)*PY) QY(2)=(QY(2) +QX(2)*PY)/PX C-----RECONSTRUCT MOMENTA IF (QT(IGAM).GT.QT(JGAM)) THEN IGAM=3-IGAM JGAM=3-JGAM ENDIF DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2)) C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES A=S*(S*Z(JGAM)+QT(JGAM)**2) B=S*DOT*(1+Z(JGAM)) C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2 IF (B**2.LT.4*A*C) GOTO 20 ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A) IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20 ZZ(JGAM)=1-Z(JGAM) C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM)) & *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM)) IF (HWRLOG(1-PROB)) GOTO 20 C-------RECONSTRUCT ALL OTHER VARIABLES DO 40 I=1,2 IGAM=2*I+3 PHEP(1,IGAM)=QX(I) PHEP(2,IGAM)=QY(I) PHEP(4,IGAM)=ZZ(I)*PHEP(4,I) PHEP(5,IGAM)=RMASS(IDHW(IGAM)) C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20 PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2- & QT(I)**2),PHEP(3,IGAM)) CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1)) CALL HWUMAS(PHEP(1,IGAM-1)) 40 CONTINUE C-----TIDY UP EVENT RECORD NHEP=NHEP+1 IDHW(NHEP)=IDHW(3) IDHEP(NHEP)=IDHEP(3) ISTHEP(NHEP)=110 CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP)) CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3)) CALL HWUMAS(PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,3)) JMOHEP(1,NHEP)=4 JMOHEP(2,NHEP)=6 JMOHEP(1,3)=0 JMOHEP(2,3)=0 C-----CHOOSE FINAL STATE QUARK IF (IHPRO.EQ.0) THEN RWGT=HWRGEN(2)*EVWGT ID=1 DO 50 IDL=1,NQ IF (RWGT.GT.WGT(IDL)) ID=IDL+1 50 CONTINUE EMSQ=RMASS(ID)**2 X=4*EMSQ/SHAT BETA=SQRT(1-X) ENDIF C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ) TMIN=-SHAT/2 TMAX=-SHAT/2*(1-BETA*CTMAX) TRAT=TMAX/TMIN NTRY=0 IF (IHPRO.LE.9) THEN C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T 60 NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWHEGG',101) GOTO 999 ENDIF T=TRAT**HWRGEN(3)*TMIN U=-T-SHAT C-------REWEIGHT TO CORRECT DISTRIBUTION DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2 & +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U) & +(T*U-2*EMSQ*(U+2*EMSQ))/U**2 PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2) IF (HWRLOG(1-PROB)) GOTO 60 ELSE C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2 70 NTRY=NTRY+1 IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWHEGG',102) GOTO 999 ENDIF T=TMAX/(1-(1-TRAT)*HWRGEN(4)) U=-T-SHAT C-------REWEIGHT TO CORRECT DISTRIBUTION DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ) & + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2 PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2) IF (HWRLOG(1-PROB)) GOTO 70 ENDIF C-----SYMMETRIZE IN T,U IF (HWRLOG(HALF)) T=U C-----FILL EVENT RECORD COSTH=(1+2*T/SHAT)/BETA PC=0.5*BETA*PHEP(5,NHEP) PHEP(5,NHEP+1)=RMASS(ID) PHEP(5,NHEP+2)=RMASS(ID) CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2), & PC,COSTH,.TRUE.) DO 80 I=1,2 IHEP=NHEP+I JHEP=NHEP+3-I ISTHEP(IHEP)=190 IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I IDHW(IHEP)=ID+NADD*(I-1) IDHEP(IHEP)=IDPDG(IDHW(IHEP)) JDAHEP(I,NHEP)=IHEP JMOHEP(1,IHEP)=NHEP JMOHEP(2,IHEP)=JHEP JDAHEP(2,IHEP)=JHEP IF (IHPRO.EQ.10) THEN RHOHEP(1,IHEP)=0.3333 RHOHEP(2,IHEP)=0.3333 RHOHEP(3,IHEP)=0.3333 ENDIF 80 CONTINUE NHEP=NHEP+2 ENDIF 999 RETURN END CDECK ID>, HWHEGW. *CMZ :- -26/04/91 10.18.56 by Bryan Webber *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHEGW C---------------------------------------------------------------------- C W + GAMMA --> FF'BAR : MEAN EVWGT = CROSS SECTION IN NANOBARN C BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB, & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT INTEGER LEP INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO EXTERNAL HWRGEN SAVE LEPFIN,ID1,ID2 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE IQK=MOD(IPROC,10) CHARGD=.TRUE. IF(GENEV) THEN C IDHW(4)=IDHW(1) IDHW(5)=59 IDHW(6)=15 IDHW(7)=LEPFIN IDHW(8)=ID1 IDHW(9)=ID2 DO 1 I=4,9 1 IDHEP(I)=IDPDG(IDHW(I)) C IFLAVD=ID1 IFLAVU=ID2-6 C ISTHEP(4)=111 ISTHEP(5)=112 ISTHEP(6)=110 ISTHEP(7)=113 ISTHEP(8)=114 ISTHEP(9)=114 C JMOHEP(1,4)=6 JMOHEP(2,4)=7 JMOHEP(1,5)=6 JMOHEP(2,5)=5 JMOHEP(1,6)=4 JMOHEP(2,6)=5 JMOHEP(1,7)=6 JMOHEP(2,7)=4 JMOHEP(1,8)=6 JMOHEP(2,8)=9 JMOHEP(1,9)=6 JMOHEP(2,9)=8 JDAHEP(1,4)=0 JDAHEP(2,4)=7 JDAHEP(1,5)=0 JDAHEP(2,5)=5 JDAHEP(1,6)=7 JDAHEP(2,6)=9 JDAHEP(1,7)=0 JDAHEP(2,7)=4 JDAHEP(1,8)=0 JDAHEP(2,8)=9 JDAHEP(1,9)=0 JDAHEP(2,9)=8 C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE C---Persuade HWHBKI that the gluon is actually a photon... GMASS=RMASS(13) RMASS(13)=0 CALL HWHBKI RMASS(13)=GMASS C---put the other outgoing lepton in as well IDHW(10)=IDHW(2) IDHEP(10)=IDPDG(IDHW(10)) ISTHEP(10)=1 JMOHEP(1,10)=2 JMOHEP(2,10)=0 JDAHEP(1,10)=0 JDAHEP(2,10)=0 JDAHEP(1,2)=5 JDAHEP(2,2)=10 CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10)) CALL HWUMAS(PHEP(1,10)) NHEP=10 C C---if antilepton was first, do charge conjugation IF (LEP.EQ.-1) THEN DO 27 I=7,9 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I)) IDHEP(I)=-IDHEP(I) ENDIF 27 CONTINUE ENDIF C C---half the time, do charge conjugation and parity flip IF (HWRGEN(0).GT.HALF) THEN DO 2 I=4,10 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I)) IDHEP(I)=-IDHEP(I) ENDIF PHEP(1,I)=-PHEP(1,I) PHEP(2,I)=-PHEP(2,I) PHEP(3,I)=-PHEP(3,I) 2 CONTINUE JMOHEP(1,10)=3-JMOHEP(1,10) ENDIF C ELSE C EVWGT=ZERO C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON LEP=0 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN LEP=1 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN LEP=-1 ENDIF IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500) C---program only works if beam and target are charge conjugates IF (LEP*(IDHW(2)-IDHW(1)).NE.6) CALL HWWARN('HWHEGW',501) C---program only works for equal energy beams colliding IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503) C C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE C AND THEN INVERTED IF NECESSARY LEPFIN = MIN(IDHW(1),IDHW(2))+1 IF (IQK.LE.2) THEN IFLAVU=2 IFLAVD=1 ID1 = 1 ID2 = 8 ELSEIF (IQK.LE.4) THEN IFLAVU=4 IFLAVD=3 ID1 = 3 ID2 =10 ELSEIF (IQK.LE.6) THEN IFLAVU=6 IFLAVD=5 ID1 = 5 ID2 =12 ELSEIF (IQK.EQ.7) THEN IFLAVU=122 IFLAVD=121 ID1 = 121 ID2 = 128 C---INTERFERENCE TERMS IN EE -> EE NUE NUEB NEGLECTED: SIGMA UNRELIABLE IF (FSTWGT) CALL HWWARN('HWHEGW',1) ELSEIF (IQK.EQ.8) THEN IFLAVU=124 IFLAVD=123 ID1 = 123 ID2 = 130 ELSEIF (IQK.EQ.9) THEN IFLAVU=126 IFLAVD=125 ID1 = 125 ID2 = 132 ELSE CALL HWWARN('HWHEGW',504) ENDIF IF (IQK.GT.0) THEN IF (IQK.LE.6) IQK=0 CALL HWHBRN(IFGO) IF(IFGO) GOTO 999 CALL HWHEGX EVWGT = 2 * DSIGMA * AJACOB IF (EVWGT.LT.ZERO) EVWGT=ZERO ELSE C---SUM OVER QUARK FLAVOURS CALL HWHBRN(IFGO) IF(IFGO) GOTO 999 DO 3 I=1,3 IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN CALL HWHEGX EV(I) = 2 * DSIGMA * AJACOB IF (EV(I).LT.ZERO) EV(I)=ZERO ELSE EV(I)=ZERO ENDIF EVWGT=EVWGT+EV(I) EV(I)=EVWGT IFLAVU=IFLAVU+2 IFLAVD=IFLAVD+2 3 CONTINUE C---CHOOSE QUARK FLAVOUR RV=EV(3)*HWRGEN(1) IF (RV.LT.EV(1)) THEN ID1 = 1 ID2 = 8 ELSEIF (RV.LT.EV(2)) THEN ID1 = 3 ID2 =10 ELSE ID1 = 5 ID2 =12 ENDIF ENDIF ENDIF 999 RETURN END CDECK ID>, HWHEGX. *CMZ :- -17/07/92 16.42.56 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHEGX C----------------------------------------------------------------------- C COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ, & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4), & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI, & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2, & RSHAT INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP LOGICAL CHARGD,INCLUD(18),INSIDE(18) COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF, & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP, & IPROO,CHARGD,INCLUD,INSIDE C---INPUT VARIABLES IF (IERROR.NE.0) RETURN DSIGMA=0 IF (IFLAVU.LE.12) THEN QU=QFCH(MOD(IFLAVU-1,6)+1) QD=QFCH(MOD(IFLAVD-1,6)+1) CFAC=CAFAC ELSE QU=QFCH(MOD(IFLAVU-1,6)+11) QD=QFCH(MOD(IFLAVD-1,6)+11) CFAC=1 ENDIF QE=QFCH(11) QW=+1 EMWSQ=RMASS(198)**2 EMSCA=PHEP(5,3) EMSSQ=EMSCA**2 MUSQ=RMASS(IFLAVU)**2 MDSQ=RMASS(IFLAVD)**2 ETA=(SHAT+Q2)/EMSSQ/Y IF (ETA.GT.ONE) RETURN C---CALCULATE KINEMATIC TERMS G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ) S=0.5*ETA*EMSSQ T=0.5*ETA*EMSSQ*(1-Y) U=0.5*Q2 C1=0.5*ETA*EMSSQ*Y*Z C2=0.5*ETA*EMSSQ*Y*(1-Z) COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2)) IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2 & -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2) COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1 IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1* & (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI))) D2=S-U-D1 F1=D1+C1-G -MDSQ F2=U+T-F1 C---CALCULATE TRACE TERMS CALL HWVZRO(16,D) CALL HWVZRO(16,C) D(1,1)=2*F1*C2*S D(2,2)=2*C1*D2*T D(3,3)=-D1*(2*F2*G-D2*(F1+2*U)) & -D2*F1*(F2+U-D2+F1) & +2*F1*F2*U & -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G)) D(4,4)=2*F1*C2*S D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2) D(1,3)=D1*F2*(-2*F1+U-F2+D1) & +F1*(F2*(D2-2*U)+F1*D2) & +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G)) D(1,4)=-2*F1*(D1+U)*(F2+G) D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1)) & +F1*D2**2 & +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G)) D(2,4)=-D1*F2*(U-F2+D1) & -F1*D2*(U-D1-G-F2) & -G*(U*(F2-U+G)-D1*(F2+U)) D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1)) & +F1*(2*F2*U-D2*(U+F1)) & +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G)) C---REGULATE PROPAGATORS TMAX=EMSSQ-2*G TMIN=PHEP(5,2)**2 A1=2*C1+MDSQ*(G+U)/G A2=2*C2+MUSQ*(G+U)/G B1=(2*U+MUSQ)/(2*G+2*U) B2=(2*U+MDSQ)/(2*G+2*U) I0=LOG(TMAX/TMIN) I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN))) I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN))) I3=(B1*I1-B2*I2)/(B1*A2-B2*A1) I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN)) I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN)) WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ) C---CALCULATE COEFFICIENTS C(1,1)= QU**2/(2*U+EMWSQ)**2 *I5 C(2,2)= QD**2/(2*U+EMWSQ)**2 *I4 C(3,3)= QW**2/(2*U+EMWSQ)**2 *WPROP *I0 C(4,4)= QE**2/(2*S)**2 *WPROP *I0 C(1,2)= 2*QU*QD/(2*U+EMWSQ)**2 *I3 C(1,3)= 2*QW*QU/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I2 C(1,4)= 2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2 C(2,3)= 2*QW*QD/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I1 C(2,4)= 2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1 C(3,4)= 2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP *I0 C---CALCULATE PHOTON STRUCTURE FUNCTION PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA) C---SUM ALL TENSOR CONTRIBUTIONS DO 10 I=1,4 DO 10 J=1,4 10 DSIGMA=DSIGMA + C(I,J)*D(I,J) C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2 C---CALCULATE DIFFERENTIAL CROSS-SECTION DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ) END CDECK ID>, HWHEPA. *CMZ :- -12/10/01 10.05.16 by Peter Richardson *-- Author : Bryan Webber and Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHEPA C----------------------------------------------------------------------- C (Initially polarised) e+e- --> ffbar (f=quark, mu or tau) C If IPROC=107: --> gg, distributed as sum of light quarks. C If fermion flavour specified mass effects fully included. C EVWGT=sig(e+e- --> ffbar) in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR, & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI, & PPHI,SINTH,PCM,PP(5),EWGT INTEGER ID1,ID2,IDF,IQ,IQ1,I EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT DATA Q2LST/0.D0/ IF (GENEV) THEN IF (ID2.EQ.0) THEN C Choose quark flavour PRAN=TQWT*HWRGEN(0) PQWT=0. DO 10 IQ=1,MAXFL PQWT=PQWT+CLQ(1,IQ) IF (PQWT.GT.PRAN) GOTO 11 10 CONTINUE IQ=MAXFL 11 IQ1=MAPQ(IQ) DO 20 I=1,7 20 CLF(I)=CLQ(I,IQ) ELSE IQ1=ID1 ENDIF C Label particles, assign outgoing particle masses IDHW(NHEP+1)=200 IDHEP(NHEP+1)=23 ISTHEP(NHEP+1)=110 IF (ID1.EQ.7) THEN IDHW(NHEP+2)=13 IDHW(NHEP+3)=13 IDHEP(NHEP+2)=21 IDHEP(NHEP+3)=21 PHEP(5,NHEP+2)=RMASS(13) PHEP(5,NHEP+3)=RMASS(13) ELSE IDHW(NHEP+2)=IQ1 IDHW(NHEP+3)=IQ1+6 IDHEP(NHEP+2)=IDPDG(IQ1) IDHEP(NHEP+3)=-IDHEP(NHEP+2) PHEP(5,NHEP+2)=RMASS(IQ1) PHEP(5,NHEP+3)=RMASS(IQ1) ENDIF ISTHEP(NHEP+2)=113 ISTHEP(NHEP+3)=114 JMOHEP(1,NHEP+1)=1 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1)=2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2)=NHEP+1 JMOHEP(2,NHEP+2)=NHEP+3 JMOHEP(1,NHEP+3)=NHEP+1 JMOHEP(2,NHEP+3)=NHEP+2 JDAHEP(1,NHEP+1)=NHEP+2 JDAHEP(2,NHEP+1)=NHEP+3 JDAHEP(1,NHEP+2)=0 JDAHEP(2,NHEP+2)=NHEP+3 JDAHEP(1,NHEP+3)=0 JDAHEP(2,NHEP+3)=NHEP+2 C Generate polar and azimuthal angular distributions: C CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2) C +CLF(6)*SIN(2*PHI-PHI1-PHI2)) PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF 30 COSTH=HWRUNI(0,-ONE, ONE) PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2) & +CLF(3)*2.*VF*COSTH IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30 IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH SINTH2=1.-COSTH**2 IF (TPOL) THEN PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2) 40 CALL HWRAZM(ONE,CPHI,SPHI) C2PHI=2.*CPHI**2-1. S2PHI=2.*CPHI*SPHI PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS) & +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2 IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40 ELSE CALL HWRAZM(ONE,CPHI,SPHI) ENDIF C Construct final state 4-mommenta CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame SINTH=SQRT(SINTH2) PP(5)=PHEP(5,NHEP+2) PP(1)=PCM*SINTH*CPHI PP(2)=PCM*SINTH*SPHI PP(3)=PCM*COSTH PP(4)=SQRT(PCM**2+PP(5)**2) CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3)) C Set production vertices CALL HWVZRO(4,VHEP(1,NHEP+2)) CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3)) NHEP=NHEP+3 ELSE EMSCA=PHEP(5,3) Q2NOW=EMSCA**2 IF (Q2NOW.NE.Q2LST) THEN C Calculate coefficients for cross-section EMSCA=PHEP(5,3) Q2LST=Q2NOW FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW ID1=MOD(IPROC,10) ID2=MOD(ID1,7) IF (ID2.EQ.0) THEN CALL HWUEEC(1) VF2=1. VF=1. EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3. ELSE IF (IPROC.LT.150) THEN IDF=ID1 FACTR=FACTR*FLOAT(NCOLO) ELSE ID1=2*ID1+119 IDF=ID1-110 ENDIF IF (EMSCA.LE.2.*RMASS(ID1)) THEN EWGT=0. ELSE CALL HWUCFF(11,IDF,Q2NOW,CLF(1)) VF2=1.-4.*RMASS(ID1)**2/Q2NOW VF=SQRT(VF2) EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2)) ENDIF ENDIF ENDIF EVWGT=EWGT ENDIF END CDECK ID>, HWHEPG. *CMZ :- -02/05/91 10.57.27 by Federico Carminati *-- Author : Bryan Webber and Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHEPG C----------------------------------------------------------------------- C (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX, C equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0 c scheme, y_cut=1.-THMAX. C If flavour specified mass effects fully included. C EVWGT=sig(e^-e^+ --> qqbar g) in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST, & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM, & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM, & PVRT(4) INTEGER ID1,IQ,I,LM,LP,IQ1 LOGICAL MASS EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP, & IQ1,QQG,QBG,SUM DATA Q2LST/0.D0/ IF (GENEV) THEN C Label produced partons and calculate gluon spin IDHW(NHEP+1)=200 IDHW(NHEP+2)=IQ1 IDHW(NHEP+3)=13 IDHW(NHEP+4)=IQ1+6 IDHEP(NHEP+1)=23 IDHEP(NHEP+2)=IQ1 IDHEP(NHEP+3)=21 IDHEP(NHEP+4)=-IQ1 ISTHEP(NHEP+1)=110 ISTHEP(NHEP+2)=113 ISTHEP(NHEP+3)=114 ISTHEP(NHEP+4)=114 JMOHEP(1,NHEP+1)=LM JMOHEP(2,NHEP+1)=LP JMOHEP(1,NHEP+2)=NHEP+1 JMOHEP(2,NHEP+2)=NHEP+3 JMOHEP(1,NHEP+3)=NHEP+1 JMOHEP(2,NHEP+3)=NHEP+4 JMOHEP(1,NHEP+4)=NHEP+1 JMOHEP(2,NHEP+4)=NHEP+2 JDAHEP(1,NHEP+1)=NHEP+2 JDAHEP(2,NHEP+1)=NHEP+4 JDAHEP(1,NHEP+2)=0 JDAHEP(2,NHEP+2)=NHEP+4 JDAHEP(1,NHEP+3)=0 JDAHEP(2,NHEP+3)=NHEP+2 JDAHEP(1,NHEP+4)=0 JDAHEP(2,NHEP+4)=NHEP+3 C Decide which quark radiated and assign production vertices XQ2=(Q2NOW-2.*QBG)**2 X2SUM=XQ2+(Q2NOW-2.*QQG)**2 IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN C Quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP+4)) CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT) CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3)) CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2)) ELSE C Anti-quark radiated the gluon CALL HWVZRO(4,VHEP(1,NHEP+2)) CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT) CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3)) CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4)) ENDIF IF (AZSPIN) THEN C Calculate the transverse polarisation of the gluon C Correlation with leptons presently neglected GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW) GPOLN=2./(2.+GPOLN) ENDIF NHEP=NHEP+4 ELSE EMSCA=PHEP(5,3) Q2NOW=EMSCA**2 IF (Q2NOW.NE.Q2LST) THEN Q2LST=Q2NOW PHASP=3.*THMAX-2. IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400) QGMAX=.5*Q2NOW*THMAX QGMIN=.5*Q2NOW*(1.-THMAX) FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA) & *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW LM=1 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM) LP=2 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP) ORDER=1. IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER ID1=MOD(IPROC,10) IF (ID1.NE.0) THEN MASS=.TRUE. QM2=RMASS(ID1)**2 CALL HWUCFF(11,ID1,Q2NOW,CLF(1)) FACTR=FACTR*CLF(1) ELSE MASS=.FALSE. CALL HWUEEC(1) FACTR=FACTR*TQWT ENDIF ENDIF IF (ID1.EQ.0) THEN C Select quark flavour PRAN=TQWT*HWRGEN(1) PQWT=0. DO 10 IQ=1,MAXFL PQWT=PQWT+CLQ(1,IQ) IF (PQWT.GT.PRAN) GOTO 11 10 CONTINUE IQ=MAXFL 11 IQ1=MAPQ(IQ) DO 20 I=1,7 20 CLF(I)=CLQ(I,IQ) ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN IQ1=ID1 ELSE EVWGT=0. RETURN ENDIF C Select final state momentum configuration CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PHEP(5,NHEP+2)=RMASS(IQ1) PHEP(5,NHEP+3)=RMASS(13) PHEP(5,NHEP+4)=RMASS(IQ1) 30 CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2), & PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT) QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3)) IF (QQG.LT.QGMIN) GOTO 30 QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3)) SUM=QQG+QBG IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30 QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM)) QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP)) QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM)) QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP)) DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2 DYN2=0. DYN3=DYN1-2.*(QQLM**2+QBLP**2) IF (MASS) THEN RUT=1./QQG+1./QBG DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT & +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG)) DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT) & -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM)) & *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW) DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM)) ENDIF EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3 IF (TPOL) THEN C Include event plane azimuthal angle DYN4=.5*Q2NOW DYN5=DYN4 DYN6=0. IF (MASS) THEN DYN4=DYN4-QM2*SUM/QBG DYN5=DYN5-QM2*SUM/QQG DYN6=QM2 ENDIF EVWGT=EVWGT & +(CLF(4)*COSS-CLF(6)*SINS) & *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2) & +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2)) & +(CLF(4)*SINS+CLF(6)*COSS)*2. & *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2) & +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4)) & +(CLF(5)*COSS-CLF(7)*SINS)*DYN6 & *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2) & +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2. & *PHEP(1,NHEP+3)*PHEP(2,NHEP+3) ENDIF C Assign event weight EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1)) ENDIF END CDECK ID>, HWHESL. *CMZ :- -17/10/00 17:43:25 by Peter Richardson *-- Author : Kosuke Odagiri & Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHESL C----------------------------------------------------------------------- C SUSY E+E- -> 2 SLEPTON PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM, & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2), & IDSLP(2) INTEGER SSNU, SSCH PARAMETER (SSNU = 449, SSCH = 453) EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI SAVE HCS,ME2,IDLR,IDSLP PARAMETER (EPS = 1.D-9) DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E DOUBLE PRECISION F,FACT0 PARAMETER (Z = (0.D0,1.D0)) EQUIVALENCE (MZ, RMASS(200)) C S = PHEP(5,3)**2 EMSC2 = S EMSCA = SQRT(EMSC2) IF(FSTWGT) THEN IL = MOD((IPROC-740),5) IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN IDLR(1) = 0 IDLR(2) = 0 IDSLP(1) = 1 IDSLP(2) = 6 ELSE IF(IL.EQ.0) THEN IDLR(1) = 1 IDLR(2) = 1 IDSLP(1) = 2*(IPROC-740)/5 ELSEIF(IL.EQ.1) THEN IDLR(1) = 0 IDLR(2) = 0 IDSLP(1) = 2*(IPROC-741)/5+1 ELSEIF(IL.EQ.2) THEN IDLR(1) = 1 IDLR(2) = 1 IDSLP(1) = 2*(IPROC-742)/5+1 ELSEIF(IL.EQ.3) THEN IDLR(1) = 1 IDLR(2) = 2 IDSLP(1) = 2*(IPROC-743)/5+1 ELSEIF(IL.EQ.4) THEN IDLR(1) = 2 IDLR(2) = 2 IDSLP(1) = 2*(IPROC-744)/5+1 ENDIF IDSLP(2) = IDSLP(1) ENDIF ENDIF IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IDL = ABS(IDHEP(1)) ILP = IDL-10 COSTH = HWRUNI(1,-ONE,ONE) SN2TH = 0.25D0 - 0.25D0*COSTH**2 FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S FACTR = FACT0*SN2TH GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S c ~ ~* c e+ e- -> l l c DO IL=1,6 DO I=1,2 DO J=1,2 ME2(I,J,IL) = ZERO ENDDO ENDDO ENDDO DO IL = IDSLP(1),IDSLP(2) DO I = 1,2 DO J = 1,2 IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR. & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J) & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN QPE = -1. ELSE ID1 = 412 + I*12 + IL ID2 = 412 + J*12 + IL IL1 = IL + 10 QPE = S-(RMASS(ID1)+RMASS(ID2))**2 ENDIF IF (QPE.GT.ZERO) THEN SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2)) PF = SQPE/S IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN A = QFCH(IL1)*QFCH(IDL) BL = LFCH(IL1)/GZ BR = RFCH(IL1)/GZ CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J) CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J) D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN F = ZERO T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2) IF (IL.EQ.ILP) THEN IF (I.EQ.J) THEN IF (I.EQ.1) THEN DO IG = 1,4 IG1 = SSNU+IG F = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2) ENDDO D = D + F*S ELSE DO IG=1,4 IG1 = SSNU+IG F = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2) ENDDO E = E + F*S ENDIF ELSE ENDIF ELSE DO IG = 1,2 IG1 = SSCH+IG F = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2) ENDDO D = D + F*S/(TWO*SWEIN) ENDIF ENDIF ME2(I,J,IL)=FACTR*PF**3*DREAL( & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E) ELSE F = ZERO T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2) DO IG = 1,4 IG1 = SSNU+IG F = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)* & ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2) ENDDO C--production of el- er+ IF(I.EQ.1.AND.J.EQ.2) THEN ME2(I,J,IL)=FACT0*PF*F**2*S* & (ONE-EPOLN(3))*(ONE-PPOLN(3)) ELSE C--production of er- el+ ME2(I,J,IL)=FACT0*PF*F**2*S* & (ONE+EPOLN(3))*(ONE+PPOLN(3)) ENDIF ENDIF ELSE ME2(I,J,IL)=ZERO ENDIF ENDDO ENDDO ENDDO ENDIF HCS = ZERO C DO IL = 1,6 DO I = 1,2 DO J = 1,2 IL1 = IL+I*12+412 IL2 = IL+J*12+418 HCS = HCS + ME2(I,J,IL) IF (GENEV.AND.HCS.GT.RCS) GOTO 100 ENDDO ENDDO ENDDO C---GENERATE EVENT 100 IF(GENEV) THEN C--change sign of COSTH if antiparticle first IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH IDHW(NHEP+1) = 15 IDHEP(NHEP+1) = 0 ISTHEP(NHEP+1) = 110 IDHW(NHEP+2) = IL1 IDHW(NHEP+3) = IL2 IDHEP(NHEP+2) = IDPDG(IL1) IDHEP(NHEP+3) = IDPDG(IL2) C--select the particle masses and momenta NTRY = 0 110 NTRY = NTRY+1 PHEP(5,NHEP+2) = HWUMBW(IL1) PHEP(5,NHEP+3) = HWUMBW(IL2) CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN GOTO 110 ELSEIF(PCM.LT.ZERO) THEN CALL HWWARN('HWHESL',100) GOTO 999 ENDIF C--Set up the colours etc ISTHEP(NHEP+2) = 113 ISTHEP(NHEP+3) = 114 JMOHEP(1,NHEP+1) = 1 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1) = 2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2) = NHEP+1 JMOHEP(2,NHEP+2) = NHEP+2 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+3 JDAHEP(1,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+3 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+2) = NHEP+2 JDAHEP(1,NHEP+3) = 0 JDAHEP(2,NHEP+3) = NHEP+3 C--Set up the momenta IHEP = NHEP+2 IHEP = NHEP+2 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP) = PCM*COSTH PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) PHEP(2,IHEP) = ZERO CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1)) NHEP = NHEP+3 ELSE EVWGT = HCS ENDIF 999 RETURN END CDECK ID>, HWHESG. *CMZ :- -18/10/00 13:46:47 by Peter Richardson *-- Author : Kosuke Odagiri & Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHESG C----------------------------------------------------------------------- C SUSY E+E- -> 2 GAUGINO PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI, & FACA,M1(4,4),S2W,XC(4),XD(4),MSNU, & MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2, & SGN,S,SM,DM,PF,PCM,HWUPCM,XW,S22W, & MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR, & ISN,IDL,NTRY LOGICAL NEUT,CHAR SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS2,HWUPCM,HWUMBW DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0)) PARAMETER (SSNU=449,SSCH = 453) EQUIVALENCE (MZ, RMASS(200)) EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3)) EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3)) EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4)) EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4)) C--Start of the code IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE C--Decide which processes to generate IF(FSTWGT) THEN NEUT = .TRUE. CHAR = .TRUE. C--neutralino pair production IF(IPROC.GE.710.AND.IPROC.LE.726) THEN CHAR = .FALSE. IF(IPROC.EQ.710) THEN NTID(1) = 0 NTID(2) = 0 ELSE NTID(1) = INT((IPROC-707)/4) NTID(2) = MOD((IPROC-711),4)+1 ENDIF C--chargino pair production ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN NEUT = .FALSE. IF(IPROC.EQ.730) THEN CHID(1) = 0 CHID(2) = 0 ELSE CHID(1) = INT((IPROC-729)/2) CHID(2) = MOD((IPROC-731),2)+1 ENDIF ELSEIF(IPROC.NE.700) THEN CALL HWWARN('HWHESG',500) ENDIF C--check the particles in the beam IF(ABS(IDHEP(1)).EQ.11) THEN C--electron beams ISL = 425 ISR = 437 ISN = 426 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN C--muon beams ISL = 427 ISR = 439 ISN = 428 ELSE CALL HWWARN('HWHESG',501) ENDIF IDL=ABS(IDHEP(1)) ENDIF DO I=1,4 MNU(I) = RMASS(SSNU+I) MNU2(I) = MNU(I)**2 ENDDO DO IG1 = 1,2 MCH(IG1) = RMASS(IG1+SSCH) MCH2(IG1) = MCH(IG1)**2 ENDDO COSTH = HWRUNI(1,-ONE,ONE) XW = TWO * SWEIN S22W = XW * (TWO - XW) S2W = SQRT(S22W) S = PHEP(5,3)**2 EMSCA = PHEP(5,3) FACA = HWUAEM(S)**2 GZ = S-MZ**2+Z*S/MZ*GAMZ MSL = RMASS(ISL) MSR = RMASS(ISR) MSL2 = MSL**2 MSR2 = MSR**2 MSNU = RMASS(ISN) MSNU2 = MSNU**2 C--neutralino pair production IF(.NOT.NEUT) THEN DO IQ1=1,4 DO IQ2=1,4 M1(IQ1,IQ2) = ZERO ENDDO ENDDO GOTO 100 ENDIF DO IQ1=1,4 DO IQ2=1,4 SM = MNU(IQ1) + MNU(IQ2) QPE = S - SM**2 IF(QPE.GE.ZERO.AND. & (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2)) & .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN DM = MNU(IQ1) - MNU(IQ2) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2)) U = - T - S + MNU2(IQ1) + MNU2(IQ2) C1 = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ C2 = - C1 SGN = ZSGNSS(IQ1)*ZSGNSS(IQ2) CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2) CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2) CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2) CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2) C--modified to include beam polarization PR 10/10/01 M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF* & HWHSS2(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR) ELSE M1(IQ1,IQ2) = ZERO ENDIF ENDDO ENDDO C--chargino pair production 100 IF(.NOT.CHAR) THEN DO IG1=1,2 DO IG2=1,2 M2(IG1,IG2) = ZERO ENDDO ENDDO GOTO 200 ENDIF DO IG1 = 1,2 DO IG2 = 1,2 SM = MCH(IG1) + MCH(IG2) QPE = S - SM**2 IF (QPE.GE.ZERO.AND. & (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2) & .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN DM = MCH(IG1) - MCH(IG2) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) U = - T - S + MCH2(IG1) + MCH2(IG2) DAB = ABS(FLOAT(IG1+IG2-3)) C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ SGN = WSGNSS(IG1)*WSGNSS(IG2) C3 = -DAB*QFCH(IDL)/S CLL = C3- LFCH(IDL)*C1 & +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW) CLR = C3- LFCH(IDL)*C2 CRL = C3- RFCH(IDL)*C1 CRR = C3- RFCH(IDL)*C2 C--modified to include beam polarization PR 10/10/01 M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S* & HWHSS2(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR) ELSE M2(IG1,IG2) = ZERO ENDIF ENDDO ENDDO ENDIF C--Add up the weights now 200 HCS = ZERO IF(.NOT.NEUT) GOTO 250 DO IQ1=1,4 IG1 = SSNU+IQ1 DO IQ2=1,4 IG2 = SSNU+IQ2 HCS = HCS+M1(IQ1,IQ2) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 ENDDO ENDDO 250 IF(.NOT.CHAR) GOTO 900 DO IQ1 = 1,2 IG1 = SSCH+IQ1 DO IQ2 = 1,2 IG2 = SSCH+IQ2+2 HCS = HCS + M2(IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) GOTO 900 ENDDO ENDDO 900 IF(GENEV) THEN C--change sign of COSTH if antiparticle first IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH C-Set up the particle types IDHW(NHEP+1) = 15 IDHEP(NHEP+1) = 0 ISTHEP(NHEP+1) = 110 IDHW(NHEP+2) = IG1 IDHW(NHEP+3) = IG2 IDHEP(NHEP+2) = IDPDG(IG1) IDHEP(NHEP+3) = IDPDG(IG2) C--select the particle masses and momenta NTRY = 0 910 NTRY = NTRY+1 PHEP(5,NHEP+2) = HWUMBW(IG1) PHEP(5,NHEP+3) = HWUMBW(IG2) CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN GOTO 910 ELSEIF(PCM.LT.ZERO) THEN CALL HWWARN('HWHESG',100) GOTO 999 ENDIF C--Set up the colours etc ISTHEP(NHEP+2) = 113 ISTHEP(NHEP+3) = 114 JMOHEP(1,NHEP+1) = 1 C--PR Bug fix 10/10/01 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1) = 2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2) = NHEP+1 JMOHEP(2,NHEP+2) = NHEP+2 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+3 JDAHEP(1,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+3 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+2) = NHEP+3 JDAHEP(1,NHEP+3) = 0 JDAHEP(2,NHEP+3) = NHEP+2 C--Set up the momenta IHEP = NHEP+2 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP) = PCM*COSTH PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) PHEP(2,IHEP) = ZERO CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1)) NHEP = NHEP+3 ELSE EVWGT = HCS ENDIF 999 RETURN END CDECK ID>, HWHESP. *CMZ :- -18/10/00 13:46:47 by Peter Richardson *-- Author : Kosuke Odagiri & Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHESP C----------------------------------------------------------------------- C SUSY E+E- -> 2 SPARTICLE PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN EXTERNAL HWRGEN SAVE SAVWT IF(IPROC.EQ.700) THEN IF(GENEV) THEN RANWT = SAVWT(3)*HWRGEN(0) IF(RANWT.LT.SAVWT(1)) THEN CALL HWHESG ELSEIF(RANWT.LT.SAVWT(2)) THEN CALL HWHESL ELSEIF(RANWT.LT.SAVWT(3)) THEN CALL HWHESQ ENDIF ELSE CALL HWHESG SAVWT(1) = EVWGT CALL HWHESL SAVWT(2) = SAVWT(1)+EVWGT CALL HWHESQ SAVWT(3) = SAVWT(2)+EVWGT EVWGT = SAVWT(3) ENDIF ELSEIF(IPROC.LT.740) THEN CALL HWHESG ELSEIF(IPROC.LT.760) THEN CALL HWHESL ELSEIF(IPROC.LT.790) THEN CALL HWHESQ ELSE C---UNRECOGNIZED PROCESS CALL HWWARN('HWHESP',500) ENDIF END CDECK ID>, HWHESQ. *CMZ :- -16/10/00 15:34:113 by Peter Richardson *-- Author : Kosuke Odagiri & Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHESQ C----------------------------------------------------------------------- C SUSY E+E- -> 2 SQUARK PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM, & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI SAVE HCS,ME2,IDLR,IDSQU PARAMETER (EPS = 1.D-9) DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E PARAMETER (Z = (0.D0,1.D0)) EQUIVALENCE (MZ, RMASS(200)) C S = PHEP(5,3)**2 EMSC2 = S EMSCA = SQRT(EMSC2) IF(FSTWGT) THEN IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN IDLR(1) = 0 IDLR(2) = 0 IDSQU(1) = 1 IDSQU(2) = 6 ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN IQ = MOD((IPROC-761),4) IF(IQ.EQ.0) THEN IDLR(1) = 0 IDLR(2) = 0 ELSEIF(IQ.EQ.1) THEN IDLR(1) = 1 IDLR(2) = 1 ELSEIF(IQ.EQ.2) THEN IDLR(1) = 1 IDLR(2) = 2 ELSEIF(IQ.EQ.3) THEN IDLR(1) = 2 IDLR(2) = 2 ENDIF IDSQU(1) = (IPROC-761)/4+1 IDSQU(2) = IDSQU(1) ELSE CALL HWWARN('HWHESQ',500) ENDIF ENDIF IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE COSTH = HWRUNI(1,-ONE,ONE) SN2TH = 0.25D0 - 0.25D0*COSTH**2 FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S IDL = ABS(IDHEP(1)) c ~ ~* c e+ e- -> q q c DO IQ=1,6 DO I=1,2 DO J=1,2 ME2(I,J,IQ) = ZERO ENDDO ENDDO ENDDO DO IQ = IDSQU(1),IDSQU(2) DO I = 1,2 DO J = 1,2 IF ((I.NE.J).AND.(IQ.LT.5).OR. & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J) & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN QPE = -1. ELSE ID1 = 388 + I*12 + IQ ID2 = 388 + J*12 + IQ QPE = S-(RMASS(ID1)+RMASS(ID2))**2 ENDIF IF (QPE.GT.ZERO) THEN SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2)) PF = SQPE/S A = QFCH(IQ)*QFCH(IDL) BL = LFCH(IQ)/GZ BR = RFCH(IQ)/GZ CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J) CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J) D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR ME2(I,J,IQ)=FACTR*PF**3*DREAL( & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E) ELSE ME2(I,J,IQ)=ZERO ENDIF ENDDO ENDDO ENDDO ENDIF HCS = ZERO C DO IQ = 1,6 DO I = 1,2 DO J = 1,2 IQ1 = IQ+I*12+388 IQ2 = IQ+J*12+394 HCS = HCS + ME2(I,J,IQ) IF (GENEV.AND.HCS.GT.RCS) GOTO 100 ENDDO ENDDO ENDDO C---GENERATE EVENT 100 IF(GENEV) THEN IDHW(NHEP+1) = 15 IDHEP(NHEP+1) = 0 ISTHEP(NHEP+1) = 110 IDHW(NHEP+2) = IQ1 IDHW(NHEP+3) = IQ2 IDHEP(NHEP+2) = IDPDG(IQ1) IDHEP(NHEP+3) = IDPDG(IQ2) C--Select the particle masses and momenta 110 NTRY = NTRY+1 PHEP(5,NHEP+2) = HWUMBW(IQ1) PHEP(5,NHEP+3) = HWUMBW(IQ2) CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN GOTO 110 ELSEIF(PCM.LT.ZERO) THEN CALL HWWARN('HWHESQ',100) GOTO 999 ENDIF C--Set up the colours etc ISTHEP(NHEP+2) = 113 ISTHEP(NHEP+3) = 114 JMOHEP(1,NHEP+1) = 1 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1) = 2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2) = NHEP+1 JMOHEP(2,NHEP+2) = NHEP+3 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+2 JDAHEP(1,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+3 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+2) = NHEP+3 JDAHEP(1,NHEP+3) = 0 JDAHEP(2,NHEP+3) = NHEP+2 C--Set up the momenta IHEP = NHEP+2 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP) = PCM*COSTH PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1)) NHEP = NHEP+3 ELSE EVWGT = HCS ENDIF 999 RETURN END CDECK ID>, HWHEW0. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Zoltan Kunszt, modified by Bryan Webber & Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S, & D1,PABS,D,CX,C,E,F,SC,G INTEGER IP,I EXTERNAL HWRGEN WEIGHT=ZERO XM1=XM(1)**2 XM2=XM(2)**2 S=ETOT*ETOT D1=S-XM1-XM2 PABS=D1*D1-4.*XM1*XM2 IF (PABS.LE.ZERO) RETURN PABS=SQRT(PABS) D=D1/PABS IF(IP.EQ.2)GOTO3 CX=CR C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2) GOTO 4 3 E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE) C=D*((E-ONE)/(E+ONE)) 4 F=2D0*PIFAC*HWRGEN(4) SC=SQRT(ONE-C*C) PR(4,1)=(S+XM1-XM2)/(TWO*ETOT) PR(5,1)=PR(4,1)*PR(4,1)-XM1 IF (PR(5,1).LE.ZERO) RETURN PR(5,1)=SQRT(PR(5,1)) PR(4,2)=ETOT-PR(4,1) PR(3,1)=PR(5,1)*C PR(5,2)=PR(5,1) PR(2,1)=PR(5,1)*SC*COS(F) PR(1,1)=PR(5,1)*SC*SIN(F) DO 7 I=1,3 7 PR(I,2)=-PR(I,1) G=0. IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR)) IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE)) WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF END CDECK ID>, HWHEW1. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHEW1(NPART) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM INTEGER NPART,I,J,K COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) DO 10 I=1,NPART P(1,I)=PLAB(3,I) P(2,I)=PLAB(1,I) P(3,I)=PLAB(2,I) P(4,I)=PLAB(4,I) 10 CONTINUE DO 20 J=1,4 DO 30 K=1,(NPART-2) 30 PCM(J,K)=P(J,K+2) PCM(J,NPART-1)=-P(J,1) PCM(J,NPART)=-P(J,2) 20 CONTINUE END CDECK ID>, HWHEW2. *CMZ :- -26/04/91 13.22.25 by Federico Carminati *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D) C----------------------------------------------------------------------- C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING. C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS. C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA C OF NEGATIVE ENERGY. C PCM IS FILLED BY PHASE SPACE MONTE CARLO. C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING ` C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(8,8), & CH(8,8),D(8,8) DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),EPS,Q1,Q2,QP,QM, & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1 PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0) EPS=0.0000001 ZI=DCMPLX(ZERO,ONE) Z1=DCMPLX(ONE,ZERO) C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING DO 1 L=1,NPART DO 1 IJ=1,4 1 P(IJ,L)=PPCM(IJ,L) DO 2 II=1,8 WRN(II)=ONE IF(P(4,II).LT.ZERO) WRN(II)=-ONE DO 2 JJ=1,4 P(JJ,II)=WRN(II)*P(JJ,II) 2 CONTINUE C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES DO 11 I=1,NPART-1 IP1=I+1 DO 11 J=IP1,NPART Q1=P(4,I)+P(1,I) QP=0.0 IF(Q1.GT.EPS)QP=SQRT(Q1) Q2=P(4,I)-P(1,I) QM=0.0 IF(Q2.GT.EPS)QM=SQRT(Q2) P1=P(4,J)+P(1,J) PP=0. IF(P1.GT.EPS)PP=SQRT(P1) P2=P(4,J)-P(1,J) PM=0. IF(P2.GT.EPS)PM=SQRT(P2) DMP=PM*QP ZDMP=DCMPLX(DMP,ZERO) DPM=PP*QM ZDPM=DCMPLX(DPM,ZERO) C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING PT=SQRT(P(2,J)**2+P(3,J)**2) QT=SQRT(P(2,I)**2+P(3,I)**2) IF(PT.GT.EPS) GOTO 99 ZP=Z1 GOTO 98 99 PTI=ONE/PT ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J)) 98 ZPS=DCONJG(ZP) IF(QT.GT.EPS) GOTO 89 ZQ=Z1 GOTO 88 89 QTI=ONE/QT ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I)) 88 ZQS=DCONJG(ZQ) ZT=Z1 IF(WRN(I).LT.ZERO) ZT=ZT*ZI IF(WRN(J).LT.ZERO) ZT=ZT*ZI H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT ZD=H(J,I)*CH(J,I) PT5=DCMPLX(HALF,ZERO) D(J,I)=PT5*ZD 11 CONTINUE DO 60 I=1,NPART-1 IPP1=I+1 DO 60 J=IPP1,NPART H(I,J)=-H(J,I) CH(I,J)=-CH(J,I) 60 D(I,J)=D(J,I) END CDECK ID>, HWHEW3. *CMZ :- -27/03/92 19.48.55 by Mike Seymour *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW) C----------------------------------------------------------------------- C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+ C C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS C C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION C FOR ON POLE APPROXIMATION AS DESIRED. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP3,DWW,CWW,BWW,AWW, & AWWM,AWWP,AMPTEM,ZTWO,ZHALF DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4), & AMPWW(4) INTEGER I,N1,N2,N3,N4,N5,N6 EXTERNAL HWHEW4 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200)) SAVE COLFAC,ZTWO,ZHALF DATA COLFAC/1.D0,3.D0,3.D0,9.D0/ DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/ T3=-1.D0 EQ1=-1.D0 RR=-2.D0*EQ1*XW RL=T3+RR ZM2=ZMASS*ZMASS ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2)) & /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS)) ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6)) DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2)) CWW=DCMPLX(RR)*ZAMP1 AWW=DWW BWW=DWW-ZAMP3 AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4) AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6)) AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP) AMP2=DREAL(AMPTEM) C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET C NOR DOES IT INCLUDE TO THIS POINT KWW**2 C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE RKW=0.25D0/XW**2 DO 6 I=1,4 6 AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW END CDECK ID>, HWHEW4. *CMZ :- -26/04/91 10.18.57 by Bryan Webber *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD INTEGER N1,N2,N3,N4,N5,N6 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4) X +ZH(N3,N5)*ZCH(N3,N4)) END CDECK ID>, HWHEW5. *CMZ : 20/08/91 22.09.33 by Federico Carminati *-- Author : Zoltan Kunszt, modified by Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2) C----------------------------------------------------------------------- C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0 C C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS C C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION C FOR ON POLE APPROXIMATION AS DESIRED. C C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE C INDICATED BY ID1,ID2 C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256, & ZTWO DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I EXTERNAL HWHEW4 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8) SAVE ZTWO DATA ZTWO/(2.0D0,0.0D0)/ C THE MATRIX ELEMENT DEPENDS ON ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+ > HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156 ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+ > HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156 ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+ > HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156 ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+ > HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156 ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+ > HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256 ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+ > HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256 ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+ > HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256 ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+ > HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256 HELSUM=0.0 HELCTY=0.0 DO 1 I=1,8 AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I))) HELSUM=HELSUM+CPALL(I)*AMM HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM 1 CONTINUE END CDECK ID>, HWHEWW. *CMZ :- -02/05/91 10.58.29 by Federico Carminati *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHEWW C----------------------------------------------------------------------- C E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ZH,ZCH,ZD DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM, & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO, & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM, & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12), & RRL(12),DIST(4) INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST, & IDZOLT(16),MAP(12),NEWHEP LOGICAL EISBM1,HWRLOG EXTERNAL HWUAEM,HWRGEN,HWUPCM SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST, & IDBOS,WMASS,WWIDTH,BRZED COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8) SAVE IDZOLT,MAP DATA ELST,ILST/0.D0,0/ DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/ DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/ IF (IERROR.NE.0) RETURN EISBM1=IDHW(1).LT.IDHW(2) IF (GENEV) THEN NEWHEP=NHEP NHEP=NHEP+2 DO 20 IB=1,2 IBOS=IB+NEWHEP CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS)) IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS) CALL HWVZRO(4,VHEP(1,IBOS)) CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST) CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST) IDHW(IBOS)=IDBOS(IB) IDHEP(IBOS)=IDPDG(IDBOS(IB)) JMOHEP(1,IBOS)=1 JMOHEP(2,IBOS)=2 ISTHEP(IBOS)=110 DO 10 I=1,2 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I)) IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I) CALL HWVEQU(4,DIST,VHEP(1,NHEP+I)) C---STATUS, IDs AND POINTERS ISTHEP(NHEP+I)=112+I IDHW(NHEP+I)=IDP(2*IB+I) IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I)) JDAHEP(I,IBOS)=NHEP+I JMOHEP(1,NHEP+I)=IBOS JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS) 10 CONTINUE NHEP=NHEP+2 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(2,NHEP)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP JDAHEP(2,NHEP-1)=NHEP 20 CONTINUE ELSE EMSCA=PHEP(5,3) ETOT=EMSCA IPRC=MOD(IPROC,100) IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN STOT=ETOT*ETOT FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT IF (IPRC.EQ.0) THEN WMASS=RMASS(198) WWIDTH=GAMW IDBOS(1)=198 IDBOS(2)=199 ELSEIF (IPRC.EQ.50) THEN WMASS=RMASS(200) WWIDTH=GAMZ IDBOS(1)=200 IDBOS(2)=200 C---LOAD FERMION COUPLINGS TO Z DO 30 I=1,12 RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1) RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1) 30 CONTINUE RLL(11)=0 RRL(11)=0 BRTOT=0 DO 60 J1=1,12 BRZED(J1)=0 DO 50 J2=1,12 CCC=1 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2 DO 40 I=1,8 IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0 CPALL(I)=CPALL(I)+CPFAC(J1,J2,I) BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I) BRTOT=BRTOT+CPFAC(J1,J2,I) 40 CONTINUE 50 CONTINUE 60 CONTINUE DO 70 I=1,12 70 BRZED(I)=BRZED(I)/BRTOT ELSE CALL HWWARN('HWHEWW',500) ENDIF GAMM=WMASS*WWIDTH GIMM=1.D0/GAMM WM2=WMASS*WMASS WXMIN=ATAN(-WMASS/WWIDTH) WX1MAX=ATAN((STOT-WM2)*GIMM) FJAC1=WX1MAX-WXMIN ILST=IPRC ELST=ETOT ENDIF EVWGT=0 C---CHOOSE W MASSES WX1=WXMIN+FJAC1*HWRGEN(1) WMM1=GAMM*TAN(WX1)+WM2 IF (WMM1.LE.0) RETURN XMASS(1)=SQRT(WMM1) WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM) FJAC2=WX2MAX-WXMIN WX2=WXMIN+FJAC2*HWRGEN(2) WMM2=GAMM*TAN(WX2)+WM2 IF (WMM2.LE.0) RETURN XMASS(2)=SQRT(WMM2) IF (HWRLOG(HALF))THEN XXM=XMASS(1) XMASS(1)=XMASS(2) XMASS(2)=XXM ENDIF C---CTMAX=ANGULAR CUT ON COS W-ANGLE CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX) IF (W2BO.EQ.ZERO) RETURN C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0 IF (IPRC.NE.0) THEN IF (PRW(3,1).LT.ZERO) RETURN C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY) IF (HWRLOG(HALF)) THEN PRW(3,1)=-PRW(3,1) PRW(3,2)=-PRW(3,2) ENDIF ENDIF PLAB(3,1)=0.5*ETOT PLAB(4,1)=PLAB(3,1) PLAB(3,2)=-PLAB(3,1) PLAB(4,2)=PLAB(3,1) C C---LET THE W BOSONS DECAY NTRY=0 80 NTRY=NTRY+1 DO 90 IB=1,2 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1) PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2)) IF (PST.LT.ZERO) THEN CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2) IF (NTRY.LE.NBTRY) GOTO 80 C CALL HWWARN('HWHEWW',1) RETURN ENDIF PRW(5,IB)=XMASS(IB) IDP(2*IB+1)=ID1 IDP(2*IB+2)=ID2 PLAB(5,2*IB+1)=RMASS(ID1) PLAB(5,2*IB+2)=RMASS(ID2) CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2), & PST,TWO,.TRUE.) 90 CONTINUE WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2 CALL HWHEW1(6) CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD) IF (IPRC.EQ.0) THEN CALL HWHEW3(5,6,3,4,1,2,AMPWW) TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4) EVWGT=TOTSIG*WEIGHT*BR ELSE ID1=IDZOLT(IDPDG(IDP(3))) ID2=IDZOLT(IDPDG(IDP(5))) CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2) EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2)) ENDIF ENDIF END CDECK ID>, HWHGBP. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGBP C----------------------------------------------------------------------- C Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX ZH,ZCH,ZD DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,XMASS, & PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP, & MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4 INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT, & MAP(4),IDRES LOGICAL PHOTON,GEN EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1 COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2), & IDRES,IDP(10),IOPT SAVE AMPWW,IPRC,PHOTON PARAMETER(FPI4=24936.72731D0) DOUBLE PRECISION WI(IMAXCH) COMMON /HWPSOM/ WI SAVE MAP DATA MAP/1,2,11,12/ IF (IERROR.NE.0) RETURN IF (GENEV) THEN IF (IPRC.EQ.0) THEN CALL HWHGB2(AMPWW,IDP,PHOTON) ELSEIF(IPRC.EQ.10) THEN CALL HWHGB3(AMPWW,IDP,PHOTON) ELSEIF(IPRC.EQ.20) THEN CALL HWHGB4(AMPWW,IDP,PHOTON) IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR. & (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN IDBOS(1)=199 IDP(3) = IDP(3)+6 IDP(4) = IDP(4)-6 ENDIF ENDIF C--change the sign of the z component (in CMF) if particle first IF(IDP(1).LT.IDP(2)) THEN DO IB=1,2 PRW(3,IB) = -PRW(3,IB) DO I=1,2 PLAB(3,2*IB+I)=-PLAB(3,2*IB+I) ENDDO ENDDO ENDIF C--boost particles back to the lab frame from the centre of mass frame DO IB=1,2 CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB)) ENDDO DO I=1,6 CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I)) ENDDO C--put the particles in the event record C--first the incoming quarks ICMF = NHEP+3 DO I=1,2 IHEP = NHEP+I CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP)) IDHW(IHEP) = IDP(I) IDHEP(IHEP)=IDPDG(IDP(I)) ISTHEP(IHEP)=110+I JMOHEP(1,IHEP)=ICMF JMOHEP(I,ICMF)=IHEP JDAHEP(1,IHEP)=ICMF ENDDO JMOHEP(2,NHEP+1) = NHEP+2 JMOHEP(2,NHEP+2) = NHEP+1 JDAHEP(2,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+2) = NHEP+1 C--Centre-of-mass energy ICMF = NHEP+3 C--new for spin correlations IF(SYSPIN) THEN IDSPN(1) = ICMF ISNHEP(ICMF) = 1 JMOSPN(1) = 0 JDASPN(1,1) = 2 JDASPN(2,1) = 5 DECSPN(1) = .FALSE. ENDIF IDHW(ICMF)=15 IDHEP(ICMF)=IDPDG(15) ISTHEP(ICMF)=110 CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) JDAHEP(1,ICMF) = ICMF+1 JDAHEP(2,ICMF) = ICMF+2 NHEP = NHEP+3 NEWHEP = NHEP NHEP = NHEP+2 C--Now the bosons DO IB=1,2 IBOS=IB+NEWHEP CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS)) CALL HWVZRO(4,VHEP(1,IBOS)) CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST) CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST) IDHW(IBOS)=IDBOS(IB) IDHEP(IBOS)=IDPDG(IDBOS(IB)) JMOHEP(1,IBOS)=ICMF JMOHEP(2,IBOS)=ICMF JDAHEP(2,IBOS)=IBOS ISTHEP(IBOS)=112+IB ENDDO C--now generate the initial state shower CALL HWBGEN IF(IERROR.NE.0) RETURN C--now add the outgoing fermions to the event record DO 20 IB=1,2 IBOS=IB+NEWHEP IBRAD = JDAHEP(1,IBOS) ISTHEP(IBRAD) = 195 DO 10 I=1,2 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I)) CALL HWVEQU(4,DIST,VHEP(1,NHEP+I)) C--Boost the fermion momenta to the rest frame of the original W CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I)) C--Now boost back to the lab from rest frame of the W after radiation CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I)) C--Set the status and pointers ISTHEP(NHEP+I)=112+I IDHW(NHEP+I)=IDP(2*IB+I) IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I)) JDAHEP(I,IBRAD)=NHEP+I JMOHEP(1,NHEP+I)=IBRAD C--New for spin correlations IF(SYSPIN) THEN ISNHEP(NHEP+I) = 2*IB+I-1 IDSPN(2*IB+I-1) = NHEP+I JMOSPN(2*IB+I-1) = 1 DECSPN(2*IB+I-1) = .FALSE. RHOSPN(1,1,2*IB+I-1) = HALF RHOSPN(1,2,2*IB+I-1) = ZERO RHOSPN(2,1,2*IB+I-1) = ZERO RHOSPN(2,2,2*IB+I-1) = HALF NSPN = NSPN+1 ENDIF 10 CONTINUE NHEP=NHEP+2 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(2,NHEP)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP JDAHEP(2,NHEP-1)=NHEP 20 CONTINUE ELSE IF(FSTWGT) THEN IPRC=MOD(IPROC,100) IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN PHOTON = .FALSE. IPRC = IPRC-5 ELSE PHOTON = .TRUE. ENDIF IOPT=1 IF (IPRC.EQ.0) THEN C--WW production IDBOS(1)=199 IDBOS(2)=198 IDRES =200 C--ZZ production ELSEIF (IPRC.EQ.10) THEN IDBOS(1)=200 IDBOS(2)=200 IDRES =200 ELSEIF(IPRC.EQ.20) THEN C--WZ production IDBOS(1)=198 IDBOS(2)=200 IDRES =198 IOPT = 0 ELSE CALL HWWARN('HWHGBP',500) ENDIF C--calculate the couplings etc MW2 = RMASS(198)**2 GMW = RMASS(198)*GAMW MZ2 = RMASS(200)**2 GMZ = RMASS(200)*GAMZ C--couplings to Z and photon DO I=1,4 G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1) G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1) EE(I) = QFCH(MAP(I)) ENDDO C--elements of the CKM matrix for the various decay modes of the W DO I=1,3 DO J=1,3 C**Bug fix 2/7/01 by BRW (unsquare) CKM2(3*I-3+J) = VCKM(J,I) C**End bug fix ENDDO CKM2(9+I) = ONE ENDDO C--couplings of the up and down TAUI(1) = -ONE TAUI(2) = ONE DO I=1,2 RF(I) = -TWO*QFCH(I)*SWEIN LF(I) = TAUI(I)+RF(I) ENDDO CFAC1 = ONE/THREE CSW = SQRT((ONE-SWEIN)/SWEIN) ENDIF EVWGT=ZERO C--find the momenta and the phase space weight CALL HWHGBS(FLUXW,GEN) IF(.NOT.GEN) RETURN C--couplings AMP = FPI4*HWUAEM(EMSCA**2)**4 C--copy the momenta and change the sign of the beam DO I=1,6 P(1,I)=PLAB(3,I) P(2,I)=PLAB(1,I) P(3,I)=PLAB(2,I) P(4,I)=PLAB(4,I) ENDDO DO 120 J=1,4 DO 130 K=3,6 130 PCM(J,K)=P(J,K) PCM(J,1)=-P(J,1) PCM(J,2)=-P(J,2) 120 CONTINUE C--use the e+e- code to calulate the spinor products CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD) C--calculate the matrix elements IF (IPRC.EQ.0) THEN C--WW matrix element CALL HWHGB2(AMPWW,IDP,PHOTON) ELSEIF(IPRC.EQ.10) THEN C--ZZ matrix element CALL HWHGB3(AMPWW,IDP,PHOTON) ELSEIF(IPRC.EQ.20) THEN C--WZ matrix element CALL HWHGB4(AMPWW,IDP,PHOTON) ENDIF C--Now calculate the cross section EVWGT = AMPWW*FLUXW*AMP IF(OPTM) THEN DO I=1,IMAXCH IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2 ENDDO ENDIF ENDIF END CDECK ID>, HWHGBS. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGBS(WEIGHT,GEN) C----------------------------------------------------------------------- C Multichannel phase space for gauge boson pair production C ICH returns the channel used if OPTM=.FALSE. C ICH specifies the channel to be used if OPTM=.TRUE. C This is used in optimising the weights for the different channels C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1 DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM, & MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2), & ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2), & G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12) LOGICAL HWRLOG,GEN COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2), & IDRES,IDP(10),IOPT EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI SAVE ISM,IPRC PARAMETER(TWOPI2=39.4784176D0) DOUBLE PRECISION WI(IMAXCH) COMMON /HWPSOM/ WI SAVE SIG,BRZ DATA SIG/1.0D0,-1.0D0/ DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/ IF(IERROR.NE.0) RETURN WEIGHT = ZERO IF(OPTM) THEN DO I=1,IMAXCH WI(I) = ZERO ENDDO ENDIF GEN = .FALSE. C--set the smoothing for the bosons in the various channels IF(FSTWGT) THEN IPRC = MOD(IPROC,100) DO I=1,2 ISM(1,I) = 1 DO J=1,2 ISM(1,4*I-2+J ) = 1 ISM(1,4*I+J ) = 2 ISM(2,4*I+2*J-3) = 1 ISM(2,4*I+2*J-2) = 2 ENDDO ENDDO ISM(2,1) = 1 ISM(2,2) = 2 ENDIF C--select the channel to be used RAND=HWRGEN(0) DO ICH=1,IMAXCH IF(CHON(ICH)) THEN IF(CHNPRB(ICH).GT.RAND) GOTO 10 RAND = RAND-CHNPRB(ICH) ENDIF ENDDO 10 CONTINUE C--select the boson masses and compute that part of the denominator C--decide which boson to do first IF(HWRLOG(HALF)) THEN IB(1) = 1 IB(2) = 2 ELSE IB(1) = 2 IB(2) = 1 ENDIF C--find the boson masses CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)), & (PHEP(5,3)-EMMIN)**2,EMMIN**2) XMASS(IB(1)) = SQRT(BMS2(IB(1))) CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)), & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2) XMASS(IB(2)) = SQRT(BMS2(IB(2))) DO I=1,2 MJAC(I) = HALF*MJAC(I)/TWOPI2 ENDDO C--now generate the values of s C--according to a Breit-Wigner for the first two IF(ICH.LE.2) THEN CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2, & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2) C--according to a power law for the rest ELSE CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2, & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2) ENDIF ETOT = SQRT(STOT) C--find the centre of mass momenta PST = HWUPCM(ETOT,XMASS(1),XMASS(2)) IF(PST.LT.PTMIN) RETURN PRW(4,1) = SQRT(BMS2(1)+PST**2) PRW(4,2) = SQRT(BMS2(2)+PST**2) C--now generate the value of t and u PLM = SQRT(PST**2-PTMIN**2) TMIN = BMS2(1)-ETOT*(PRW(4,1)+PLM) TMAX = BMS2(1)-ETOT*(PRW(4,1)-PLM) UMIN = BMS2(2)-ETOT*(PRW(4,2)+PLM) UMAX = BMS2(2)-ETOT*(PRW(4,2)-PLM) SN = ONE/(TMAX-TMIN) C--for the first two channels uniform in t IF(ICH.LE.2) THEN THAT = HWRUNI(1,TMIN,TMAX) UHAT = BMS2(1)+BMS2(2)-STOT-THAT TJAC = TMAX-TMIN C--for the next four channels generate t according to 1/t ELSEIF(ICH.LE.6) THEN CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN) UHAT = BMS2(1)+BMS2(2)-STOT-THAT C--for the last four channels generate u according to 1/u ELSEIF(ICH.LE.10) THEN CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN) THAT = BMS2(1)+BMS2(2)-STOT-UHAT ELSE CALL HWWARN('HWHGBS',500) ENDIF CALL HWHGB5(1,TN,THAT,TMAX,TMIN) CALL HWHGB5(1,UN,UHAT,UMAX,UMIN) C--generate the parton momentum fractions and find the pdf's TAU = STOT/PHEP(5,3)**2 XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO)) XX(2) = TAU/XX(1) XJAC = -LOG(TAU)*XX(1) XF = ONE/XJAC EMSCA=ETOT CALL HWSGEN(.FALSE.) C--Centre of mass collison angle COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST PHI = HWRUNI(4,ZERO,TWO*PIFAC) SINTH = SQRT(ONE-COSTH**2) C--incoming momenta in the centre of mass frame DO I=1,2 PLAB(1,I) = ZERO PLAB(2,I) = ZERO PLAB(3,I) = HALF*ETOT PLAB(4,I) = HALF*ETOT PLAB(5,I) = ZERO ENDDO PLAB(3,2) = -PLAB(3,2) C--outgoing boson momenta in the centre of mass frame DO I=1,2 PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST PRW(3,I) = SIG(I)*COSTH*PST PRW(5,I) = XMASS(I) ENDDO C--now find the boson decay products C--find the momenta of the boson decay products IF(IPRC.EQ.20) IDBOS(1)=198 DO 90 I=1,2 CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT, & XMASS(I)) IF(BR(I).EQ.ZERO) RETURN PRW(5,I)=XMASS(I) PLAB(5,2*I+1) = ZERO PLAB(5,2*I+2) = ZERO PS(I) = HALF*XMASS(I) PLAB(5,2*I+1)=ZERO PLAB(5,2*I+2)=ZERO CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2), & PS(I),TWO,.TRUE.) 90 CONTINUE BRFAC = BR(2) IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1) DO I=1,2 IF(IDBOS(I).EQ.200) THEN ID1 = IDP(1+2*I) IF(ID1.GE.121) ID1 = ID1-114 BRFAC = BRFAC/BRZ(ID1) ENDIF ENDDO DO I=1,2 MJAC(I) = MJAC(I)*PS(I)/XMASS(I) ENDDO C--set up a vector with the centre of mass PLAB(1,7) = ZERO PLAB(2,7) = ZERO PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2)) PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2)) PLAB(5,7) = ETOT C--now find the denominator CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2, & (XMASS(1)+XMASS(2))**2) CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2, & (XMASS(1)+XMASS(2))**2) DEM = ZERO DO I=1,IMAXCH IF(CHON(I)) THEN C--factors due to the choice of s and t IF(I.LE.2) THEN G(I) = SN*S1 ELSEIF(I.LE.6) THEN G(I) = TN*S2 ELSE G(I) = UN*S2 ENDIF C--factors due to the boson masses CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)), & (PHEP(5,3)-EMMIN)**2,EMMIN**2) CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)), & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2) G(I) = G(I)*MB1*MB2*XF DEM = DEM+CHNPRB(I)*G(I) ENDIF ENDDO C--now combine everything to get the weight WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)* & MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC GEN = .TRUE. C--compute the weights for the different channels if optimizing IF(OPTM) THEN DO I=1,IMAXCH IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM ENDDO ENDIF END CDECK ID>, HWHGB1. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN) C----------------------------------------------------------------------- C Subroutine to select gauge boson mass for HWHGBP C ISM=1 select according to Breit-Wigner for IDBOZ C ISM=2 select according to power law for IDBOZ C IOPT=1 return the function at MBOS2 C IOPT=2 calculate MBOS2 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IDBOZ,ISM,IOPT DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN, & MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ EXTERNAL HWRGEN C--set the boson mass IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN MBOZ = RMASS(198) GBOZ = GAMW ELSEIF(IDBOZ.EQ.200) THEN MBOZ = RMASS(200) GBOZ = GAMZ ELSE CALL HWWARN('HWHGB1',500) ENDIF EMSQ=MBOZ**2 GMBOZ=MBOZ*GBOZ C--smooth a Breit-Wigner only IF(ISM.EQ.1) THEN A02 = ATAN((MMIN-EMSQ)/GMBOZ) A2 = ATAN((MMAX-EMSQ)/GMBOZ)-A02 IF(IOPT.EQ.1) THEN FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2 ELSE MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1)) FJAC = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ ENDIF C--smooth a powerlaw only ELSEIF(ISM.EQ.2) THEN IF(EMPOW.EQ.TWO) THEN A01 = LOG(MMIN) A1 = LOG(MMAX)-A01 IF(IOPT.EQ.1) THEN FJAC = ONE/MBOS2/A1 ELSE MBOS2 = EXP(A01+A1*HWRGEN(2)) FJAC = A1*MBOS2 ENDIF ELSE MPOW = -EMPOW/TWO QPOW = ONE+MPOW RPOW = ONE/QPOW A01 = MMIN**QPOW A1 = (MMAX**QPOW-A01) IF(IOPT.EQ.1) THEN FJAC = QPOW*MBOS2**MPOW/A1 ELSE MBOS2 = (A01+A1*HWRGEN(2))**RPOW FJAC = A1*RPOW/MBOS2**MPOW ENDIF ENDIF ELSE CALL HWWARN('HWHGB1',501) ENDIF END CDECK ID>, HWHGB2. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGB2(HCS,IDP,PHOTON) C----------------------------------------------------------------------- C WW cross section in hadron hadron C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2, & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2), & CSW,CFAC1 DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW, & CWW,DWW,AWWM(2),AWWP(2),HWHEW4 INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4 PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0), & ZHF=(0.5D0,0.0D0)) LOGICAL PHOTON EXTERNAL HWRGEN,HWHEW4 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1 SAVE WAMP,AWWM,AWWP SAVE MAPZ DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/ IF(GENEV) THEN RCS = HCS*HWRGEN(1) ELSE C--Now calculate the matrix element Z12 = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ) P12 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2) S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4)) S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6)) S34 = DBLE(Z2*ZD(3,4)) S56 = DBLE(Z2*ZD(5,6)) KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2) & /SWEIN**4/16.0D0 DO I=1,2 DWW = LF(I)*Z12-RF(I)*P12 CWW = RF(I)*(Z12-P12) AWW = DWW + ZHF*S134*(TAUI(I)+ONE) BWW = DWW + ZHF*S156*(TAUI(I)-ONE) AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4) AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6)) WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I)) & +AWWP(I)*DCONJG(AWWP(I))) ENDDO ENDIF HCS = ZERO CFAC = CFAC1*81.0D0 DO I=1,2 DO I1=1,3 IDP(1) = MAPZ(I,I1) IDP(2) = IDP(1)+6 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2) DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2) DO I2=1,2 HCS = HCS+DIST(I2)*CFAC*WAMP(I) IF(GENEV.AND.HCS.GT.RCS) THEN C--new for spin correlations IF(SYSPIN) THEN NSPN = 1 DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0) MESPN(1,2,2,1,1,1) = AWWP(I) MESPN(2,2,2,1,1,1) = AWWM(I) NCFL(1) = 1 SPNCFC(1,1,1) = ONE ENDIF GOTO 999 ENDIF IDP(1) = IDP(1)+6 IDP(2) = IDP(2)-6 ENDDO ENDDO ENDDO 999 RETURN END CDECK ID>, HWHGB3. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGB3(HCS,IDP,PHOTON) C----------------------------------------------------------------------- C ZZ cross section in hadron hadron C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC, & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2), & CSW,CFAC1 DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156, & HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2) EXTERNAL HWHEW4,HWRGEN LOGICAL PHOTON COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0)) SAVE AMP,ID,AMPT SAVE MAPZ,O DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/ DATA O/2,1/ C--initialisation IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4) DO I=1,2 ID(I) = IDP(1+2*I) IF(ID(I).GE.121) ID(I) = ID(I)-114 ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1 ENDDO C--the various propagators we need S34 = TWO*DBLE(ZD(3,4)) S56 = TWO*DBLE(ZD(5,6)) Z34 = ONE/(S34-MZ2+Z1*GMZ) Z56 = ONE/(S56-MZ2+Z1*GMZ) IF(PHOTON) THEN P34 = Z34*(S34-MZ2)/S34 P56 = Z56*(S56-MZ2)/S56 ELSE P34 = Z0 P56 = Z0 ENDIF S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4)) S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6)) C--Now calculate the amplitudes ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156 ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156 ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156 ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156 ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134 ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134 ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134 ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134 C--Now the amplitudes squared for the process DO I=1,2 TAMP = Z0 DO P1=1,2 DO P2=1,2 DO P3=1,2 IF(PHOTON) THEN CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56 & +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56 & +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56 & +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56 ELSE CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56 ENDIF AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3)) ENDDO ENDDO ENDDO AMP(I) = HALF*DBLE(TAMP) ENDDO ENDIF C--Now calculate the cross section HCS = 0.0D0 CFAC = CFAC1 IF(ID(1).LE.2) CFAC = CFAC*THREE IF(ID(2).LE.2) CFAC = CFAC*THREE DO I=1,2 DO I1=1,3 IDP(1) = MAPZ(I,I1) IDP(2) = MAPZ(I,I1)+6 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2) DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2) DO I2=1,2 HCS = HCS+CFAC*DIST(I2)*AMP(I) IF(GENEV.AND.HCS.GT.RCS) THEN C--New for spin correlations IF(SYSPIN) THEN NSPN = 1 DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3)) 10 MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0) NCFL(1) = 1 SPNCFC(1,1,1) = ONE ENDIF GOTO 999 ENDIF ENDDO IDP(1) = IDP(1)+6 IDP(2) = IDP(2)-6 ENDDO ENDDO 999 RETURN END CDECK ID>, HWHGB4. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGB4(HCS,IDP,PHOTON) C----------------------------------------------------------------------- C WZ cross section in hadron hadron C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC, & TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2), & TAUI(2),CSW,CFAC1 DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4, & CP(4),W12,F(4),TAMP(2,2) INTEGER IDP(10),I,J,I1,I2,ID,P1,P2,P3,P4 LOGICAL PHOTON EXTERNAL HWRGEN,HWHEW4 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8) COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0)) SAVE AMP,ID,TAMP IF(GENEV) THEN RCS = HCS*HWRGEN(1) ELSE C--identity of the Z decay product (d=1,u=2,e=3,nu=4) ID = IDP(5) IF(ID.GE.121) ID = ID-114 ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1 C--the various propagators we need S12 = TWO*DBLE(ZD(1,2)) S34 = TWO*DBLE(ZD(3,4)) S56 = TWO*DBLE(ZD(5,6)) Z56 = ONE/(S56-MZ2+Z1*GMZ) IF(PHOTON) THEN P56 = Z56*(S56-MZ2)/S56 ELSE P56 = Z0 ENDIF W12 = ONE/(S12-MW2+Z1*GMW) S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4)) S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6)) W34 = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR C--calculate the coefficents of the various amplitudes F(1) = HWHEW4(1,2,3,4,5,6) F(2) = HWHEW4(1,2,5,6,3,4) F(3) = HWHEW4(1,2,3,4,6,5) F(4) = HWHEW4(1,2,6,5,3,4) DO I=1,2 IF(I.EQ.1) THEN J=2 ELSE J=1 ENDIF CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12 CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12 IF(PHOTON) THEN CP(3) = EE(J)*S134-TAUI(I)*W12 CP(4) = EE(I)*S156+TAUI(I)*W12 ELSE CP(3) = Z0 CP(4) = Z0 ENDIF TAMP(I,1) = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3)) & +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4)) TAMP(I,2) = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3)) & +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4)) AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1)) & +TAMP(I,2)*DCONJG(TAMP(I,2))) ENDDO ENDIF C--Now calculate the cross section HCS = ZERO CFAC = CFAC1*9.0D0 IF(ID.LE.2) CFAC = CFAC*THREE DO I=1,2 DO I1=1,3 IF(I.EQ.1) THEN IDP(1) = 2*I1+5 ELSE IDP(1) = 2*I1+6 ENDIF DO J=1,3 IF(I.EQ.1) THEN IDP(2) = 2*J C**Bug fix 2/7/01 by BRW (unsquare) TCS = VCKM(J,I1) ELSE IDP(2) = 2*J-1 TCS = VCKM(I1,J) C**End bug fix ENDIF DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2) DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2) DO I2=1,2 HCS = HCS+CFAC*DIST(I2)*AMP(I) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 ENDDO ENDDO ENDDO ENDDO 900 IF(GENEV.AND.I2.EQ.2) THEN I1 = IDP(1) IDP(1) = IDP(2) IDP(2) = I1 ENDIF IF(SYSPIN.AND.GENEV) THEN NSPN = 1 DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0) MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2) MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1) NCFL(1) = 1 SPNCFC(1,1,1) = ONE ENDIF END CDECK ID>, HWHGB5. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN) C----------------------------------------------------------------------- C Subroutine to select t or u for HWHGBP C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IOPT DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN, & TX,MT EXTERNAL HWRGEN TPOW = -1.0D0 TX = -TMIN TN = -TMAX IF(TPOW.EQ.-ONE) THEN A1 = LOG(TX/TN) IF(IOPT.EQ.1) THEN FJAC =-ONE/T/A1 ELSE T = -TN*EXP(A1*HWRGEN(2)) FJAC =-A1*T ENDIF ELSE QPOW = ONE+TPOW RPOW = ONE/QPOW A01 = TN**QPOW A1 = (TX**QPOW-A01) IF(IOPT.EQ.1) THEN MT = -T FJAC =QPOW*MT**TPOW/A1 ELSE MT = (A01+A1*HWRGEN(2))**RPOW T = -MT FJAC = A1*RPOW/MT**TPOW ENDIF ENDIF END CDECK ID>, HWHGRV. *CMZ :- -13/10/00 10:48:07 by Peter Richardson *-- Author Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWHGRV C----------------------------------------------------------------------- C Massive spin-2 resonance (massive graviton) C Universal tensor coupling to the energy-momentum tensor is assumed C viz L = - G(mu,nu) T(mu,nu) / GRVLAM C If GAMGRV is zero, it is revaluated during the first run C MEAN EVWGT = SIGMA IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG, & EMGMG,S,CC,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3), & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4, & IADD(2,2) LOGICAL JGLU,JPHO,JW,JZ,JH EXTERNAL HWRGEN,HWRUNI SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG, & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6 PARAMETER (EPS=1.D-9) SAVE IADD DATA IADD/0,6,6,0/ IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE IF (FSTWGT) THEN C Set limits for which particles to include JLMN=1 JLMX=0 JQMN=1 JQMX=0 JGLU=.FALSE. JPHO=.FALSE. JW =.FALSE. JZ =.FALSE. JH =.FALSE. IMODE=MOD(IPROC,100) IF (IMODE.EQ.0) THEN JQMN=1 JQMX=6 JGLU=.TRUE. JLMN=11 JLMX=16 JPHO=.TRUE. JW =.TRUE. JZ =.TRUE. JH =.TRUE. ELSEIF (IMODE.EQ.10) THEN JQMN=1 JQMX=6 JGLU=.TRUE. ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN JQMN=IMODE-10 JQMX=IMODE-10 ELSEIF (IMODE.EQ.20) THEN JGLU=.TRUE. ELSEIF (IMODE.EQ.50) THEN JLMN=11 JLMX=16 JPHO=.TRUE. ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN JLMN=IMODE-40 JLMX=IMODE-40 ELSEIF (IMODE.EQ.60) THEN JPHO=.TRUE. ELSEIF (IMODE.EQ.70) THEN JW =.TRUE. JZ =.TRUE. JH =.TRUE. ELSEIF (IMODE.EQ.71) THEN JW =.TRUE. ELSEIF (IMODE.EQ.72) THEN JZ =.TRUE. ELSEIF (IMODE.EQ.73) THEN JH =.TRUE. ELSE CALL HWWARN('HWHGRV',500) ENDIF RNGLU=CAFAC**2-ONE IF (GAMGRV.EQ.ZERO) THEN C Calculate the width if GAMGRV=ZERO. C Quarks DO 10 JQ=1,6 RGRV=(RMASS(JQ)/EMGRV)**2 QPE=ONE-4.D0*RGRV IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0 END IF 10 CONTINUE C Leptons DO 20 JL=121,126 RGRV=(RMASS(JL)/EMGRV)**2 QPE=ONE-4.D0*RGRV IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0 END IF 20 CONTINUE C Photons GAMGRV=GAMGRV+HALF C gg GAMGRV=GAMGRV+HALF*RNGLU C ZZ RGRV=(RMASS(200)/EMGRV)**2 QPE=ONE-4.D0*RGRV IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) GAMGRV=GAMGRV+SQPE* & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO END IF C WW RGRV=(RMASS(198)/EMGRV)**2 QPE=ONE-4.D0*RGRV IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) GAMGRV=GAMGRV+SQPE* & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2) END IF C HH RGRV=(RMASS(201)/EMGRV)**2 QPE=ONE-4.D0*RGRV IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) GAMGRV=GAMGRV+SQPE**5/12.D0/TWO END IF GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC) END IF EMSQG=EMGRV**2 EMGMG=EMGRV*GAMGRV A02=ATAN((EMMIN**2-EMSQG)/EMGMG) A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02 ENDIF EVWGT=0. C Select a mass for the produced pair S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1)) EMSCA=SQRT(S) C Select initial momentum fractions XXMIN=S/PHEP(5,3)**2 XLMIN=LOG(XXMIN) CALL HWSGEN(.TRUE.) COSTH=HWRUNI(0,-ONE,ONE) C FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC) CC = COSTH**2 SS = ONE-CC SS2= SS**2 C QQ,GG -> FF DO 110 I=1,6 JQ=I JL=I+10 QPE=ONE-4.D0*RMASS(JQ)**2/S IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU ELSE M1(JQ)=ZERO M2(JQ)=ZERO END IF QPE=ONE-4.D0*RMASS(JL+110)**2/S IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU ELSE M1(JL)=ZERO M2(JL)=ZERO END IF 110 CONTINUE C QQ,GG -> BB (massless) M3=SS*(ONE+CC)/32.D0/CAFAC M4=(CC+SS2/8.D0)/4.D0/RNGLU C QQ,GG -> W,Z,H QPE=ONE-4.D0*RMASS(198)**2/S IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU ELSE M5(1)=ZERO M6(1)=ZERO END IF QPE=ONE-4.D0*RMASS(200)**2/S IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU ELSE M5(2)=ZERO M6(2)=ZERO END IF QPE=ONE-4.D0*RMASS(201)**2/S IF (QPE.GT.ZERO) THEN SQPE=SQRT(QPE) M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU ELSE M5(3)=ZERO M6(3)=ZERO END IF END IF HCS=ZERO DO 90 I=1,2 C I=1 quark first, I=2 anti-quark first DO 80 IQ=1,6 ID1=IQ+IADD(1,I) ID2=IQ+IADD(2,I) IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2) C Quark final states DO 60 JQ=JQMN,JQMX ID3=JQ ID4=JQ+6 HCS=HCS+FACTR*M1(JQ)*CAFAC IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,50) GOTO 99 ENDIF 60 CONTINUE C Lepton final states DO 70 JL=JLMN,JLMX ID3=110+JL ID4=ID3+6 HCS=HCS+FACTR*M1(JL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF 70 CONTINUE C Bosonic final states IF (JPHO) THEN ID3=59 ID4=59 HCS=HCS+FACTR*M3 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF END IF IF (JW) THEN ID3=198 ID4=199 HCS=HCS+FACTR*M5(1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF END IF IF (JZ) THEN ID3=200 ID4=200 HCS=HCS+FACTR*M5(2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF END IF IF (JH) THEN ID3=201 ID4=201 HCS=HCS+FACTR*M5(3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,50) GOTO 99 ENDIF END IF IF (JGLU) THEN ID3=13 ID4=13 HCS=HCS+FACTR*M3*RNGLU IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,50) GOTO 99 ENDIF END IF 80 CONTINUE 90 CONTINUE C Gluon initial states ID1=13 ID2=13 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2) C Quark final states DO 40 JQ=JQMN,JQMX ID3=JQ ID4=JQ+6 HCS=HCS+FACTR*M2(JQ)*CAFAC IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,51) GOTO 99 ENDIF 40 CONTINUE C Lepton final states DO 50 JL=JLMN,JLMX ID3=110+JL ID4=ID3+6 HCS=HCS+FACTR*M2(JL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,51) GOTO 99 ENDIF 50 CONTINUE C Vector boson final states IF (JPHO) THEN ID3=59 ID4=59 HCS=HCS+FACTR*M4 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,51) GOTO 99 ENDIF END IF IF (JW) THEN ID3=198 ID4=199 HCS=HCS+FACTR*M6(1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,51) GOTO 99 ENDIF END IF IF (JZ) THEN ID3=200 ID4=200 HCS=HCS+FACTR*M6(2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,51) GOTO 99 ENDIF END IF IF (JH) THEN ID3=201 ID4=201 HCS=HCS+FACTR*M6(3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2134,51) GOTO 99 ENDIF END IF IF (JGLU) THEN ID3=13 ID4=13 HCS=HCS+FACTR*M4*RNGLU IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,2143,51) GOTO 99 ENDIF END IF 30 CONTINUE EVWGT=HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=208 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices C Set to zero for now CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHGUP. *CMZ :- -16/07/02 09.40.25 by Peter Richardson *-- Author : Peter Richardson C---------------------------------------------------------------------- SUBROUTINE HWHGUP C---------------------------------------------------------------------- C Use the GUPI (Generic User Process Interface) event common block C as the hard process for HERWIG C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' C--Les Houches Common Block INTEGER MAXPUP PARAMETER(MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP), & XMAXUP(MAXPUP),LPRUP(MAXPUP) INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP, & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP), & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP), & SPINUP(MAXNUP) C--Local variables COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP) INTEGER ILOC,JLOC,JHEP,ID,IPHO,LTRY INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J COMMON/PHOCOM/XEPHO DOUBLE PRECISION PTEMP(5),XEPHO CHARACTER *8 DUMMY LOGICAL HWRLOG EXTERNAL HWRLOG IRES = 0 C--zero the variables DO I=1,NUP JLOC(I) = 0 ENDDO DO I=1,NMXHEP ILOC(I) = 0 ENDDO c---generate hard subprocess C--now do the event selection bit IF(.NOT.GENEV) THEN IDPRUP = LPRUP(ITYPLH) CALL UPEVNT IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR. & ABS(IDWTUP).EQ.4) THEN EVWGT = XWGTUP*1.0D-3 ELSEIF(ABS(IDWTUP).EQ.3) THEN EVWGT = SIGN(ONE,XWGTUP) ELSE CALL HWWARN('HWHGUP',510) ENDIF C--check the sign of the weight IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO) CALL HWWARN('HWHGUP',520) RETURN ENDIF C--update the number of events LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1 ITYPLH = 0 C--first search to see if there are incoming beam particles in the record I = 0 DO IHEP=1,NUP IF(ISTUP(IHEP).EQ.-9) THEN I=I+1 IF(I.EQ.3) THEN CALL HWWARN('HWHGUP',102) GOTO 999 ENDIF IDIN(I) = IHEP ENDIF ENDDO C--put the beam particles in the record C--require the soft event GENSOF = LHSOFT.AND.HWRLOG(PRSOF) C--if given for event from event common block NHEP = 0 IF(I.EQ.2) THEN C--otherwise from the process common block ELSEIF(I.EQ.0) THEN DO I=1,2 CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY) PHEP(1,I) = ZERO PHEP(2,I) = ZERO PHEP(4,I) = EBMUP(I) PHEP(5,I) = RMASS(IDHW(I)) PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2) ISTHEP(I) = 100+I ENDDO PHEP(3,2) = -PHEP(3,2) NHEP = NHEP+2 C--if not correct issue warning ELSE CALL HWWARN('HWHGUP',103) GOTO 999 ENDIF C--setup the centre-of-mass energy CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1)) CALL HWUMAS(PHEP(1,NHEP+1)) JMOHEP(1,NHEP+1) = NHEP-1 JMOHEP(2,NHEP+1) = NHEP IDHW(3) = 14 ISTHEP(3) = 103 NHEP = NHEP+1 C--search for the incoming particles in collision I = 0 DO IHEP=1,NUP IF(ISTUP(IHEP).EQ.-1) THEN I = I+1 IF(I.EQ.3) THEN CALL HWWARN('HWHGUP',100) GOTO 999 ENDIF IDIN(I) = IHEP ENDIF ENDDO C--require two incoming particles IF(I.NE.2) THEN CALL HWWARN('HWHGUP',101) GOTO 999 ENDIF C--special for MC@NLO photoproduction IF (ABS(IDPRUP/100).EQ.51) THEN IF (IDUP(IDIN(1)).EQ.22) THEN IPHO=IDIN(1) ELSE IPHO=NUP+1 CALL HWVZRO(5,PUP(1,IPHO)) PUP(4,IPHO)=XEPHO PUP(3,IPHO)=PUP(4,IPHO) ENDIF C--recompute cmf CALL HWVSUM(4,PHEP(1,2),PUP(1,IPHO),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) JMOHEP(1,NHEP)=NHEP+1 C--insert photon NHEP=NHEP+1 CALL HWVEQU(5,PUP(1,IPHO),PHEP(1,NHEP)) IDHEP(NHEP)=22 CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),DUMMY) ISTHEP(NHEP)=3 JMOHEP(1,NHEP)=1 JDAHEP(1,1)=NHEP C--insert outgoing beam particle NHEP=NHEP+1 CALL HWVDIF(4,PHEP(1,1),PUP(1,IPHO),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) IDHEP(NHEP)=IDHEP(1) IDHW(NHEP)=IDHW(1) ISTHEP(NHEP)=1 JMOHEP(1,NHEP)=1 JDAHEP(2,1)=NHEP ENDIF C--Now write incoming particles into the event record DO I=1,2 IDHEP(NHEP+I) = IDUP(IDIN(I)) ISTHEP(NHEP+I) = 110+I CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY) CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I)) JMOHEP(1,NHEP+I) = NHEP+3 ILOC(NHEP+I) = IDIN(I) JLOC(I) = NHEP+I C--special for particles which are identical to the beam DO J=1,2 IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN JDAHEP(1,J) = NHEP+I JDAHEP(2,J) = NHEP+I ENDIF ENDDO ENDDO CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3)) CALL HWUMAS(PHEP(1,NHEP+3)) C--add the hard entry IDHW(NHEP+3) = 15 IDHEP(NHEP+3)=0 ISTHEP(NHEP+3) = 110 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+2 JDAHEP(1,NHEP+3) = NHEP+4 NHEP = NHEP+3 ICMF = NHEP C--now search for the outgoing particles and add them to the event record DO I=1,NUP C--normal outgoing particles IF(ISTUP(I).EQ.1.AND. & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN NHEP = NHEP+1 IDHEP(NHEP) = IDUP(I) CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY) CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP)) JMOHEP(1,NHEP) = ICMF JMOHEP(2,NHEP) = 0 JDAHEP(2,NHEP) = 0 ILOC(NHEP) = I JLOC(I) = NHEP C--resonances which must have mass preserved and resonances C-- which don't have to have mass preserved C--for the time being we won't disguish between these two options ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND. & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN NHEP = NHEP+1 IDHEP(NHEP) = IDUP(I) CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY) CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP)) IRES = IRES+1 IDRES(1,IRES) = NHEP IDRES(2,IRES) = I JMOHEP(1,NHEP) = ICMF JMOHEP(2,NHEP) = 0 JDAHEP(2,NHEP) = 0 ILOC(NHEP) = I JLOC(I) = NHEP ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND. & ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN CALL HWWARN('HWHGUP',500) ENDIF ENDDO C--Modified 2/7/03 for 2->1 processes IF(ICMF+1.EQ.NHEP) THEN NHEP = NHEP-1 IDHEP(NHEP) = IDHEP(NHEP+1) IDHEP(NHEP+1) = 0 IDHW(NHEP) = IDHW(NHEP+1) IDHW(NHEP+1) = 0 CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP)) JMOHEP(1,NHEP+1) = 0 JMOHEP(2,NHEP+1) = 0 JDAHEP(1,NHEP+1) = 0 JDAHEP(2,NHEP+1) = 0 JDAHEP(1,NHEP ) = NHEP JDAHEP(2,NHEP ) = NHEP ILOC(NHEP) = ILOC(NHEP+1) ILOC(NHEP+1) = 0 JLOC(ILOC(NHEP)) = NHEP JLOC(NHEP+1) = 0 DO I=1,IRES IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP ENDDO ELSE JDAHEP(2,ICMF) = NHEP C--setup the status codes ISTHEP(ICMF+1) = 113 DO IHEP=ICMF+2,NHEP ISTHEP(IHEP) = 114 ENDDO ENDIF C--End mod ISTART = ICMF-3 EMSCA = SCALUP C--generate parton shower CALL HWBGUP(ISTART,ICMF) IF (IERROR.NE.0) RETURN C--now we need to sort out the resonances IF(IRES.EQ.0) RETURN JRES = 1 35 ID = IDHEP(IDRES(1,JRES)) C--BRW fix to close ticket 51 caused problems: revert to Kluth solution LTRY=0 36 IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND. & JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN LTRY=LTRY+1 IF (LTRY.GT.NSNTRY) THEN CALL HWWARN('HWHGUP',199) GOTO 999 ENDIF IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES)) IF(IDHEP(IHEP).EQ.ID) THEN IDRES(1,JRES) = IHEP GOTO 36 ENDIF ENDDO ELSE IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES)) ENDIF GOTO 36 ENDIF C--make a copy of this particle IHEP = IDRES(1,JRES) JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES)) JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES)) IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES)) IDHW(NHEP+1) = IDHW(IDRES(1,JRES)) CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1)) IDRES(1,JRES) = NHEP+1 JLOC(IDRES(2,JRES)) = IDRES(1,JRES) ISTHEP(NHEP+1) = 155 NHEP = NHEP+1 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 Relabel original track IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3 JMOHEP(2,IHEP)=JMOHEP(1,IHEP) JDAHEP(1,IHEP)=NHEP JDAHEP(2,IHEP)=NHEP C--look for all the particles which have this as a mother C--now search for the outgoing particles and add them to the event record JDAHEP(1,NHEP) = NHEP+1 ISTHEP(NHEP+1) = 113 DO I=1,NUP IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN NHEP = NHEP+1 IDHEP(NHEP) = IDUP(I) CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY) CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP)) CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP)) JMOHEP(1,NHEP) = IDRES(1,JRES) JMOHEP(2,NHEP) = 0 JDAHEP(2,NHEP) = 0 ILOC(NHEP) = I JLOC(I) = NHEP ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND. & MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN NHEP = NHEP+1 IDHEP(NHEP) = IDUP(I) CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY) CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP)) CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP)) IRES = IRES+1 IDRES(1,IRES) = NHEP IDRES(2,IRES) = I JMOHEP(1,NHEP) = IDRES(1,JRES) JMOHEP(2,NHEP) = 0 JDAHEP(2,NHEP) = 0 ILOC(NHEP) = I JLOC(I) = NHEP ENDIF ENDDO C--special for top decays to ensure b is second and W is first, this seems C--to cause problems if the order is the other way around IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND. & NHEP-IDRES(1,JRES).EQ.2) THEN IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN C--swap momenta CALL HWVEQU(5,PHEP(1,NHEP),PTEMP) CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP)) CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1)) C--swap id's J = IDHW(NHEP) IDHW(NHEP) = IDHW(NHEP-1) IDHW(NHEP-1) = J J = IDHEP(NHEP) IDHEP(NHEP) = IDHEP(NHEP-1) IDHEP(NHEP-1) = J C--locations J = ILOC(NHEP) ILOC(NHEP) = ILOC(NHEP-1) ILOC(NHEP-1) = J JLOC(ILOC(NHEP-1)) = NHEP-1 JLOC(ILOC(NHEP)) = NHEP C--resonances DO I=1,IRES IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1 ENDDO ENDIF ENDIF DO IHEP=IDRES(1,JRES)+2,NHEP ISTHEP(IHEP) = 114 ENDDO JDAHEP(2,IDRES(1,JRES)) = NHEP ISTART = IDRES(1,JRES) C--BRW mod 21/11/06 for pt-veto IF (.NOT.PTVETO) EMSCA = PHEP(4,IDRES(1,JRES)) CALL HWBGUP(ISTART,0) IF (IERROR.NE.0) RETURN IF(JRES.NE.IRES) THEN JRES = JRES+1 GOTO 35 ENDIF 999 RETURN END CDECK ID>, HWHHVY. *CMZ :- -18/05/99 14.55.44 by Kosuke Odagiri *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHHVY C----------------------------------------------------------------------- C QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ, & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU, & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2, & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP INTEGER IQ1,IQ2,ID1,ID2 LOGICAL HQ1,HQ2 EXTERNAL HWRGEN,HWRUNI,HWUALF C---BRW mod 30/01/07: save IQ1 SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US,IQ1 PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK = ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) ) YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) ) YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=HALF*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN S=XX(1)*XX(2)*PHEP(5,3)**2 IQ1=MOD(IPROC,100) QM2=RMASS(IQ1)**2 QPE=S-4.*QM2 IF (QPE.LE.ZERO) RETURN COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE) IF (ABS(COSTH).GT.ONE) RETURN C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4 S=HALF*S T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2 U=-S-T C---SET EMSCA TO HEAVY HARD PROCESS SCALE EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U)) FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2 & *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) CALL HWSGEN(.FALSE.) C ST=S/T TU=T/U UT=U/T US=U/S SU=S/U TUS=US/ST UST=ST/TU C EN=CAFAC RN=CFFAC/EN AF=FACTR*RN ASTU=AF*(1.-2.*UST+QM2/T) AUST=AF*(1.-2.*TUS+QM2/S) CF=FACTR/(2.*CFFAC) CN=1./(EN*EN) C----------------------------------------------------------------------- C---Heavy flavour colour decomposition modifications below (KO) C----------------------------------------------------------------------- CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO) CSTU=CF*CS/(ONE+TU**2) CSUT=CF*CS/(ONE+UT**2) CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO) CTSU=-FACTR*CS/(ONE+SU**2) CTUS=-FACTR*CS/(ONE+US**2) C----------------------------------------------------------------------- C CS=HALF/TU-QM2/T-HALF*(QM2/T)**2 C CSTU=CF*(CS- US**2-QM2/S - CN*(CS+QM2*QM2/(S*T))) C CS=HALF*TU-QM2/U-HALF*(QM2/U)**2 C CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U))) C CS=HALF*US-QM2/S-HALF*(QM2/S)**2 C CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T))) C CS=HALF/US-QM2/U-HALF*(QM2/U)**2 C CTUS=-FACTR*(CS- ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U))) C----------------------------------------------------------------------- ENDIF C HCS=0. IQ2=IQ1+6 DO 6 ID1=1,13 IF (DISF(ID1,1).LT.EPS) GOTO 6 HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2 DO 5 ID2=1,13 IF (DISF(ID2,2).LT.EPS) GOTO 5 HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2 DIST=DISF(ID1,1)*DISF(ID2,2) IF (HQ1.OR.HQ2) THEN C---PROCESSES INVOLVING HEAVY CONSTITUENT C N.B. NEGLECT CASE THAT BOTH ARE HEAVY IF (HQ1.AND.HQ2) GOTO 5 IF (ID1.LT.7) THEN C---QUARK FIRST IF (ID2.LT.7) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421, 3) GOTO 9 ENDIF ELSEIF (ID2.NE.13) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142, 9) GOTO 9 ENDIF ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142,10) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,11) GOTO 9 ENDIF ENDIF ELSEIF (ID1.NE.13) THEN C---QBAR FIRST IF (ID2.LT.7) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,17) GOTO 9 ENDIF ELSEIF (ID2.NE.13) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,20) GOTO 9 ENDIF ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,21) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,22) GOTO 9 ENDIF ENDIF ELSE C---GLUON FIRST IF (ID2.LT.7) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,23) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,24) GOTO 9 ENDIF ELSEIF (ID2.LT.13) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142,25) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,26) GOTO 9 ENDIF ENDIF ENDIF ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN C---LIGHT Q-QBAR ANNIHILATION HCS=HCS+AUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IQ1,IQ2,2413, 4) GOTO 9 ENDIF ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN C---LIGHT QBAR-Q ANNIHILATION HCS=HCS+AUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IQ2,IQ1,3142,12) GOTO 9 ENDIF ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN C---GLUON FUSION HCS=HCS+CSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IQ1,IQ2,2413,27) GOTO 9 ENDIF HCS=HCS+CSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IQ1,IQ2,4123,28) GOTO 9 ENDIF ENDIF 5 CONTINUE 6 CONTINUE EVWGT=HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR. & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN C qqbar-->gg or qbarq-->gg UT=1./TU GCOEF(1)=UT+TU GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=UT-TU GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR. & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR. & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR. & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar SU=1./US GCOEF(1)=-(SU+US) GCOEF(2)=0. GCOEF(3)=2. GCOEF(4)=0. GCOEF(5)=SU-US GCOEF(6)=GCOEF(1) GCOEF(7)=-GCOEF(5) ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN C gg-->qqbar UT=1./TU GCOEF(1)=TU+UT GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=TU-UT GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR. & IHPRO.EQ.31) THEN C gg-->gg GT=S*S+T*T+U*U GCOEF(2)=2.*U*U*T*T GCOEF(3)=2.*S*S*U*U GCOEF(4)=2.*S*S*T*T GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4) GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2) GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3) GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4) ELSE CALL HWVZRO(7,GCOEF) ENDIF ENDIF END CDECK ID>, HWHIBG. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Kosuke Odagiri & Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450 C...as described in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 6-AUG-1999 by Kosuke Odagiri C...Last modified: 6-SEP-1999 by Stefano Moretti C C----------------------------------------------------------------------- SUBROUTINE HWHIBG C----------------------------------------------------------------------- C HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4, & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN, & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3), & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX, & CTMP, PCM, PCM2, RCM, RCM2, FKLN INTEGER ID1, ID2, IH, IQ, I EXTERNAL HWRGEN, HWUALF, HWUAEM SAVE HCS,ME2,S,SHAT PARAMETER (EPS = 1.D-9) EQUIVALENCE (MW, RMASS(198)) PARAMETER (EMG=0.,EMG2=0.) C...generate event. IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE HCS = ZERO EVWGT = ZERO C...minimum transverse momentum. PTMIN = ZERO PT2MIN = PTMIN**2 C...accompanying quark. IQ=5 IF(IHIGGS.GE.5)IQ=6 EMQ=RMASS(IQ) EMQ2=EMQ*EMQ C...on-shell Higgs. EMH=RMASS(201+IHIGGS) EMHWT=1.D0 EMH2=EMH*EMH RMMIN=(EMQ+EMH)/2. C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|), C...IF IQ=6 -> X(1)=COS(THETA_CM); C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2), C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU), C...phase space borders. IF(IQ.EQ.5)XL(1)=0. IF(IQ.EQ.6)XL(1)=-1. XU(1)=1. XL(2)=0. XU(2)=1. XL(3)=0. XU(3)=1. C...single phase space point. WEIGHT=1. DO I=1,3 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...energy at parton level. ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(3))) XX(2)=TAU/XX(1) C...reconstruct polar angle. IF(IQ.EQ.5)THEN PCM2=((SHAT-EMQ2-EMG2)**2 & -(2.*EMQ*EMG)**2)/(4.*SHAT) PCM=SQRT(PCM2) RCM2=((SHAT-EMQ2-EMH2)**2 & -(2.*EMQ*EMH)**2)/(4.*SHAT) RCM=SQRT(RCM2) FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2)) & *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2)) TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2) & -FKLN) TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2) & +FKLN) TLMAX=LOG(ABS(TTMIN)) TLMIN=LOG(ABS(TTMAX)) TL=X(1)*(TLMAX-TLMIN)+TLMIN T=EXP(TL) CTMP=-T-EMG2-EMQ2 & +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2) COSTH = CTMP/2./PCM/RCM ELSE IF(IQ.EQ.6)THEN COSTH = X(1) END IF SN2TH = 0.25D0 - 0.25D0*COSTH**2 IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN EVWGT=0. RETURN END IF T3 = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT U4 = - T3 - SHAT EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2) EMSCA = SQRT( EMSC2 ) CALL HWSGEN(.FALSE.) EVWGT = ZERO XWEIN = TWO * SWEIN FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT & *HWUALF(1,EMSCA)/TWO/CAFAC/2. C...Jacobians from COSTH to X(1). IF(IQ.EQ.5)THEN FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T ELSE CONTINUE END IF C...Jacobians from X1,X2 to X(2),X(3). FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2) C...CKM mixing top/bottom quark. c bug fix 20/05/01 SM. IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3) c end of bug fix. C...Higgs resonance. FACTR=FACTR*EMHWT C...constant weight. FACTR=FACTR*WEIGHT C...SM/MSSM couplings. IF (IHIGGS.EQ.0) THEN GQH(0)=(RMASS(5)/MW)**2/TWO ELSE G1 = (RMASS(5)/MW/COSB)**2/TWO GQH(1) = G1*SINA**2 GQH(2) = G1*COSA**2 GQH(3) = G1*SINB**2 GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO END IF C...Matrix elements. DO IH = 0,4 ME2(IH) = ZERO END DO c c g b -> Q H c ID1 = 5 IH=IHIGGS IF(IHIGGS.NE.0)IH=IHIGGS-1 IF (IH.EQ.4) ID1 = 6 ID2 = 201+IHIGGS SM = RMASS(ID1)+RMASS(ID2) QPE = SHAT-SM**2 IF (QPE.GT.ZERO) THEN DM = RMASS(ID1)-RMASS(ID2) QPE = QPE*(SHAT-DM**2)/SHAT END IF PT2 = QPE*SN2TH IF (PT2.GT.PT2MIN) THEN SQPE = SQRT(QPE*SHAT) PF = SQPE/SHAT T3 = (SQPE*COSTH - SHAT - SM*DM) / TWO U4 = - T3 - SHAT ME2(IH) = FACTR*PF * GQH(IH) * & U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2) ELSE ME2(IH) = ZERO END IF END IF HCS = ZERO c c g b ID1 = 13 ID2 = 5 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 0,3 HCS = HCS + DIST*ME2(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(5,IHIGGS+201,2314,1) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2(4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(6,207,2314,1) GOTO 9 ENDIF END IF c _ c g b ID1 = 13 ID2 = 11 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 0,3 HCS = HCS + DIST*ME2(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(11,IHIGGS+201,3124,1) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2(4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(12,206,3124,1) GOTO 9 ENDIF END IF c c b g ID1 = 5 ID2 = 13 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 0,3 HCS = HCS + DIST*ME2(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IHIGGS+201,5,4132,1) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2(4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(207,6,4132,1) GOTO 9 ENDIF END IF c _ c b g ID1 = 11 ID2 = 13 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 0,3 HCS = HCS + DIST*ME2(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IHIGGS+201,11,2431,1) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2(4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(206,12,2431,1) GOTO 9 ENDIF END IF EVWGT = HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices C Set to zero for now CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHIBK. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described C...in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 8-APR-1999 by Stefano Moretti C SUBROUTINE HWHIBK C----------------------------------------------------------------------- C ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,IHEL DOUBLE PRECISION EMH,EMHWT,RMW,EMW DOUBLE PRECISION RMH DOUBLE PRECISION X(4),XL(4),XU(4) DOUBLE PRECISION CT,ST DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3) DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM DOUBLE PRECISION M2,M2L,M2T DOUBLE PRECISION ALPHA,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST DOUBLE PRECISION WEIGHT DOUBLE PRECISION VSAVE SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT LOGICAL HWRLOG EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG PARAMETER (EPS=1.D-9) EQUIVALENCE (RMW ,RMASS(198)) EQUIVALENCE (RMH ,RMASS(206)) IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE HCS=0. EVWGT=0. C...assign final state masses. EMH=RMH EMHWT=1.D0 C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=COS(THETA_CM), C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2), C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU), C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN), C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW); C...phase space borders. XL(1)=-1. XU(1)=1. XL(2)=0. XU(2)=1. XL(3)=0. XU(3)=1. XL(4)=0. XU(4)=1. C...single phase space point. WEIGHT=1. DO I=1,4 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...resonant boson mass (limits to -10*W-widths to improve efficiency). RNMIN=RMW-GAMMAX*GAMW THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW) RNMAX=ECM_MAX-EMH THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW) EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN)) & *RMW*GAMW+RMW*RMW) C...energy at parton level. ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(3))) XX(2)=TAU/XX(1) C...two particle kinematics. CT=X(1) IF(HWRLOG(HALF))THEN ST=+SQRT(1.-CT*CT) ELSE ST=-SQRT(1.-CT*CT) END IF RCM2=((SHAT-EMW*EMW-EMH*EMH)**2 & -(2.*EMW*EMH)**2)/(4.*SHAT) RCM=SQRT(RCM2) P3(0)=SQRT(RCM2+EMW*EMW) P3(1)=0. P3(2)=RCM*ST P3(3)=RCM*CT P4(0)=SQRT(RCM2+EMH*EMH) P4(1)=0. P4(2)=-RCM*ST P4(3)=-RCM*CT C...incoming parton: massless. EMIN=0. C...initial state momenta in the partonic CM. PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN*EMIN) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN*EMIN) P2(1)=0. P2(2)=0. P2(3)=-PCM C...color structured ME summed/averaged over final/initial spins and colors. CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T) IF(M2.LE.0.)RETURN C...charge conjugation. M2=M2*2. M2L=M2L*2. M2T=M2T*2. C...constant factors: phi along beam and conversion GeV^2->nb. FACT=2.*PIFAC*GEV2NB C...Jacobians from X1,X2 to X(2),X(3) FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2) C...phase space Jacobians, pi's and flux. FACT=FACT/64./PIFAC/PIFAC*RCM/PCM C...hard scale. EMSCA=RMW+RMH C...EW couplings. EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2 C...Higgs resonance. FACT=FACT*EMHWT C...vector boson resonance. FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC C...constant weight. FACT=FACT*WEIGHT END IF C...set up PDFs. HCS=0. CALL HWSGEN(.FALSE.) DO I=5,11,6 IF(DISF(I,1).LT.EPS)THEN GOTO 200 END IF IF(I.LE.6)J=I+6 IF(I.GE.7)J=I-6 IF(DISF(J,2).LT.EPS)THEN GOTO 200 END IF DIST=DISF(I,1)*DISF(J,2)*S C...no need to set up color connections. HCS=HCS+M2*DIST*FACT IF(GENEV.AND.HCS.GT.RCS)THEN C...generate event. IDN(1)=I IDN(2)=J IDN(3)=NINT(198.+HWRGEN(0)) IF(IDN(3).EQ.198)IDN(4)=207 IF(IDN(3).EQ.199)IDN(4)=206 C...set up status and IDs: use HWETWO. COSTH=CT IDCMF=15 ICO(1)=2 ICO(2)=1 ICO(3)=3 ICO(4)=4 C...trick HWETWO in using off-shell V mass VSAVE=RMASS(IDN(3)) RMASS(IDN(3))=EMW C-- BRW fix 27/8/04: avoid double smearing of V mass CALL HWETWO(.FALSE.,.TRUE.) RMASS(IDN(3))=VSAVE IF(AZSPIN)THEN C...set to zero the coefficients of the spin density matrices. CALL HWVZRO(7,GCOEF) END IF C...calculates approximately polarized decay matrix of gauge boson. IF(IERROR.NE.0)RETURN IHEL=0 IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1 IF(M2L.LT.0.)M2L=0. IF(M2T.LT.0.)M2T=0. RHOHEP(2,NHEP-1)=M2L/M2 RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL) RHOHEP(3,NHEP-1)=M2T/M2*( IHEL) RETURN END IF 200 CONTINUE END DO EVWGT=HCS END CDECK ID>, HWHIG1. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles *- Split in 3 files by M. Kirsanov C----------------------------------------------------------------------- FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C Basic matrix elements for Higgs + jet production; used in HWHIGA C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHIG1,BI(4),CI(7),DI(3) DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF INTEGER I,J,K,I1,J1,K1 COMMON/CINTS/BI,CI,DI PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0) C----------------------------------------------------------------------- C +++ helicity amplitude for: g+g --> g+H C----------------------------------------------------------------------- S1=S-EH2 T1=T-EH2 U1=U-EH2 HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*( & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1)) & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U) & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1)) & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U) & +FOUR*EQ2*DI(I)/S & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 ) END CDECK ID>, HWHIG2. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C Basic matrix elements for Higgs + jet production; used in HWHIGA C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHIG2,BI(4),CI(7),DI(3) DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF INTEGER I,J,K,I1,J1,K1 COMMON/CINTS/BI,CI,DI PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0) C----------------------------------------------------------------------- C ++- helicity amplitude for: g+g --> g+H C----------------------------------------------------------------------- S1=S-EH2 T1=T-EH2 U1=U-EH2 HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2 & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6)) & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U) END CDECK ID>, HWHIG5. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C Basic matrix elements for Higgs + jet production; used in HWHIGA C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHIG5,BI(4),CI(7),DI(3) DOUBLE PRECISION S,T,U,EH2,EQ2,ONE,TWO,FOUR,HALF INTEGER I,J,K,I1,J1,K1 COMMON/CINTS/BI,CI,DI PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0) C----------------------------------------------------------------------- C Amplitude for: q+qbar --> g+H C----------------------------------------------------------------------- HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I) & +DCMPLX(FOUR*EQ2-U-T)*CI(K) END CDECK ID>, HWHIBQ. *CMZ :- -30/06/01 18.40.33 by Stefano Moretti *-- Author : Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,6 (see below) for the process IPROC=3500, as described C...in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 12-APR-2000 by Stefano Moretti C C----------------------------------------------------------------------- SUBROUTINE HWHIBQ C----------------------------------------------------------------------- C PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,L,M,N INTEGER II,JJ,ITMP INTEGER IFL,IRES DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW DOUBLE PRECISION EMH01,EMH02,EMH03 DOUBLE PRECISION WCKM,CKM,GAMT DOUBLE PRECISION X(6),XL(6),XU(6) DOUBLE PRECISION Q3(0:3),Q35(0:3) DOUBLE PRECISION Q1(5),Q2(5),H(5) DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU DOUBLE PRECISION XTMP DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM DOUBLE PRECISION M2B,M2BBAR DOUBLE PRECISION ALPHA,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3) DOUBLE PRECISION QAUX(0:3) DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST DOUBLE PRECISION WEIGHT SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5 LOGICAL HWRLOG EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG, & HWUMAS,HWULOB EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6)) EQUIVALENCE (EMW,RMASS(198)) EQUIVALENCE (EMH01,RMASS(204)), & (EMH02,RMASS(203)), & (EMH03,RMASS(205)) EQUIVALENCE (CKM,VCKM(3,3)) PARAMETER (EPS=1.D-9) IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE HCS=0. EVWGT=0. C...assign final state masses. EMQ=0. ENQ=0 EMH=RMASS(206) EMHWT=1. C...assign top width. GAMT=HBAR/RLTIM(6) C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH), C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35, C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2), C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU); C...phase space borders. XL(1)=0. XU(1)=1. c...for XL(2),XU(2) see below (non constant). XL(3)=-1. XU(3)=1. XL(4)=0. XU(4)=2.*PIFAC XL(5)=0. XU(5)=1. XL(6)=0. XU(6)=1. C...single phase space point. 100 CONTINUE WEIGHT=1. DO I=1,6 IF(I.EQ.2)GOTO 125 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) 125 CONTINUE END DO C...energy at parton level. ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(6))) XX(2)=TAU/XX(1) C...incoming partons massless. EMIN1=0. EMIN2=0. C...initial state momenta in the partonic CM. PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT) PCM=SQRT(PCM2) C...three particle kinematics. EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/ & (4.*ECM*ECM) IF(RQ42.LT.0.)THEN GOTO 100 ELSE RQ4=SQRT(RQ42) ENDIF C...X(2): integrate over W propagator. XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW) XU(2)=1./(EMW*EMW) X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(2)-XL(2)) XTMP=1./X(2) XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2) CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM)) IF(CT4.GT.+1.)CT4=+1. IF(CT4.LT.-1.)CT4=-1. IF(HWRLOG(HALF))THEN ST4=+SQRT(1.-CT4*CT4) ELSE ST4=-SQRT(1.-CT4*CT4) END IF CT3=X(3) ST3=SQRT(1.-CT3*CT3) CF3=COS(X(4)) SF3=SIN(X(4)) P4(1)=0. P4(2)=-RQ4*ST4 P4(3)=-RQ4*CT4 P4(0)=SQRT(RQ42+ENQ*ENQ) DO I=1,3 Q35(I)=-P4(I) END DO Q35(0)=SQRT(RQ42+EMQH*EMQH) RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/ & (4.*EMQH*EMQH) IF(RQ32.LT.0.)THEN GOTO 100 ELSE RQ3=SQRT(RQ32) ENDIF Q3(1)=RQ3*ST3*CF3 Q3(2)=RQ3*ST3*SF3 Q3(3)=RQ3*CT3 Q3(0)=SQRT(RQ32+EMQ*EMQ) PQ3=0. DO I=1,3 PQ3=PQ3+Q35(I)*Q3(I) END DO P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH P5(0)=Q35(0)-P3(0) DO I=1,3 P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH) P5(I)=Q35(I)-P3(I) END DO C...initial state. P1(0)=SQRT(PCM2+EMIN1*EMIN1) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN2*EMIN2) P2(1)=0. P2(2)=0. P2(3)=-PCM C...option: top diagram removed if can be resonant to avoid double counting. IRES=1 C IF((EMT-EMB-EMH).GE.0.)IRES=0 C...color structured ME summed/averaged over final/initial spins and colors. C...IFL=+1 selects b. IFL=+1 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT, & IFL,IRES,CKM,GAMT,M2B) C...IFL=-1 selects b-bar. IFL=-1 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT, & IFL,IRES,CKM,GAMT,M2BBAR) C...constant factors: phi along beam and conversion GeV^2->nb. FACT=2.*PIFAC*GEV2NB C...Jacobians from X1,X2 to X(5),X(6) FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2) C...phase space Jacobians, pi's and flux. FACT=FACT*RQ3*RQ4/PCM/32./(2.*PIFAC)**5 & *(ECM-EMQ-ENQ-EMH) FACT=FACT/2./P2(0)/P4(0) FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2 C...EW couplings. EMSCA=EMQ+ENQ+EMH EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW C...Higgs resonance. FACT=FACT*EMHWT C...constant weight. FACT=FACT*WEIGHT END IF C...set up PDFs. HCS=0. CALL HWSGEN(.FALSE.) DO I=1,12 IF(DISF(I,1).LT.EPS)THEN GOTO 200 END IF DO J=1,12 IF(DISF(J,2).LT.EPS)THEN GOTO 175 END IF IF((I.NE.5).AND.(I.NE.11).AND. & (J.NE.5).AND.(J.NE.11))THEN GOTO 150 END IF II=J IF((I.NE.5).AND.(I.NE.11))II=I IF(II.GT.6)II=II-6 ITMP=II II=(II+1)/2 DIST=0. DO JJ=1,3 WCKM=VCKM(II,JJ) IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0. DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S END DO IF((I.LE.6).AND.(J.LE.6))THEN HCS=HCS+M2B*DIST*FACT ELSE IF((I.LE.6).AND.(J.GE.7))THEN IF(J.NE.11)HCS=HCS+M2B*DIST*FACT IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT ELSE IF((I.GE.7).AND.(J.LE.6))THEN IF(I.NE.11)HCS=HCS+M2B*DIST*FACT IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT ELSE IF((I.GE.7).AND.(J.GE.7))THEN HCS=HCS+M2BBAR*DIST*FACT END IF IF(GENEV.AND.HCS.GT.RCS)THEN C...generate event. IDN(1)=I IDN(2)=J IF((I.EQ.5).OR.(I.EQ.11))THEN K=I L=J+(-1)**(J+1) IDN(3)=K IDN(4)=L ELSE L=I+(-1)**(J+1) K=J IDN(3)=L IDN(4)=K END IF IF(IDN(2).EQ.IDN(4))THEN IDN(5)= & NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3)))) ELSE IDN(5)= & NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4)))) END IF IDN(5)=IDN(5)+8 C...sets up incoming status and IDs only for 2->1: use HWEONE. IDCMF=15 CALL HWEONE JDAHEP(1,NHEP)=NHEP+1 JDAHEP(2,NHEP)=NHEP+3 JMOHEP(1,NHEP+1)=NHEP JMOHEP(1,NHEP+2)=NHEP JMOHEP(1,NHEP+3)=NHEP C...randomly rotate final state momenta around beam axis. PHI=2.*PIFAC*HWRGEN(0) CPHI=COS(PHI) SPHI=SIN(PHI) ROT(1,1)=+CPHI ROT(1,2)=+SPHI ROT(1,3)=0. ROT(2,1)=-SPHI ROT(2,2)=+CPHI ROT(2,3)=0. ROT(3,1)=0. ROT(3,2)=0. ROT(3,3)=1. DO L=1,3 DO M=1,3 QAUX(M)=0. DO N=1,3 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N) IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N) IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N) END DO END DO DO M=1,3 IF(L.EQ.1)P3(M)=QAUX(M) IF(L.EQ.2)P4(M)=QAUX(M) IF(L.EQ.3)P5(M)=QAUX(M) END DO END DO C...outgoing momenta (give quark masses non covariantly!) DO M=1,3 Q1(M)=P3(M) Q2(M)=P4(M) H( M)=P5(M) END DO Q1(4)=P3(0) Q2(4)=P4(0) H( 4)=P5(0) Q1(5)=RMASS(IDN(3)) Q1(4)=SQRT(Q1(4)**2+Q1(5)**2) Q2(5)=RMASS(IDN(4)) Q2(4)=SQRT(Q2(4)**2+Q2(5)**2) H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP) CALL HWUMAS(H) CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1)) CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2)) CALL HWULOB(PHEP(1,NHEP),H ,PHEP(1,NHEP+3)) C...sets up outgoing status and IDs. ISTHEP(NHEP+1)=113 ISTHEP(NHEP+2)=114 ISTHEP(NHEP+3)=114 IDHW(NHEP+1)=IDN(3) IDHEP(NHEP+1)=IDPDG(IDN(3)) IDHW(NHEP+2)=IDN(4) IDHEP(NHEP+2)=IDPDG(IDN(4)) IDHW(NHEP+3)=IDN(5) IDHEP(NHEP+3)=IDPDG(IDN(5)) C...sets up colour connections. JMOHEP(2,NHEP+1)=NHEP-2 JMOHEP(2,NHEP+2)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP+2 JMOHEP(2,NHEP-2)=NHEP+1 JMOHEP(2,NHEP+3)=NHEP+3 JDAHEP(2,NHEP+1)=NHEP-2 JDAHEP(2,NHEP+2)=NHEP-1 JDAHEP(2,NHEP-1)=NHEP+2 JDAHEP(2,NHEP-2)=NHEP+1 JDAHEP(2,NHEP+3)=NHEP+3 NHEP=NHEP+3 IF(AZSPIN)THEN C...set to zero the coefficients of the spin density matrices. CALL HWVZRO(7,GCOEF) END IF RETURN END IF 150 CONTINUE 175 CONTINUE END DO 200 CONTINUE END DO EVWGT=HCS END CDECK ID>, HWHIGA. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG) C----------------------------------------------------------------------- C Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet C IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result C =2: infinite mass limit. C Only top loop included. A factor (alpha_s**3*alpha_W) is extracted C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4), & CI(7),DI(3),EPSI,TAMP(7) DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK, & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7) INTEGER I LOGICAL NOMASS EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2 COMMON/SMALL/EPSI COMMON/CINTS/BI,CI,DI EPSI=DCMPLX(ZERO,-1.D-10) EMW2=RMASS(198)**2 C Spin and colour flux factors plus enhancement factor RNGLU=1./FLOAT(NCOLO**2-1) RNQRK=1./FLOAT(NCOLO) FLUXGG=.25*RNGLU**2*ENHANC(6)**2 FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2 FLUXQQ=.25*RNQRK**2*ENHANC(6)**2 IF (IAPHIG.EQ.2) THEN C Infinite mass limit in loops WTGG=(2./3.)**2*FLOAT(NCOLO*(NCOLO**2-1)) & *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ RETURN ELSEIF (IAPHIG.EQ.1) THEN C Exact result for loops NOMASS=.FALSE. ELSEIF (IAPHIG.EQ.0) THEN C Small mass approximation in loops NOMASS=.TRUE. ELSE CALL HWWARN('HWHIGA',500) ENDIF C Include only top quark contribution EMQ2=RMASS(6)**2 BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2) BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2) BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2) BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2) BI(1)=BI(1)-BI(4) BI(2)=BI(2)-BI(4) BI(3)=BI(3)-BI(4) CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2) CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2) CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2) CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2) CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2) CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2) CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2) DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2) DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2) DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2) C Compute complex amplitudes TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6) TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0) TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6) TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4) TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0) TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0) TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0) DO 20 I=1,7 TAMPI(I)= DREAL(TAMP(I)) 20 TAMPR(I)=-DIMAG(TAMP(I)) C Square and add prefactors WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))/EMW2 & *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2 & +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2) & *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2) & *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2) & *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ END CDECK ID>, HWHIGB. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles *- split in 3 files by M. Kirsanov C----------------------------------------------------------------------- FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2) C----------------------------------------------------------------------- C One loop scalar integrals, used in HWHIGJ. C If NOMASS=.TRUE. use a small mass approx. for particle in loop. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWHIGB,HWUCI2,HWULI2,EPSI,PII DOUBLE PRECISION S,T,EQ2,EH2,RAT LOGICAL NOMASS EXTERNAL HWULI2,HWUCI2 COMMON/SMALL/EPSI C----------------------------------------------------------------------- C B_0(2p1.p2=S;mq,mq) C----------------------------------------------------------------------- PII=DCMPLX(ZERO,PIFAC) IF (NOMASS) THEN RAT=DABS(S/EQ2) HWHIGB=-DLOG(RAT)+TWO IF (S.GT.ZERO) HWHIGB=HWHIGB+PII ELSE RAT=S/(FOUR*EQ2) IF (S.LT.ZERO) THEN HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT) & *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT)) ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT)) ELSEIF (RAT.GT.ONE) THEN HWHIGB=TWO-DSQRT(ONE-ONE/RAT) & *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII) ENDIF ENDIF END CDECK ID>, HWHIGC. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHIGC(NOMASS,S,T,EH2,EQ2) C----------------------------------------------------------------------- C One loop scalar integrals, used in HWHIGJ. C If NOMASS=.TRUE. use a small mass approx. for particle in loop. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWHIGC,HWUCI2,HWULI2,EPSI,PII DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH LOGICAL NOMASS EXTERNAL HWULI2,HWUCI2 COMMON/SMALL/EPSI C----------------------------------------------------------------------- C C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq) C----------------------------------------------------------------------- PII=DCMPLX(ZERO,PIFAC) IF (NOMASS) THEN RAT=DABS(S/EQ2) HWHIGC=HALF*DLOG(RAT)**2 IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT) HWHIGC=HWHIGC/S ELSE RAT=S/(FOUR*EQ2) IF (S.LT.ZERO) THEN HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S ELSEIF (RAT.GT.ONE) THEN COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE)) HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S ENDIF ENDIF END CDECK ID>, HWHIGD. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHIGD(NOMASS,S,T,EH2,EQ2) C----------------------------------------------------------------------- C One loop scalar integrals, used in HWHIGJ. C If NOMASS=.TRUE. use a small mass approx. for particle in loop. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE COMPLEX HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2 DOUBLE PRECISION S,T,EQ2,EH2,DLS,DLT,DLM,RZ12,DL1,DL2, & ST,ROOT,XP,XM LOGICAL NOMASS EXTERNAL HWULI2,HWUCI2 COMMON/SMALL/EPSI C----------------------------------------------------------------------- C D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq) C----------------------------------------------------------------------- PII=DCMPLX(ZERO,PIFAC) IF (NOMASS) THEN DLS=DLOG(DABS(S/EQ2)) DLT=DLOG(DABS(T/EQ2)) DLM=DLOG(DABS(EH2/EQ2)) IF (S.GE.ZERO.AND.T.LE.ZERO) THEN DL1=DLOG((EH2-T)/S) Z1=T/(T-EH2) Z2=(S-EH2)/S HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2 & +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2) & +PII*DLOG(EH2/(EH2-T))) ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN Z1=(S-EH2)/S Z2=(T-EH2)/T RZ12=ONE/DREAL(Z1*Z2) DL1=DLOG((T-EH2)/(S-EH2)) DL2=DLOG(RZ12) HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE & +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2)) & +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1)) & -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2)) & +TWO*PII*DLOG(RZ12**2*EH2/EQ2) ENDIF HWHIGD=HWHIGD/(S*T) ELSE ST=S*T ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2)) XP=HALF*(ST+ROOT)/ST XM=1-XP HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP) & +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP) & *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM) & +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM))) ENDIF END CDECK ID>, HWHIGE. *CMZ :- -13/10/02 09.43.05 by Peter Richardson *-- Author : Kosuke Odagiri and Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,4 (see below) for the processes from IPROC=1000-1099 (SM), C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file. C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.) C C...First release: 18-SEP-2002 by Stefano Moretti C SUBROUTINE HWHIGE C-------------------------------------------------------------------------- C LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS C-------------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER JHIGGS INTEGER I,L,M,N,NN INTEGER IH,IQ,JQ,IIQ,JJQ INTEGER IAD INTEGER IDEC,FLIP INTEGER ID1,ID2 DOUBLE PRECISION CV,CA,BR DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2 DOUBLE PRECISION X(4),XL(4),XU(4) DOUBLE PRECISION Q4(0:3),Q34(0:3) DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION F(0:3),G(0:3) DOUBLE PRECISION ECM,SHAT,S DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM DOUBLE PRECISION HFC,HBC DOUBLE PRECISION M2EE DOUBLE PRECISION ALPHA,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3) DOUBLE PRECISION QAUX(0:3) DOUBLE PRECISION EPS,HCS,RCS,FACT DOUBLE PRECISION WEIGHT INTEGER IFL,KHIGGS,JH,JFL LOGICAL FIRST,GAUGE DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR DOUBLE PRECISION RM3,RM4,RM5 DOUBLE PRECISION S2W,RMW,RMZ DOUBLE PRECISION RMHL,GAMHL DOUBLE PRECISION RMHH,GAMHH DOUBLE PRECISION RMHA,GAMHA EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205)) LOGICAL HWRLOG EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2HE,HWEONE,HWRLOG PARAMETER (EPS=1.D-9) SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5 SAVE IIQ,JJQ,JHIGGS C...ASSIGN Q/Q'-FLAVOUR. IF(IPROC.GE.1140)THEN IH=4 IF(IPROC.EQ.1140)IQ=2 IF(IPROC.EQ.1141)IQ=4 IF(IPROC.EQ.1142)IQ=6 IF(IPROC.EQ.1143)IQ=7 IF(IPROC.EQ.1144)IQ=8 IF(IPROC.EQ.1145)IQ=9 IAD=7 JQ=IQ+5 GMQ=ZERO IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6) ELSE IF(IMSSM.EQ.0)THEN IH=0 IQ=6 ELSE IF(IPROC.LT.1140)IH=3 IF(IPROC.LT.1130)IH=2 IF(IPROC.LT.1120)IH=1 IQ=IPROC-1100-10*IH END IF IAD=6 JQ=IQ+6 GMQ=ZERO END IF C...PROCESS EVENT. IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. HCS=0. C...ASSIGN FINAL STATE MASSES. IF(IQ.LE.6)THEN EMQ=RMASS(IQ) ENQ=RMASS(JQ) ELSE EMQ=RMASS(2*IQ-7+114+IAD) ENQ=RMASS(2*IQ-7+114 ) END IF EMH=RMASS(201+IHIGGS) GMH=HBAR/RLTIM(201+IHIGGS) EMHWT=1. C...ENERGY AT PARTON LEVEL. ECM=PBEAM1+PBEAM2 S=ECM*ECM SHAT=S IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN C...PHASE SPACE VARIABLES. C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2), C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|), C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34), C...HEAVY QUARKS -> X(2)=COS(THETA5_CM), C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34, C...PHASE SPACE BORDERS. XL(1)=0. XU(1)=1. IF((IQ+JQ).EQ.18)THEN XL(2)=-1. XL(4)=0. XU(4)=2.*PIFAC ELSE XL(2)=0. XL(4)=-1. XU(4)=1. END IF XU(2)=1. XL(3)=-1. XU(3)=1. C...SINGLE PHASE SPACE POINT. 100 CONTINUE WEIGHT=1. DO I=1,4 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...THREE PARTICLE KINEMATICS. EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2) C...INCOMING PARTONS: ALL MASSLESS. EMIN=0. IF((IQ+JQ).EQ.18)THEN CT5=X(2) CT4=X(3) ST4=SQRT(1.-CT4*CT4) CF4=COS(X(4)) SF4=SIN(X(4)) ELSE PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM) PCM=SQRT(PCM2) RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM) RCM=SQRT(RCM2) TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2) & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2)) & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2))) TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2) & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2)) & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2))) TLMIN=LOG(ABS(TTMAX)) TLMAX=LOG(ABS(TTMIN)) TL=X(2)*(TLMAX-TLMIN)+TLMIN T=EXP(ABS(TL)) CTMP=-T-EMIN**2-EMQQ**2 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2) CT5=CTMP/2./PCM/RCM ST4=X(3) CT4=SQRT(1.-ST4*ST4) CF4=X(4) SF4=SQRT(1.-CF4*CF4) END IF IF(HWRLOG(HALF))THEN ST5=+SQRT(1.-CT5*CT5) ELSE ST5=-SQRT(1.-CT5*CT5) END IF RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/ & (4.*ECM*ECM) IF(RQ52.LT.0.)THEN GOTO 100 ELSE RQ5=SQRT(RQ52) ENDIF P5(1)=0. P5(2)=RQ5*ST5 P5(3)=RQ5*CT5 P5(0)=SQRT(RQ52+EMH*EMH) DO I=1,3 Q34(I)=-P5(I) END DO Q34(0)=SQRT(RQ52+EMQQ*EMQQ) RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/ & (4.*EMQQ*EMQQ) IF(RQ42.LT.0.)THEN GOTO 100 ELSE RQ4=SQRT(RQ42) ENDIF Q4(1)=RQ4*ST4*CF4 Q4(2)=RQ4*ST4*SF4 Q4(3)=RQ4*CT4 Q4(0)=SQRT(RQ42+ENQ*ENQ) PQ4=0. DO I=1,3 PQ4=PQ4+Q34(I)*Q4(I) END DO P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ P3(0)=Q34(0)-P4(0) DO I=1,3 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ) P3(I)=Q34(I)-P4(I) END DO IF(IMSSM.NE.0)THEN IF(IPROC.GE.1140)THEN IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN ELSE IF((IQ.NE.6).AND.(IQ.NE.12).AND. & (JQ.NE.6).AND.(JQ.NE.12))THEN IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN ELSE CONTINUE END IF END IF END IF C...INITIAL STATE MOMENTA IN THE PARTONIC CM. PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN*EMIN) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN*EMIN) P2(1)=0. P2(2)=0. P2(3)=-PCM C...COLOR STRUCTURED ME SUMMED/AVERAGED OVER FINAL/INITIAL SPINS AND COLORS. C...EW AND QCD COUPLINGS. EMSCA=EMQ+ENQ+EMH EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) FIRST=.TRUE. GAUGE=.FALSE. E=SQRT(4.D0*PIFAC*ALPHA) IF(IPROC.GE.1140)THEN IFL=IQ-1 IF(IQ.EQ.7)IFL=IQ IF(IQ.EQ.8)IFL=IQ+1 IF(IQ.EQ.9)IFL=IQ+2 RM3=ENQ YM3=ENQ GAM3=0.D0 RM4=EMQ YM4=EMQ GAM4=GMQ C...CHARGED HIGGSES Q3=-1.D0 IF(IFL.LE.6)Q3=-1.D0/3.D0 JFL=0 JH=IH C...ASSIGN FERMION MOMENTA DO I=0,3 F(I)=P4(I) G(I)=P3(I) END DO ELSE IFL=IQ IF(IQ.EQ.7)IFL=IQ IF(IQ.EQ.8)IFL=IQ+1 IF(IQ.EQ.9)IFL=IQ+2 RM3=EMQ YM3=EMQ GAM3=0.D0 RM4=ENQ YM4=ENQ GAM4=0.D0 C...NEUTRAL HIGGSES IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN Q3=-1.D0/3.D0 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN Q3=+2.D0/3.D0 ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN Q3=-1.D0 END IF IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR. & (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN JFL=1 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN JFL=2 END IF KHIGGS=IHIGGS IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1 JH=KHIGGS C...ASSIGN FERMION MOMENTA DO I=0,3 F(I)=P3(I) G(I)=P4(I) END DO END IF RM5=EMH GAM5=GMH S2W=SWEIN RMW=RMASS(198) RMZ=RMASS(200) GAMHL=HBAR/RLTIM(203) GAMHH=HBAR/RLTIM(204) GAMHA=HBAR/RLTIM(205) COLOUR=1.D0 IF(IFL.LE.6)COLOUR=3.D0 C...MSSM COUPLINGS. IF(JH.LE.3)THEN HFC=ENHANC(IQ) HBC=ENHANC(10) ELSE HFC=ONE HBC=ONE END IF C...ME. CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC, & E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5, & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5, & RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA, & RMZ,GAMZ,COLOUR,M2EE) C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB. FACT=2.*PIFAC*GEV2NB C...PHASE SPACE JACOBIANS, PI'S AND FLUX. FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5 & *((ECM-EMH)**2-(EMQ+ENQ)**2) & /2./EMQQ/S C...JACOBIANS FROM CT5 TO X(2). IF((IQ+JQ).EQ.18)THEN CONTINUE ELSE FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T) FACT=FACT*2.*ABS(ST4/CT4/SF4) END IF C...CHARGE CONJUGATION. IF(IPROC.GE.1140)THEN C...YES FOR CHARGED HIGGS. FACT=FACT*2. ELSE C...NO FOR NEUTRAL HIGGSES. CONTINUE END IF C...HIGGS RESONANCE. FACT=FACT*EMHWT C...CONSTANT WEIGHT. FACT=FACT*WEIGHT C...INCLUDE BR OF HIGGS. IF(IMSSM.EQ.0)THEN IDEC=MOD(IPROC,100) IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC) IF (IDEC.EQ.0) THEN BRHIGQ=0.D0 DO I=1,6 BRHIGQ=BRHIGQ+BRHIG(I) END DO FACT=FACT*BRHIGQ ENDIF IF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ENDIF END IF END IF C...SET UP FLAVOURS IN FINAL STATE. IF(IPROC.GE.1140)THEN IF(HWRGEN(0).LT.0.5)THEN JHIGGS=207-201 IIQ=IQ JJQ=JQ FLIP=0 ELSE JHIGGS=206-201 IIQ=IQ-1 JJQ=JQ+1 FLIP=1 END IF ELSE JHIGGS=IHIGGS IIQ=IQ JJQ=JQ FLIP=0 END IF HCS=FACT*M2EE IF (GENEV.AND.HCS.GT.RCS) THEN C...GENERATE EVENT. IDN(1)=IDHW(1) IDN(2)=IDHW(2) IF(IIQ.LE.12.AND.JJQ.LE.12)THEN IDN(3)=IIQ IDN(4)=JJQ ELSE IDN(3)=2*IIQ-7+114 IDN(4)=2*IIQ-7+114+IAD END IF IDN(5)=201+JHIGGS C...INCOMING PARTONS: NOW MASSIVE. EMIN1=RMASS(IDN(1)) EMIN2=RMASS(IDN(2)) C...REDO INITIAL STATE MOMENTA IN THE PARTONIC CM. PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN1*EMIN1) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN2*EMIN2) P2(1)=0. P2(2)=0. P2(3)=-PCM C...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE. IDCMF=15 XX(1)=ONE XX(2)=ONE CALL HWEONE JDAHEP(1,NHEP )=NHEP+1 JDAHEP(2,NHEP )=NHEP+3 JMOHEP(1,NHEP+1)=NHEP JMOHEP(1,NHEP+2)=NHEP JMOHEP(1,NHEP+3)=NHEP C...RANDOMLY ROTATE FINAL STATE MOMENTA AROUND BEAM AXIS. PHI=2.*PIFAC*HWRGEN(0) CPHI=COS(PHI) SPHI=SIN(PHI) ROT(1,1)=+CPHI ROT(1,2)=+SPHI ROT(1,3)=0. ROT(2,1)=-SPHI ROT(2,2)=+CPHI ROT(2,3)=0. ROT(3,1)=0. ROT(3,2)=0. ROT(3,3)=1. DO L=1,3 DO M=1,3 QAUX(M)=0. DO N=1,3 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N) IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N) IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N) END DO END DO DO M=1,3 IF(L.EQ.1)P3(M)=QAUX(M) IF(L.EQ.2)P4(M)=QAUX(M) IF(L.EQ.3)P5(M)=QAUX(M) END DO END DO C...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME. DO M=NHEP-2,NHEP+3 IF(M.EQ.NHEP )GO TO 888 DO N=0,3 NN=N IF(N.EQ.0)NN=4 IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N) IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N) IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N) END DO 888 CONTINUE END DO C...NEEDS TO SET ALL FINAL STATE MASSES. PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2 & -PHEP(3,NHEP+1)**2 & -PHEP(2,NHEP+1)**2 & -PHEP(1,NHEP+1)**2)) PHEP(5,NHEP+2)=SQRT(ABS(PHEP(4,NHEP+2)**2 & -PHEP(3,NHEP+2)**2 & -PHEP(2,NHEP+2)**2 & -PHEP(1,NHEP+2)**2)) PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2 & -PHEP(3,NHEP+3)**2 & -PHEP(2,NHEP+3)**2 & -PHEP(1,NHEP+3)**2)) C...SETS CMF. DO I=1,4 PHEP(I,NHEP )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1) END DO PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2 & -PHEP(3,NHEP )**2 & -PHEP(2,NHEP )**2 & -PHEP(1,NHEP )**2)) C...SETS UP OUTGOING STATUS AND IDS. ISTHEP(NHEP+1)=113 ISTHEP(NHEP+2)=114 ISTHEP(NHEP+3)=114 IDHW(NHEP+1)=IDN(3) IDHEP(NHEP+1)=IDPDG(IDN(3)) IDHW(NHEP+2)=IDN(4) IDHEP(NHEP+2)=IDPDG(IDN(4)) IDHW(NHEP+3)=IDN(5) IDHEP(NHEP+3)=IDPDG(IDN(5)) C...SETS UP COLOUR CONNECTIONS. JMOHEP(2,NHEP+1)=NHEP+2 JMOHEP(2,NHEP+2)=NHEP+1 JMOHEP(2,NHEP-1)=NHEP-2 JMOHEP(2,NHEP-2)=NHEP-1 JMOHEP(2,NHEP+3)=NHEP+3 JDAHEP(2,NHEP+1)=NHEP+2 JDAHEP(2,NHEP+2)=NHEP+1 JDAHEP(2,NHEP-1)=NHEP-1 JDAHEP(2,NHEP-2)=NHEP-2 JDAHEP(2,NHEP+3)=NHEP+3 NHEP=NHEP+3 IF(AZSPIN)THEN C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES. CALL HWVZRO(7,GCOEF) END IF END IF C...COLLECT WEIGHT. EVWGT=HCS END CDECK ID>, HWHIGH. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Kosuke Odagiri & Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355, C...3365,3375 as described in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 16-AUG-1999 by Kosuke Odagiri C...Last modified: 26-SEP-1999 by Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWHIGH C----------------------------------------------------------------------- C DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE, & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2, & GHH(4), XWEIN, S2W, ECM_MAX, X(3), XL(3), & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2, & EMHWT1, EMHWT2, EMHHWT INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2 EXTERNAL HWRGEN, HWUAEM SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT PARAMETER (EPS = 1.D-9) DOUBLE COMPLEX Z, GZ, A, D, E PARAMETER (Z = (0.D0,1.D0)) EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)) C...process event. IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE HCS = ZERO EVWGT = ZERO C...minimum transverse momentum. PTMIN = ZERO C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=COS(THETA_CM), C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2), C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU), C...phase space borders. XL(1)=-1. XU(1)=1. XL(2)=0. XU(2)=1. XL(3)=0. XU(3)=1. C...single phase space point. WEIGHT=1. DO I=1,3 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...final state masses. IF((MOD(IPROC,10000).EQ.3365).OR. & (MOD(IPROC,10000).EQ.3375))THEN JH = IHIGGS-1 ID1 = 205 ID2 = 202 + JH ELSE IF(MOD(IPROC,10000).EQ.3355)THEN JH = 4 ID1 = 206 ID2 = 207 ELSE IF((MOD(IPROC,10000).EQ.3315).OR. & (MOD(IPROC,10000).EQ.3325).OR. & (MOD(IPROC,10000).EQ.3335))THEN JH = IHIGGS-1 ID1 = 206 ID2 = 202 + JH END IF RMH1=RMASS(ID1) RMH2=RMASS(ID2) EMH1=RMH1 EMH2=RMH2 EMHWT1=1. EMHWT2=1. EMHHWT=EMHWT1*EMHWT2 C...energy at parton level. ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1) = EXP(LOG(TAU)*(1.-X(3))) XX(2) = TAU/XX(1) COSTH = X(1) SN2TH = 0.25D0 - 0.25D0*COSTH**2 EMSCA = EMH1+EMH2 EMSC2 = EMSCA*EMSCA CALL HWSGEN(.FALSE.) EVWGT = ZERO FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2. C...Jacobians from X1,X2 to X(2),X(3). FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2) C...constant weight. FACTR = FACTR*WEIGHT C...couplings and propagators. XWEIN = TWO*SWEIN S2W = DSQRT(XWEIN*(TWO-XWEIN)) GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT GZ2 = DREAL(DCONJG(GZ)*GZ) GW2 = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2 C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-. GHH(1)= COSBMA GHH(2)= SINBMA GHH(3)= ONE GHH(4)= ONE-XWEIN C...set to zero all MEs. DO I=1,2 MCC(I)=ZERO MCN(I)=ZERO DO J=1,2 MNN(I,J)=ZERO END DO END DO MCN(3)=ZERO C...start subprocesses. IF((MOD(IPROC,10000).EQ.3365).OR. & (MOD(IPROC,10000).EQ.3375))THEN c c _ o o o c q q -> A h / H c DO IH = JH,JH QPE = SHAT-(EMH1+EMH2)**2 IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT DO IQ = 1,2 MNN(IH,IQ) = & FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2 END DO ELSE CONTINUE END IF END DO ELSE IF(MOD(IPROC,10000).EQ.3355)THEN c c _ + - c q q -> H H c IH = JH QPE = SHAT-(EMH1+EMH2)**2 IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT DO IQ = 1,2 A = GHH(IH)/GZ D = QFCH(IQ)+A*LFCH(IQ) E = QFCH(IQ)+A*RFCH(IQ) MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E) END DO ELSE CONTINUE END IF ELSE IF((MOD(IPROC,10000).EQ.3315).OR. & (MOD(IPROC,10000).EQ.3325).OR. & (MOD(IPROC,10000).EQ.3335))THEN c c _ +- o o o c q q' -> H h / H / A c DO IH = JH,JH QPE = SHAT-(EMH1+EMH2)**2 IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2 ELSE CONTINUE END IF END DO END IF END IF HCS = 0.D0 C...start PDFs. DO 1 ID1 = 1, 12 IF (DISF(ID1,1).LT.EPS) GOTO 1 IF (ID1.GT.6) THEN ID2 = ID1 - 6 ELSE ID2 = ID1 + 6 END IF IQ = ID1 - ((ID1-1)/2)*2 IF (DISF(ID2,2).LT.EPS) GOTO 1 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT IH1 = 205 IH2 = 203 HCS = HCS + DIST*EMHHWT*MNN(1,IQ) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,1) GOTO 9 ENDIF IH2 = 204 HCS = HCS + DIST*EMHHWT*MNN(2,IQ) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,2) GOTO 9 ENDIF IH1 = 206 IH2 = 207 HCS = HCS + DIST*EMHHWT*MCC(IQ) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,3) GOTO 9 ENDIF 1 CONTINUE c _ _ _ _ c ud(+), ud(-), du(-), du(+) c DO 2 IQ1 = 1, 3 DO IQ2 = 1, 3 IF(VCKM(IQ1,IQ2).GT.EPS) THEN c _ c ud (+) c ID1 = IQ1 * 2 ID2 = IQ2 * 2 + 5 IH1 = 206 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 1,3 IH2 = 202+IH HCS = HCS + DIST*EMHHWT*MCN(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,3+IH) GOTO 9 ENDIF END DO END IF c _ c du (+) c ID1 = IQ2 * 2 + 5 ID2 = IQ1 * 2 IH1 = 206 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 1,3 IH2 = 202+IH HCS = HCS + DIST*EMHHWT*MCN(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,3+IH) GOTO 9 ENDIF END DO END IF c _ c du (-) c ID1 = IQ2 * 2 - 1 ID2 = IQ1 * 2 + 6 IH1 = 207 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 1,3 IH2 = 202+IH HCS = HCS + DIST*EMHHWT*MCN(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,3+IH) GOTO 9 ENDIF END DO END IF c _ c ud (-) c ID1 = IQ1 * 2 + 6 ID2 = IQ2 * 2 - 1 IH1 = 207 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT DO IH = 1,3 IH2 = 202+IH HCS = HCS + DIST*EMHHWT*MCN(IH) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IH1,IH2,2134,3+IH) GOTO 9 ENDIF END DO END IF END IF END DO 2 CONTINUE EVWGT = HCS RETURN C...generate event. 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHIGJ. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHIGJ C----------------------------------------------------------------------- C QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R. C Adapted from the program of U. Baur and E.W.N. Glover C See: Nucl. Phys. B339 (1990) 38 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT, & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH, & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS, & FACTR INTEGER I,IDEC,ID1,ID2 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. C Select a Higgs mass CALL HWHIGM(EMH,EMHWT) IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN C Store branching ratio for specified Higgs deacy channel IDEC=MOD(IPROC,100) BR=1. IF (IDEC.EQ.0) THEN BR=0. DO 10 I=1,6 10 BR=BR+BRHIG(I) ELSEIF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) BR=BR*BRHIG(IDEC) ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) BR=BR*BRHIG(IDEC) ELSEIF (IDEC.LE.12) THEN BR=BRHIG(IDEC) ENDIF C Select subprocess kinematics EMH2=EMH**2 CALL HWRPOW(ET,EJ) PT=.5*ET EMT=SQRT(PT**2+EMH2) EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3)) IF (EMAX.LE.EMT) RETURN YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT) YHINF=MAX(YJMIN,-YMAX) YHSUP=MIN(YJMAX, YMAX) IF (YHSUP.LE.YHINF) RETURN EXYH=EXP(HWRUNI(1,YHINF,YHSUP)) YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH)) YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT) YJINF=MAX(YJMIN,YMIN) YJSUP=MIN(YJMAX,YMAX) IF (YJSUP.LE.YJINF) RETURN EXYJ=EXP(HWRUNI(2,YJINF,YJSUP)) XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3) XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3) S=XX(1)*XX(2)*PHEP(5,3)**2 T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH U=EMH2-S-T COSTH=(S+2.*T-EMH2)/(S-EMH2) C Set subprocess scale EMSCA=EMT CALL HWSGEN(.FALSE.) FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT & *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2) CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG) ENDIF HCS=0. DO 30 ID1=1,13 IF (DISF(ID1,1).LT.EPS) GOTO 30 FACTR=FACT*DISF(ID1,1) IF (ID1.LT.7) THEN C Quark first: ID2=ID1+6 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(13 ,201,2314,81) GOTO 99 ENDIF ID2=13 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,201,3124,82) GOTO 99 ENDIF ELSEIF (ID1.LT.13) THEN C Antiquark first: ID2=ID1-6 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(13 ,201,3124,83) GOTO 99 ENDIF ID2=13 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,201,2314,84) GOTO 99 ENDIF ELSE C Gluon first: DO 20 ID2=1,12 IF (DISF(ID2,2).LT.EPS) GOTO 20 IF (ID2.LT.7) THEN HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID2,201,2314,85) GOTO 99 ENDIF ELSE HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID2,201,3124,86) GOTO 99 ENDIF ENDIF 20 CONTINUE HCS=HCS+FACTR*DISF(13,2)*AMPGG IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(13 ,201,2314,87) GOTO 99 ENDIF ENDIF 30 CONTINUE EVWGT=HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 C Trick HWETWO into using off-shell Higgs mass EMHTMP=RMASS(IDN(4)) RMASS(IDN(4))=EMH C-- BRW fix 27/8/04: avoid double smearing of H mass CALL HWETWO(.TRUE.,.FALSE.) RMASS(IDN(4))=EMHTMP END CDECK ID>, HWHIGM. *CMZ :- -02/05/91 11.17.14 by Federico Carminati *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHIGM(EM,WEIGHT) C----------------------------------------------------------------------- C CHOOSE HIGGS MASS: C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN C CHOOSE HIGGS MASS ACCORDING TO C EM**4 / ((EM**2-EMH**2)**2 + (GAMH*EMH)**2) C ELSE C CHOOSE HIGGS MASS ACCORDING TO C EMH * GAMH / ((EM**2-EMH**2)**2 + (GAMH*EMH)**2) C ENDIF C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN C SUPPLY WEIGHT FACTOR TO YIELD C EM * GAM(EM)/ ((EM**2-EMH**2)**2 + (GAM(EM)*EM)**2) C ELSE C SUPPLY WEIGHT FACTOR TO YIELD C EM*(EMH/EM)**4 * GAM(EM) C / ((EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2) C AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409. C ENDIF C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0, & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS INTEGER I EXTERNAL HWRUNI SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1 EQUIVALENCE (EMH,RMASS(201)) DATA EMHLST/0D0/ C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION C THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH DIF(T,T0)=(T+T0)**2 FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T) C---SET UP CONSTANTS IF (EMH.NE.EMHLST .OR. FSTWGT) THEN EMHLST=EMH GAMEM=GAMH*EMH T0=EMH/GAMH TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0 TMAX=( EMH+GAMMAX*GAMH )**2/GAMEM-T0 THEMIN=ATAN(TMIN) THEMAX=ATAN(TMAX) ZMIN=FUN(THEMIN,TMIN,T0) ZMAX=FUN(THEMAX,TMAX,T0) W0=(ZMAX-ZMIN) / PIFAC * GAMEM W1=(THEMAX-THEMIN) / PIFAC ENDIF C---CHOOSE HIGGS MASS IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN EM=0 WEIGHT=0 Z=HWRUNI(1,ZMIN,ZMAX) C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 )) I=1 F=0 10 IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN I=I+1 IF (2*ABS(THETA).GT.PIFAC) THEN CALL HWWARN('HWHIGM',51) GOTO 999 ENDIF T=TAN(THETA) F=FUN(THETA,T,T0) THETA=THETA-(F-Z)/DIF(T,T0) GOTO 10 ENDIF IF (I.GT.20) CALL HWWARN('HWHIGM',1) ELSE THETA=HWRUNI(0,THEMIN,THEMAX) ENDIF EM=SQRT(GAMEM*(T0+TAN(THETA))) C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH GAMOFS=EM CALL HWDHIG(GAMOFS) IF (IOPHIG.EQ.0) THEN WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2) & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2) ELSEIF (IOPHIG.EQ.1) THEN WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2) & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2) ELSEIF (IOPHIG.EQ.2) THEN EMM=EM*(EMH/EM)**4 WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2) & /((EM**2-EMH**2)**2+GAMOFS**2*EMM*EM) ELSEIF (IOPHIG.EQ.3) THEN EMM=EM*(EMH/EM)**4 WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2) & /((EM**2-EMH**2)**2+GAMOFS**2*EMM*EM) ELSE CALL HWWARN('HWHIGM',500) ENDIF 999 RETURN END CDECK ID>, HWHIGQ. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM), C...IPROC=3811-3899, as described in the HERWIG 6 documentation file. C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.) C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 08-APR-1999 by Stefano Moretti C...Last modified: 28-JUN-2001 by Stefano Moretti C SUBROUTINE HWHIGQ C----------------------------------------------------------------------- C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER JHIGGS INTEGER I,J,K,L,M,N INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ INTEGER IDEC,NC,FLIP INTEGER ID1,ID2 DOUBLE PRECISION CV,CA,BR DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW DOUBLE PRECISION PTMMIN,PTNMIN DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2 DOUBLE PRECISION X(6),XL(6),XU(6) DOUBLE PRECISION Q4(0:3),Q34(0:3) DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ DOUBLE PRECISION GM,GRND,FACGPM(2) DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH DOUBLE PRECISION ALPHA,ALPHAS,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3) DOUBLE PRECISION VCOL,GCOL,QAUX(0:3) DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST DOUBLE PRECISION WEIGHT SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5 SAVE IIQ,JJQ,JHIGGS LOGICAL HWRLOG EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG PARAMETER (EPS=1.D-9) EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO) C...assign Q/Q'-flavour. IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN IQ=6 JQ=11 GM=HBAR/RLTIM(6)*RMASS(6) ELSE IF(IMSSM.EQ.0)THEN IS=0 IH=0 IQ=6 ELSE IF(MOD(IPROC,10000).LT.4000)IS=6 IF(MOD(IPROC,10000).LT.3870)IS=3 IF(MOD(IPROC,10000).LT.3840)IS=0 IH=MOD(IPROC,10000)/10-380-IS IQ=MOD(IPROC,10000)-3800-10*(IH+IS) END IF JQ=IQ+6 GM=ZERO END IF C...process event. IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. HCS=0. C...assign final state masses. EMQ=RMASS(IQ) ENQ=RMASS(JQ) EMH=RMASS(201+IHIGGS) EMHWT=1. IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT) C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2), C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|), C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34), C...HEAVY QUARKS -> X(2)=COS(THETA5_CM), C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34, C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2), C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU); C...phase space borders. XL(1)=0. XU(1)=1. IF((IQ+JQ).EQ.18)THEN XL(2)=-1. XL(4)=0. XU(4)=2.*PIFAC ELSE XL(2)=0. XL(4)=-1. XU(4)=1. END IF XU(2)=1. XL(3)=-1. XU(3)=1. XL(5)=0. XU(5)=1. XL(6)=0. XU(6)=1. C...single phase space point. 100 CONTINUE WEIGHT=1. DO I=1,6 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...energy at parton level. PTMMIN=0. PTNMIN=0. IF(IMSSM.NE.0)THEN IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN PTNMIN=PTMIN ELSE IF((IQ.NE.6).AND.(IQ.NE.12).AND. & (JQ.NE.6).AND.(JQ.NE.12))THEN PTMMIN=PTMIN PTNMIN=PTMIN ELSE CONTINUE END IF END IF END IF ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2) & +SQRT(PTNMIN**2+ENQ**2)+EMH)**2 & -1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(6))) XX(2)=TAU/XX(1) C...three particle kinematics. EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2) C...incoming partons: all massless. EMIN=0. IF((IQ+JQ).EQ.18)THEN CT5=X(2) CT4=X(3) ST4=SQRT(1.-CT4*CT4) CF4=COS(X(4)) SF4=SIN(X(4)) ELSE PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM) PCM=SQRT(PCM2) RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM) RCM=SQRT(RCM2) TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2) & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2)) & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2))) TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2) & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2)) & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2))) TLMIN=LOG(ABS(TTMAX)) TLMAX=LOG(ABS(TTMIN)) TL=X(2)*(TLMAX-TLMIN)+TLMIN T=EXP(ABS(TL)) CTMP=-T-EMIN**2-EMQQ**2 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2) CT5=CTMP/2./PCM/RCM ST4=X(3) CT4=SQRT(1.-ST4*ST4) IF (HWRLOG(HALF)) CT4=-CT4 CF4=X(4) SF4=SQRT(1.-CF4*CF4) IF (HWRLOG(HALF)) SF4=-SF4 END IF ST5=SQRT(1.-CT5*CT5) IF (HWRLOG(HALF)) ST5=-ST5 RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/ & (4.*ECM*ECM) IF(RQ52.LT.0.)THEN GOTO 100 ELSE RQ5=SQRT(RQ52) ENDIF P5(1)=0. P5(2)=RQ5*ST5 P5(3)=RQ5*CT5 P5(0)=SQRT(RQ52+EMH*EMH) DO I=1,3 Q34(I)=-P5(I) END DO Q34(0)=SQRT(RQ52+EMQQ*EMQQ) RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/ & (4.*EMQQ*EMQQ) IF(RQ42.LT.0.)THEN GOTO 100 ELSE RQ4=SQRT(RQ42) ENDIF Q4(1)=RQ4*ST4*CF4 Q4(2)=RQ4*ST4*SF4 Q4(3)=RQ4*CT4 Q4(0)=SQRT(RQ42+ENQ*ENQ) PQ4=0. DO I=1,3 PQ4=PQ4+Q34(I)*Q4(I) END DO P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ P3(0)=Q34(0)-P4(0) DO I=1,3 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ) P3(I)=Q34(I)-P4(I) END DO IF(IMSSM.NE.0)THEN IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN ELSE IF((IQ.NE.6).AND.(IQ.NE.12).AND. & (JQ.NE.6).AND.(JQ.NE.12))THEN IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN ELSE CONTINUE END IF END IF END IF C...initial state momenta in the partonic CM. PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN*EMIN) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN*EMIN) P2(1)=0. P2(2)=0. P2(3)=-PCM C...color structured ME summed/averaged over final/initial spins and colors. IGG=1 IQQ=1 IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN IF(MOD(IPROC,10000).EQ.3869)IQQ=0 IF(MOD(IPROC,10000).EQ.3899)IGG=0 GRND=TANB ELSE IF(IMSSM.NE.0)THEN IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0 IF((MOD(IPROC,10000)/10-380).EQ.7)IGG=0 END IF GRND=ONE END IF FACGPM(1) = ENQ *GRND FACGPM(2) = EMQ*PARITY/GRND CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ, & GGQQHT,GGQQHU,GGQQHNP,QQQQH) M2GG=GGQQHNP/(8.*CFFAC) M2GGPL=GGQQHT/(8.*CFFAC) M2GGMN=GGQQHU/(8.*CFFAC) M2QQ=QQQQH*(1.-1./CAFAC**2)/4. C...constant factors: phi along beam and conversion GeV^2->nb. FACT=2.*PIFAC*GEV2NB C...Jacobians from X1,X2 to X(5),X(6) FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2) C...phase space Jacobians, pi's and flux. FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5 & *((ECM-EMH)**2-(EMQ+ENQ)**2) & /2./EMQQ C...Jacobians from CT5 to X(2). IF((IQ+JQ).EQ.18)THEN CONTINUE ELSE FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T) FACT=FACT*2.*ABS(ST4/CT4/SF4) END IF C...EW and QCD couplings. EMSCA=EMQ+ENQ+EMH EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) ALPHAS=HWUALF(1,EMSCA) FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW FACT=FACT*16.*PIFAC**2*ALPHAS**2 IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN C...enhancement factor for coupling+c.c. FACT=FACT*4.*VCKM(3,3) ELSE C...enhancement factor for MSSM. FACT=FACT*ENHANC(IQ)*ENHANC(IQ) END IF C...Higgs resonance. FACT=FACT*EMHWT C...constant weight. FACT=FACT*WEIGHT C...include BR of Higgs. IF(IMSSM.EQ.0)THEN IDEC=MOD(IPROC,100) IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC) IF (IDEC.EQ.0) THEN BRHIGQ=0.D0 DO I=1,6 BRHIGQ=BRHIGQ+BRHIG(I) END DO FACT=FACT*BRHIGQ ENDIF c bug fix 11/10/02 SM. IF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ENDIF c end of bug fix. END IF END IF C...set up flavours in final state. IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN IF(HWRGEN(0).LT.0.5)THEN JHIGGS=207-201 IIQ=6 JJQ=11 FLIP=0 ELSE JHIGGS=206-201 IIQ=5 JJQ=12 FLIP=1 END IF ELSE JHIGGS=IHIGGS IIQ=IQ JJQ=JQ FLIP=0 END IF C...set up PDFs. HCS=0. CALL HWSGEN(.FALSE.) IQMAX=13 IQMIN=1 IF((MOD(IPROC,10000).EQ.3839).OR. & (MOD(IPROC,10000).EQ.3869).OR. & (MOD(IPROC,10000).EQ.3899))THEN IF(MOD(IPROC,10000).EQ.3869)IQMIN=13 IF(MOD(IPROC,10000).EQ.3899)IQMAX=12 ELSE IF(IMSSM.NE.0)THEN C...Some compilers don't like this statement. C Since it does nothing, just comment it out. C IF((MOD(IPROC,10000).GE.3811).AND. C & (MOD(IPROC,10000).LE.3836))CONTINUE IF((MOD(IPROC,10000).GE.3841).AND. & (MOD(IPROC,10000).LE.3866))IQMIN=13 IF((MOD(IPROC,10000).GE.3871).AND. & (MOD(IPROC,10000).LE.3896))IQMAX=12 END IF END IF DO I=IQMIN,IQMAX IF(DISF(I,1).LT.EPS)THEN GOTO 200 END IF K=I/7 L=+1-2*K IF(I.EQ.13)L=0 J=I+L*6 IF(DISF(J,2).LT.EPS)THEN GOTO 200 END IF DIST=DISF(I,1)*DISF(J,2)*S IF(I.LT.13)THEN C...set up color connections: qq-scattering. IF(J.EQ.I+6)THEN HCS=HCS+M2QQ*DIST*FACT IF(GENEV.AND.HCS.GT.RCS)THEN CONTINUE CALL HWHQCP(IIQ,JJQ,2413, 4) GOTO 9 END IF ELSE IF(I.EQ.J+6)THEN HCS=HCS+M2QQ*DIST*FACT IF(GENEV.AND.HCS.GT.RCS)THEN FLIP=(2-2*FLIP)/2 CALL HWHQCP(JJQ,IIQ,3142,12) GOTO 9 END IF END IF ELSE C...set up color connections: gg-scattering. HCS=HCS & +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IIQ,JJQ,2413,27) GOTO 9 ENDIF HCS=HCS & +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(IIQ,JJQ,4123,28) GOTO 9 ENDIF END IF 200 CONTINUE END DO EVWGT=HCS RETURN C...generate event. 9 IDN(1)=I IDN(2)=J IDN(5)=201+JHIGGS C...incoming partons: now massive. EMIN1=RMASS(IDN(1)) EMIN2=RMASS(IDN(2)) C...redo initial state momenta in the partonic CM. PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN1*EMIN1) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN2*EMIN2) P2(1)=0. P2(2)=0. P2(3)=-PCM C...randomly rotate final state momenta around beam axis. PHI=2.*PIFAC*HWRGEN(0) CPHI=COS(PHI) SPHI=SIN(PHI) ROT(1,1)=+CPHI ROT(1,2)=+SPHI ROT(1,3)=0. ROT(2,1)=-SPHI ROT(2,2)=+CPHI ROT(2,3)=0. ROT(3,1)=0. ROT(3,2)=0. ROT(3,3)=1. DO L=1,3 DO M=1,3 QAUX(M)=0. DO N=1,3 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N) IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N) IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N) END DO END DO DO M=1,3 IF(L.EQ.1)P3(M)=QAUX(M) IF(L.EQ.2)P4(M)=QAUX(M) IF(L.EQ.3)P5(M)=QAUX(M) END DO END DO C...use HWETWO only to set up status and IDs of quarks. COSTH=0. IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) C...do real incoming, outgoing momenta in the lab frame. VCOL=(XX(1)-XX(2))/(XX(1)+XX(2)) GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2)) DO M=NHEP-4,NHEP+1 IF(M.EQ.NHEP-2)GO TO 888 DO N=0,3 IF(M.EQ.NHEP-4)QAUX(N)=P1(N) IF(M.EQ.NHEP-3)QAUX(N)=P2(N) IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP IF(M.EQ.NHEP+1)QAUX(N)=P5(N) END DO C...perform boost. PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3)) PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0)) PHEP(2,M)=QAUX(2) PHEP(1,M)=QAUX(1) 888 CONTINUE END DO C...needs to set all final state masses. PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2 & -PHEP(3,NHEP-1)**2 & -PHEP(2,NHEP-1)**2 & -PHEP(1,NHEP-1)**2)) PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2 & -PHEP(3,NHEP )**2 & -PHEP(2,NHEP )**2 & -PHEP(1,NHEP )**2)) PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2 & -PHEP(3,NHEP+1)**2 & -PHEP(2,NHEP+1)**2 & -PHEP(1,NHEP+1)**2)) C...sets CMF. DO I=1,4 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3) END DO PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2 & -PHEP(3,NHEP-2)**2 & -PHEP(2,NHEP-2)**2 & -PHEP(1,NHEP-2)**2)) C...status and IDs for Higgs. ISTHEP(NHEP+1)=114 IDHW(NHEP+1)=IDN(5) IDHEP(NHEP+1)=IDPDG(IDN(5)) C...Higgs colour (self-)connections. JMOHEP(1,NHEP+1)=NHEP-2 JMOHEP(2,NHEP+1)=NHEP+1 JDAHEP(2,NHEP+1)=NHEP+1 JDAHEP(2,NHEP-2)=NHEP+1 NHEP=NHEP+1 IF(AZSPIN)THEN C...set to zero the coefficients of the spin density matrices. CALL HWVZRO(7,GCOEF) END IF END C----------------------------------------------------------------------- CDECK ID>, HWHIGS. *CMZ :- -02/04/98 14.52.22 by Mike Seymour *-- Author : Mike Seymour *-- Modified: Stefano Moretti 04/05/98 C----------------------------------------------------------------------- SUBROUTINE HWHIGS C----------------------------------------------------------------------- C HIGGS PRODUCTION VIA GLUON OR QUARK FUSION C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH, & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6) INTEGER IDEC,I,J,ID1,ID2 EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM SAVE CSFAC,BR,EVSUM IF (GENEV) THEN RWGT=HWRGEN(0)*EVSUM(13) IDN(1)=1 DO 10 I=1,12 10 IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1 IDN(2)=13 IF (IDN(1).LE.12) IDN(2)=IDN(1)-6 IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6 IDCMF=201+IHIGGS CALL HWEONE ELSE EVWGT=0. EMH=RMASS(201+IHIGGS) EMFAC=1.D0 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC) IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN EMSCA=EMH IF (EMSCA.NE.EMLST) THEN EMLST=EMH XXMIN=(EMH/PHEP(5,3))**2 XLMIN=LOG(XXMIN) GFACTR=GEV2NB*HWUAEM(EMH**2)/(576.*SWEIN*RMASS(198)**2) C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES CALL HWURQM(EMH,RQM) DO 20 I=13,13 IF (I.EQ.13) THEN CSFAC(I)=-GFACTR*HWHIGT( EMH)*XLMIN & *HWUALF(1,EMH)**2*EMFAC ELSEIF (I.GT.6) THEN CSFAC(I)=CSFAC(I-6) ELSE EMQ=RQM(I) IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2) & *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2 ELSE CSFAC(I)=0 ENDIF ENDIF C--END MOD 20 CONTINUE C INCLUDE BRANCHING RATIO OF HIGGS IDEC=MOD(IPROC,100) BR=1 IF(IMSSM.EQ.0)THEN C SM case IF (IDEC.EQ.0) THEN BRHIGQ=0 DO 30 I=1,6 30 BRHIGQ=BRHIGQ+BRHIG(I) BR=BRHIGQ ELSEIF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) BR=BR*BRHIG(IDEC) ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) BR=BR*BRHIG(IDEC) ELSEIF (IDEC.LE.12) THEN BR=BRHIG(IDEC) ENDIF ENDIF ENDIF CALL HWSGEN(.TRUE.) EVWGT=0 E1=PHEP(4,MAX(1,JDAHEP(1,1))) E2=PHEP(4,MAX(2,JDAHEP(1,2))) DO 40 I=1,13 EMQ=RMASS(I) IF (EMH.GT.2*EMQ) THEN J=13 IF (I.LE.12) J=I-6 IF (I.LE. 6) J=I+6 IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND. & XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2))) & EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR ENDIF EVSUM(I)=EVWGT 40 CONTINUE ENDIF END CDECK ID>, HWHIGT. *CMZ :- -02/04/98 15.00.39 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWHIGT(EMH) C----------------------------------------------------------------------- C CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433 C WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION C PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL, & AIIMAG INTEGER I,J,K,L HWHIGT=0 IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500) AIREAL=0 AIIMAG=0 C---CONTRIBUTION FROM QUARK LOOPS DO 100 I=1,NFLAV RATIO=RMASS(I)/EMH RAT2=RATIO**2 IF (RAT2.GT.0.25) THEN FREAL=-2.*ASIN(0.5/RATIO)**2 FIMAG=0 ELSEIF (RAT2.LT.0.25) THEN ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) ) FREAL=0.5 * (ETALOG**2 - PIFAC**2) FIMAG=PIFAC * ETALOG ELSE FREAL=0.5 * ( - PIFAC**2) FIMAG=0 ENDIF IF (PARITY.EQ.1) THEN AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I) AIIMAG=AIIMAG+3*RAT2*( (4*RAT2-1)*FIMAG)*ENHANC(I) ELSE AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I) AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I) ENDIF 100 CONTINUE C---CONTRIBUTION FROM SQUARK LOOPS DO 200 I=1,12 J=I/7 K=6*J+I L=K IF(K.GT.6)L=K-12 RATIO=RMASS(L)/EMH RAT2=RATIO**2 IF (RAT2.GT.0.25) THEN FREAL=-2.*ASIN(0.5/RATIO)**2 FIMAG=0 ELSEIF (RAT2.LT.0.25) THEN ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) ) FREAL=0.5 * (ETALOG**2 - PIFAC**2) FIMAG=PIFAC * ETALOG ELSE FREAL=0.5 * ( - PIFAC**2) FIMAG=0 ENDIF IF (PARITY.EQ.1) THEN AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K) AIIMAG=AIIMAG-3*RAT2*( 2*RAT2*FIMAG)*SENHNC(K) ENDIF 200 CONTINUE C---FUNCTION RETURNS MOD-SQUARED OF SUM HWHIGT=AIREAL**2 + AIIMAG**2 END CDECK ID>, HWHIGV. *CMZ :- -26/11/00 17.21.55 by Bryan Webber *-- Author : Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,4 (see below) for the processes of ther series C...IPROC=2600,2700 as described in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 8-APR-1999 by Stefano Moretti C SUBROUTINE HWHIGV C----------------------------------------------------------------------- C MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON C--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,L,M,N INTEGER IV,IDEC INTEGER ID1,ID2 DOUBLE PRECISION CV,CA,BR DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH DOUBLE PRECISION X(4),XL(4),XU(4) DOUBLE PRECISION CT,ST,CCT DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3) DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12) DOUBLE PRECISION M2,M2L,M2T DOUBLE PRECISION ALPHA,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST DOUBLE PRECISION WEIGHT DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT LOGICAL HWRLOG EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG PARAMETER (EPS=1.D-9) IF(IMSSM.EQ.0)THEN IF(IPRO.EQ.26)IV=0 IF(IPRO.EQ.27)IV=1 ELSE IF((MOD(IPROC,10000).EQ.3310).OR. & (MOD(IPROC,10000).EQ.3320))THEN IV=0 ELSEIF((MOD(IPROC,10000).EQ.3360).OR. & (MOD(IPROC,10000).EQ.3370))THEN IV=1 END IF END IF IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE HCS=0. EVWGT=0. C...assign final state masses. RMV=RMASS(198+2*IV) RMH=RMASS(201+IHIGGS) IF(IV.EQ.0)GAMV=GAMW IF(IV.EQ.1)GAMV=GAMZ EMH=RMH EMHWT=1.D0 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT) C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=COS(THETA_CM), C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2), C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU), C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN), C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV); C...phase space borders. XL(1)=-1. XU(1)=1. XL(2)=0. XU(2)=1. XL(3)=0. XU(3)=1. XL(4)=0. XU(4)=1. C...single phase space point. WEIGHT=1. DO I=1,4 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...resonant boson mass. RNMIN=RMV-GAMMAX*GAMV THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV) RNMAX=ECM_MAX-EMH THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV) EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN)) & *RMV*GAMV+RMV*RMV) C...energy at parton level. ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(3))) XX(2)=TAU/XX(1) C...two particle kinematics. CT=X(1) IF(HWRLOG(HALF))THEN ST=+SQRT(1.-CT*CT) ELSE ST=-SQRT(1.-CT*CT) END IF C...single phase space point. RCM2=((SHAT-EMV*EMV-EMH*EMH)**2 & -(2.*EMV*EMH)**2)/(4.*SHAT) RCM=SQRT(RCM2) P3(0)=SQRT(RCM2+EMV*EMV) P3(1)=0. P3(2)=RCM*ST P3(3)=RCM*CT P4(0)=SQRT(RCM2+EMH*EMH) P4(1)=0. P4(2)=-RCM*ST P4(3)=-RCM*CT C...incoming partons: massless. EMIN=0. C...initial state momenta in the partonic CM. PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN*EMIN) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN*EMIN) P2(1)=0. P2(2)=0. P2(3)=-PCM C...color structured ME summed/averaged over final/initial spins and colors. CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T) IF(M2.LE.0.)RETURN C...vector-axial couplings of V to qq'/qq. IF(IV.EQ.0)THEN DO I=2,12,2 K=I IF(I.GT.6)K=I-6 M=K/2 N=0 DO J=1,11,2 L=J IF(J.GT.6)L=J-6 N=L-N c bug fix 20/05/01 SM. QQV(I,J)=VCKM(M,N) c end of bug fix. QQV(J,I)=QQV(I,J) IF(N.EQ.3)N=0 END DO END DO ELSE IF(IV.EQ.1)THEN C4W=(1.-SWEIN)*(1.-SWEIN) DO I=1,11,2 VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN) AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN) J=I+6 IF(J.GT.12)J=J-12 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W END DO DO I=2,12,2 VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN) AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN) J=I+6 IF(J.GT.12)J=J-12 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W END DO END IF C...constant factors: phi along beam and conversion GeV^2->nb. FACT=2.*PIFAC*GEV2NB C...Jacobians from X1,X2 to X(2),X(3) FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2) C...phase space Jacobians, pi's and flux. FACT=FACT/64./PIFAC/PIFAC*RCM/PCM C...EW couplings. EMSCA=RMV+RMH EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV C...enhancement factor for MSSM. FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV) C...Higgs resonance. FACT=FACT*EMHWT C...vector boson resonance. FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC C...constant weight. FACT=FACT*WEIGHT C...include BR of Higgs. IF(IMSSM.EQ.0)THEN IDEC=MOD(IPROC,100) IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC) IF (IDEC.EQ.0) THEN BRHIGQ=0.D0 DO I=1,6 BRHIGQ=BRHIGQ+BRHIG(I) END DO FACT=FACT*BRHIGQ ENDIF c bug fix 11/10/02 SM. IF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) FACT=FACT*BR ENDIF c end of bug fix. END IF END IF C...set up PDFs. HCS=0. CALL HWSGEN(.FALSE.) DO I=1,12 IF(DISF(I,1).LT.EPS)THEN GOTO 200 END IF K=I/7 L=+1-2*K IF(IV.EQ.0)THEN J=I+L*6+(-1)**(I+1) ELSE IF(IV.EQ.1)THEN J=I+L*6 END IF IF(DISF(J,2).LT.EPS)THEN GOTO 200 END IF DIST=DISF(I,1)*DISF(J,2)*S C...QQV vector and axial couplings. DIST=DIST*QQV(I,J) C...no need to set up color connections. HCS=HCS+M2*DIST*FACT IF(GENEV.AND.HCS.GT.RCS)THEN C...generate event. IDN(1)=I IDN(2)=J IF(IV.EQ.0) & IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2)))) IF(IV.EQ.1)IDN(3)=200 IDN(4)=201+IHIGGS COSTH=CT IDCMF=15 ICO(1)=2 ICO(2)=1 ICO(3)=3 ICO(4)=4 C...trick HWETWO in using off-shell V and H masses. VSAVE=RMASS(IDN(3)) HSAVE=RMASS(IDN(4)) RMASS(IDN(3))=EMV RMASS(IDN(4))=EMH C-- BRW fix 27/8/04: avoid double smearing of W and H masses CALL HWETWO(.FALSE.,.FALSE.) RMASS(IDN(3))=VSAVE RMASS(IDN(4))=HSAVE IF(AZSPIN)THEN C...set to zero the coefficients of the spin density matrices. CALL HWVZRO(7,GCOEF) END IF C...calculates exactly polarized decay matrix of gauge boson. IF(IERROR.NE.0)RETURN CCT=CT IF(I.GT.6)CCT=-CT IF(M2L.LT.0.)M2L=0. IF(M2T.LT.0.)M2T=0. RHOHEP(2,NHEP-1)=M2L/M2 CFT=(M2-M2L)/(1.+CCT**2)/2. IF(IV.EQ.0)THEN RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2 RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2 ELSE IF(IV.EQ.1)THEN QR=(VQ(I)-AQ(I))/2. QL=(VQ(I)+AQ(I))/2. RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2) & /(QR**2+QL**2)/M2 RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2) & /(QR**2+QL**2)/M2 END IF RETURN END IF 200 CONTINUE END DO EVWGT=HCS END CDECK ID>, HWHIGW. *CMZ :- -26/04/91 14.55.44 by Federico Carminati *-- Author : Mike Seymour, modified by Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWHIGW C----------------------------------------------------------------------- C HIGGS PRODUCTION VIA W/Z BOSON FUSION C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12, & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2, & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC, & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6), & G2ZZ(6),AWW(2),AZZ(2,6),PWW,PZZ(6),EMZ,EMZ2,RSUM, & GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ, & CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2,K22JAC,COSMIN INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD,NPOW LOGICAL EE,EP EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ, & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200)) IHAD=2 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) IF (FSTWGT) THEN EMW2=EMW**2 EMZ2=EMZ**2 GLUSQ=(VFCH(2,1)+AFCH(2,1))**2 GRUSQ=(VFCH(2,1)-AFCH(2,1))**2 GLDSQ=(VFCH(1,1)+AFCH(1,1))**2 GRDSQ=(VFCH(1,1)-AFCH(1,1))**2 GLESQ=(VFCH(11,1)+AFCH(11,1))**2 GRESQ=(VFCH(11,1)-AFCH(11,1))**2 G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ G1WW=0.25 G2WW=0 FACTR=GEV2NB/(128.*PIFAC**3) EH2=RMASS(201+IHIGGS)**2 CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2 CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN)) ENDIF EE=IPRO.LE.12 EP=IPRO.GE.90 IF (.NOT.GENEV) THEN C---CHOOSE PARAMETERS EVWGT=0. EMH=RMASS(201+IHIGGS) EMFAC=ONE IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC) IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN EMSCA=EMH IF (EE) THEN ROOTS=PHEP(5,3) ELSE TAU=(EMH/PHEP(5,3))**2 TAULN=LOG(TAU) ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN))) ENDIF EMH2=EMH**2 ROOTS2=ROOTS**2 C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2 C WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S X2=EMH2/ROOTS2 1 ETA=X2**HWRGEN(0) IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1 P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2)) & *(-LOG(X2)*(1+X2)-2*(1-X2)) P1=0.5*ROOTS*(1-ETA) C---CHOOSE PHI1,2 UNIFORMLY PHI1=2*PIFAC*HWRGEN(0) PHI2=2*PIFAC*HWRGEN(0) COSPHI=COS(PHI2-PHI1) C---CHOOSE K1^2, ON PROPAGATOR FACTOR K1MAX2=2*P1*ROOTS K1MIN2=0 K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/ & ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2)) C---CALCULATE COSTH1 FROM K1^2 COSTH1=1+K12/(P1*ROOTS) SINTH1=SQRT(1-COSTH1**2) C---CHOOSE K2^2 IF (COSPHI.GT.0 .OR. HWRGEN(0).GT.HALF) THEN K2MAX2=ROOTS*(ROOTS2-EMH2-2*P1*ROOTS)/(ROOTS-P1*(1-COSTH1)) K2MIN2=0 K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/ & ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2)) K22JAC=(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2)) C---CALCULATE A,B,C FACTORS, AND... A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1) B=-2*K22*P1*SINTH1*COSPHI C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1) C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2 TERM2=B**2 + A**2 - C**2 IF (TERM2.LT.ZERO) RETURN TERM2=B*SQRT(TERM2) COSTH2=(-A*C + TERM2)/(A**2+B**2) SINTH2=-(C+A*COSTH2)/B IF (ABS(COSTH2).GE.1.OR.SINTH2.LT.0) RETURN K22JAC=K22JAC $ /(1-(1+COSTH2)*(P1*(COSTH1-SINTH1*COSTH2/SINTH2*COSPHI)) $ /(ROOTS-P1*(1-COSTH1*COSTH2-SINTH1*SINTH2*COSPHI)) ) IF (COSPHI.LE.0) K22JAC=K22JAC*2 ELSE A=ROOTS-P1*(1+COSTH1) B=2*P1*SINTH1*COSPHI COSMIN=(A**2-B**2)/(A**2+B**2) IF (ABS(COSMIN).GE.1) RETURN NPOW=-3 COSTH2=(TWO**NPOW $ -(TWO**NPOW-(1+COSMIN)**NPOW)*HWRGEN(0))**(ONE/NPOW)-1 IF (ABS(COSTH2).GE.1) RETURN SINTH2=SQRT(1-COSTH2**2) K22=-ROOTS*(1+COSTH2)*(ROOTS2-EMH2-2*ROOTS*P1)/ $ (2*ROOTS-2*P1*(1-COSTH1*COSTH2-SINTH1*SINTH2*COSPHI)) K22JAC=-K22/(1+COSTH2)/(K22-EMW2)**2 $ *(1+COSTH2)**(1-NPOW)/(-NPOW)*((1+COSMIN)**NPOW-TWO**NPOW) K22JAC=K22JAC*2 ENDIF C---FINALLY, GET P2 IF (COSTH2.EQ.-ONE) RETURN P2=-K22/(ROOTS*(1+COSTH2)) C---LOAD UP CMF MOMENTA Q1(1)=P1*SINTH1*COS(PHI1) Q1(2)=P1*SINTH1*SIN(PHI1) Q1(3)=P1*COSTH1 Q1(4)=P1 Q1(5)=0 Q2(1)=P2*SINTH2*COS(PHI2) Q2(2)=P2*SINTH2*SIN(PHI2) Q2(3)=P2*COSTH2 Q2(4)=P2 Q2(5)=0 H(1)=-Q1(1)-Q2(1) H(2)=-Q1(2)-Q2(2) H(3)=-Q1(3)-Q2(3) H(4)=-Q1(4)-Q2(4)+ROOTS CALL HWUMAS(H) C---CALCULATE MATRIX ELEMENTS SQUARED AWW(1)=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW) AWW(2)=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G2WW & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G1WW) DO 10 I=1,6 AZZ(1,I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I) & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I)) & *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2 AZZ(2,I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G2ZZ(I) & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G1ZZ(I)) & *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2 10 CONTINUE C---CALCULATE WEIGHT IN INTEGRAL WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2)) & *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2)) & *K22JAC & * EMFAC EMSCA=EMH XXMIN=(ROOTS/PHEP(5,3))**2 XLMIN=LOG(XXMIN) C---INCLUDE BRANCHING RATIO OF HIGGS IF(IMSSM.EQ.0)THEN IDEC=MOD(IPROC,100) IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC) IF (IDEC.EQ.0) THEN BRHIGQ=0 DO 20 I=1,6 20 BRHIGQ=BRHIGQ+BRHIG(I) WEIGHT=WEIGHT*BRHIGQ ENDIF IF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) WEIGHT=WEIGHT*BR ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) WEIGHT=WEIGHT*BR ENDIF END IF IF (EE) THEN CSFAC=WEIGHT IF (IDHW(1).EQ.IDHW(2)) THEN PWW=AWW(1) PZZ(4)=AZZ(1,4) ELSE PWW=AWW(2) PZZ(4)=AZZ(2,4) ENDIF PSUM=PWW+PZZ(4) EVWGT=CSFAC*PSUM ELSEIF (EP) THEN CSFAC=-WEIGHT*TAULN XX(1)=ONE XX(2)=XXMIN CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2) IF (IDHW(1).LE.126) THEN PWW=(DISF(2,2)+DISF( 4,2))*AWW(1)+ & (DISF(7,2)+DISF( 9,2))*AWW(2) PZZ(5)=(DISF(2,2)+DISF( 4,2))*AZZ(1,5)+ & (DISF(8,2)+DISF(10,2))*AZZ(2,5) PZZ(6)=(DISF(1,2)+DISF( 3,2))*AZZ(1,6)+ & (DISF(7,2)+DISF( 9,2))*AZZ(2,6) ELSE PWW=(DISF(8,2)+DISF(10,2))*AWW(1)+ & (DISF(1,2)+DISF( 3,2))*AWW(2) PZZ(5)=(DISF(8,2)+DISF(10,2))*AZZ(1,5)+ & (DISF(2,2)+DISF( 4,2))*AZZ(2,5) PZZ(6)=(DISF(7,2)+DISF( 9,2))*AZZ(1,6)+ & (DISF(1,2)+DISF( 3,2))*AZZ(2,6) ENDIF PSUM=PWW+PZZ(5)+PZZ(6) EVWGT=CSFAC*PSUM ELSE CSFAC=WEIGHT*TAULN*XLMIN CALL HWSGEN(.TRUE.) PWW=((DISF(2,1)+DISF( 4,1))*(DISF(1,2)+DISF( 3,2)) & +(DISF(1,1)+DISF( 3,1))*(DISF(2,2)+DISF( 4,2)) & +(DISF(7,1)+DISF( 9,1))*(DISF(8,2)+DISF(10,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(7,2)+DISF( 9,2))) & *AWW(1)+ & ((DISF(2,1)+DISF( 4,1))*(DISF(8,2)+DISF(10,2)) & +(DISF(1,1)+DISF( 3,1))*(DISF(7,2)+DISF( 9,2)) & +(DISF(7,1)+DISF( 9,1))*(DISF(1,2)+DISF( 3,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(2,2)+DISF( 4,2))) & *AWW(2) PZZ(1)=((DISF(2,1)+DISF( 4,1))*(DISF(2,2)+DISF( 4,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(8,2)+DISF(10,2))) & *AZZ(1,1)+ & ((DISF(2,1)+DISF( 4,1))*(DISF(8,2)+DISF(10,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(2,2)+DISF( 4,2))) & *AZZ(2,1) PZZ(2)=((DISF(2,1)+DISF( 4,1))*(DISF(1,2)+DISF( 3,2)) & +(DISF(1,1)+DISF( 3,1))*(DISF(2,2)+DISF( 4,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(7,2)+DISF( 9,2)) & +(DISF(7,1)+DISF( 9,1))*(DISF(8,2)+DISF(10,2))) & *AZZ(1,2)+ & ((DISF(2,1)+DISF( 4,1))*(DISF(7,2)+DISF( 9,2)) & +(DISF(1,1)+DISF( 3,1))*(DISF(8,2)+DISF(10,2)) & +(DISF(8,1)+DISF(10,1))*(DISF(1,2)+DISF( 3,2)) & +(DISF(7,1)+DISF( 9,1))*(DISF(2,2)+DISF( 4,2))) & *AZZ(2,2) PZZ(3)=((DISF(1,1)+DISF(3,1))*(DISF(1,2)+DISF(3,2)) & +(DISF(7,1)+DISF(9,1))*(DISF(7,2)+DISF(9,2))) & *AZZ(1,3)+ & ((DISF(1,1)+DISF(3,1))*(DISF(7,2)+DISF(9,2)) & +(DISF(7,1)+DISF(9,1))*(DISF(1,2)+DISF(3,2))) & *AZZ(2,3) PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3) C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS EVWGT=CSFAC*PSUM ENDIF ELSE C---GENERATE EVENT C---CHOOSE EVENT TYPE RSUM=PSUM*HWRGEN(0) C---ELECTRON BEAMS? IF (EE) THEN IDN(1)=IDHW(1) IDN(2)=IDHW(2) C---WW FUSION? IF (RSUM.LT.PWW) THEN IDN(3)=IDN(1)+1 IDN(4)=IDN(2)+1 C---ZZ FUSION? ELSE IDN(3)=IDN(1) IDN(4)=IDN(2) ENDIF C---LEPTON-HADRON COLLISION? ELSEIF (EP) THEN C---WW FUSION? IDN(1)=IDHW(1) IF (RSUM.LT.PWW) THEN 24 IDN(2)=HWRINT(1,8) IF (IDN(2).GE.5) IDN(2)=IDN(2)+2 IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24 IF (IDN(1).LE.126.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(2),2)*AWW(1)/PWW ELSE PROB=DISF(IDN(2),2)*AWW(2)/PWW ENDIF IF (HWRGEN(0).GT.PROB) GOTO 24 IDN(3)=IDN(1)+1 IF (HWRGEN(0).GT.SCABI) THEN IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3 ELSE IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5 ENDIF C---ZZ FUSION FROM U-TYPE QUARK? ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN 26 IDN(2)=2*HWRINT(1,4) IF (IDN(2).GE.5) IDN(2)=IDN(2)+2 IF (IDN(1).LE.126.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(2),2)*AZZ(1,5)/PZZ(5) ELSE PROB=DISF(IDN(2),2)*AZZ(2,5)/PZZ(5) ENDIF IF (HWRGEN(0).GT.PROB) GOTO 26 IDN(3)=IDN(1) IDN(4)=IDN(2) C---ZZ FUSION FROM D-TYPE QUARK? ELSE 28 IDN(2)=2*HWRINT(1,4)-1 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2 IF (IDN(1).LE.126.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(2),2)*AZZ(1,6)/PZZ(6) ELSE PROB=DISF(IDN(2),2)*AZZ(2,6)/PZZ(6) ENDIF IF (HWRGEN(0).GT.PROB) GOTO 28 IDN(3)=IDN(1) IDN(4)=IDN(2) ENDIF C---HADRON BEAMS? ELSE C---WW FUSION? IF (RSUM.LT.PWW) THEN 31 DO 32 I=1,2 IDN(I)=HWRINT(1,8) IF (IDN(I).GE.5) IDN(I)=IDN(I)+2 32 CONTINUE IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31 IF (IDN(1).LE.6.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW(1)/PWW ELSE PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW(2)/PWW ENDIF IF (HWRGEN(0).GT.PROB) GOTO 31 C---CHOOSE OUTGOING QUARKS DO 33 I=1,2 IF (HWRGEN(0).GT.SCABI) THEN IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3 ELSE IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5 ENDIF 33 CONTINUE C---ZZ FUSION FROM U-TYPE QUARKS? ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN 41 DO 42 I=1,2 IDN(I)=2*HWRINT(1,4) IF (IDN(I).GE.5) IDN(I)=IDN(I)+2 42 CONTINUE IF (IDN(1).LE.6.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,1)/PZZ(1) ELSE PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,1)/PZZ(1) ENDIF IF (HWRGEN(0).GT.PROB) GOTO 41 IDN(3)=IDN(1) IDN(4)=IDN(2) C---ZZ FUSION FROM D-TYPE QUARKS? ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN 51 DO 52 I=1,2 IDN(I)=2*HWRINT(1,4)-1 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2 52 CONTINUE IF (IDN(1).LE.6.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,3)/PZZ(3) ELSE PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,3)/PZZ(3) ENDIF IF (HWRGEN(0).GT.PROB) GOTO 51 IDN(3)=IDN(1) IDN(4)=IDN(2) C---ZZ FUSION FROM UD-TYPE PAIRS? ELSE 61 IF (HWRGEN(0).GT.HALF) THEN IDN(1)=2*HWRINT(1,4)-1 IDN(2)=2*HWRINT(1,4) ELSE IDN(1)=2*HWRINT(1,4) IDN(2)=2*HWRINT(1,4)-1 ENDIF DO 62 I=1,2 62 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2 IF (IDN(1).LE.6.AND.IDN(2).LE.6 $ .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,2)/PZZ(2) ELSE PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,2)/PZZ(2) ENDIF IF (HWRGEN(0).GT.PROB) GOTO 61 IDN(3)=IDN(1) IDN(4)=IDN(2) ENDIF ENDIF C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc IDCMF=15 C---INCOMING IF (.NOT.EE) CALL HWEONE C---CMF POINTERS JDAHEP(1,NHEP)=NHEP+1 JDAHEP(2,NHEP)=NHEP+3 JMOHEP(1,NHEP+1)=NHEP JMOHEP(1,NHEP+2)=NHEP JMOHEP(1,NHEP+3)=NHEP C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!) Q1(5)=RMASS(IDN(3)) Q1(4)=SQRT(Q1(4)**2+Q1(5)**2) Q2(5)=RMASS(IDN(4)) Q2(4)=SQRT(Q2(4)**2+Q2(5)**2) H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP) CALL HWUMAS(H) CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1)) CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2)) CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3)) C---STATUS AND IDs ISTHEP(NHEP+1)=113 ISTHEP(NHEP+2)=114 ISTHEP(NHEP+3)=114 IDHW(NHEP+1)=IDN(3) IDHEP(NHEP+1)=IDPDG(IDN(3)) IDHW(NHEP+2)=IDN(4) IDHEP(NHEP+2)=IDPDG(IDN(4)) IDHW(NHEP+3)=201+IHIGGS IDHEP(NHEP+3)=IDPDG(201+IHIGGS) C---COLOUR LABELS JMOHEP(2,NHEP+1)=NHEP-2 JMOHEP(2,NHEP+2)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP+2 JMOHEP(2,NHEP-2)=NHEP+1 JMOHEP(2,NHEP+3)=NHEP+3 JDAHEP(2,NHEP+1)=NHEP-2 JDAHEP(2,NHEP+2)=NHEP-1 JDAHEP(2,NHEP-1)=NHEP+2 JDAHEP(2,NHEP-2)=NHEP+1 JDAHEP(2,NHEP+3)=NHEP+3 NHEP=NHEP+3 ENDIF END CDECK ID>, HWHIGY. *CMZ :- -26/04/91 13.37.37 by Federico Carminati *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWHIGY(A,B,XP) C----------------------------------------------------------------------- C CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y PARAMETER (TWO=2.D0) C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4 C1(Z,A)=A**4/(3*Z) C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2) C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3 C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4 C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A C6(Z,A)=0.5*Z**2-12*Z+4*(A+6) C7(Z,A)=Z/3-8 C8(Z,A)=0.25 FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z) & +C1(Z,A)/Y**3 & +C2(Z,A)/Y**2 & +C3(Z,A)/Y & +C4(Z,A)*LOG(Y) & +C5(Z,A)*Y & +C6(Z,A)*Y**2 & +C7(Z,A)*Y**3 & +C8(Z,A)*Y**4 C---NOW EVALUATE THE INTEGRAL HWHIGY=0 IF (A.GT.4) RETURN XQ=DCMPLX(XP,B) Z1=XQ+SQRT(XQ**2-A) Z2=XQ-SQRT(XQ**2-A) Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A) Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A) HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B) END CDECK ID>, HWHIGZ. *CMZ :- -02/05/91 11.18.44 by Federico Carminati *-- Author : Mike Seymour, modified by Stefano Moretti C----------------------------------------------------------------------- SUBROUTINE HWHIGZ C----------------------------------------------------------------------- C HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H C WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL C USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32 C C MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE, & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP, & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2, & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2 EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2 EQUIVALENCE (EMZ,RMASS(200)) SAVE ELST DATA ELST/0/ C---SET UP CONSTANTS IN1=1 IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1) IN2=2 IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2) IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN ELST=PHEP(5,3) CVE=VFCH(11,1) CAE=AFCH(11,1) POL1=1.-EPOLN(3)*PPOLN(3) POL2=PPOLN(3)-EPOLN(3) CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE) CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2)) IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR. & (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2 IF (TPOL) CE3=(CVE**2-CAE**2) PMAX=4 EMZ2=EMZ**2 S=PHEP(5,3)**2 B=EMZ*GAMZ/S FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201+IHIGGS)**2)*ENHANC(11))**2 & /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2) ENDIF IF (.NOT.GENEV) THEN C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT EVWGT=0D0 EMH=RMASS(201+IHIGGS) EMFAC=ONE IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC) IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN EMSCA=EMH EMH2=EMH**2 A=4*EMH2/S XP=1+(EMH2-EMZ2)/S EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC C---INCLUDE BRANCHING RATIO OF HIGGS IF(IMSSM.EQ.0)THEN IDEC=MOD(IPROC,100) IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC) IF (IDEC.EQ.0) THEN BRHIGQ=0 DO 10 I=1,6 10 BRHIGQ=BRHIGQ+BRHIG(I) EVWGT=EVWGT*BRHIGQ ENDIF C Add Z branching fractions CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0) EVWGT=EVWGT*BR IF (IDEC.EQ.10) THEN CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1) EVWGT=EVWGT*BR ELSEIF (IDEC.EQ.11) THEN CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1) EVWGT=EVWGT*BR ENDIF END IF ELSE C---GENERATE EVENT ICMF=NHEP+1 IHIG=NHEP+2 IZED=NHEP+3 IFER=NHEP+4 IANT=NHEP+5 CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF)) NHEP=NHEP+5 C---CHOOSE ENERGY FRACTION OF HIGGS X1=SQRT(A) X2=1+0.25*A XP=1+(EMH2-EMZ2)/S FAC1=ATAN((X1-XP)/B) FAC2=ATAN((X2-XP)/B) XPP=MIN(X2,MAX(X1+B,XP)) XPPSQ=XPP**2 NLOOP=0 COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A)) 20 NLOOP=NLOOP+1 IF (NLOOP.GT.NBTRY) THEN CALL HWWARN('HWHIGZ',101) GOTO 999 ENDIF X=XP+B*TAN(HWRUNI(1,FAC1,FAC2)) XSQ=X**2 PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A)) IF (PROB.GT.PMAX) THEN PMAX=1.1*PROB CALL HWWARN('HWHIGZ',1) WRITE (6,21) PMAX 21 FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4) ENDIF IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20 C Choose Z decay mode CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0) C1=CE1*(CV**2+CA**2) C2=CE2*2.*CV*CA C---CHOOSE HIGGS DIRECTION C First polar angle NLOOP=0 COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A) 30 NLOOP=NLOOP+1 IF (NLOOP.GT.NBTRY) THEN CALL HWWARN('HWHIGZ',102) GOTO 999 ENDIF CHIGG=HWRUNI(2,-ONE, ONE) PTHETA=1-COEF*CHIGG**2 IF (PTHETA.LT.HWRGEN(1)) GOTO 30 SHIGG=SQRT(1-CHIGG**2) C Now azimuthal angle IF (TPOL) THEN C3=CE3*(CV*2+CA**2) COEF=COEF*SHIGG**2*C3/C1 PHIMAX=PTHETA+ABS(COEF) 40 CALL HWRAZM(ONE,CPHI,SPHI) C2PHI=2.*CPHI**2-1. S2PHI=2.*CPHI*SPHI PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS) IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40 ELSE CALL HWRAZM(ONE,CPHI,SPHI) ENDIF C Construct Higgs and Z momenta PHEP(5,IHIG)=EMH PHEP(4,IHIG)=X*PHEP(5,ICMF)/2 PCM=SQRT(PHEP(4,IHIG)**2-EMH2) PHEP(3,IHIG)=CHIGG*PCM PHEP(1,IHIG)=SHIGG*PCM*CPHI PHEP(2,IHIG)=SHIGG*PCM*SPHI CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED)) CALL HWUMAS(PHEP(1,IZED)) C Choose orientation of Z decay NLOOP=0 COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED)) & *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2)) PCM=PHEP(5,IZED)/2 PHEP(5,IFER)=0 PHEP(5,IANT)=0 50 NLOOP=NLOOP+1 IF (NLOOP.GT.NBTRY) THEN CALL HWWARN('HWHIGZ',103) GOTO 999 ENDIF CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT), & PCM,TWO,.TRUE.) PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT)) & +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT)) IF (TPOL) PROB=PROB+C3* & (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT)) & +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT))) IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50 C---SET UP STATUS CODES, ISTHEP(ICMF)=120 ISTHEP(IHIG)=190 ISTHEP(IZED)=195 ISTHEP(IFER)=113 ISTHEP(IANT)=114 C---COLOR CONNECTIONS, JMOHEP(1,ICMF)=1 JMOHEP(2,ICMF)=2 JDAHEP(1,ICMF)=IHIG JDAHEP(2,ICMF)=IZED JMOHEP(1,IHIG)=ICMF JMOHEP(1,IZED)=ICMF JMOHEP(1,IFER)=IZED JMOHEP(1,IANT)=IZED JMOHEP(2,IFER)=IANT JMOHEP(2,IANT)=IFER JDAHEP(1,IZED)=IFER JDAHEP(2,IZED)=IANT JDAHEP(2,IFER)=IANT JDAHEP(2,IANT)=IFER C---IDENTITY CODES IDHW(ICMF)=200 IDHW(IHIG)=201+IHIGGS IDHW(IZED)=200 IDHEP(ICMF)=IDPDG(IDHW(ICMF)) IDHEP(IHIG)=IDPDG(IDHW(IHIG)) IDHEP(IZED)=IDPDG(IDHW(IZED)) IDHEP(IFER)=IDPDG(IDHW(IFER)) IDHEP(IANT)=IDPDG(IDHW(IANT)) ENDIF 999 RETURN END CDECK ID>, HWHIHH. *CMZ :- -25/11/01 17.11.33 by Stefano Moretti *-- Author : Kosuke Odagiri, modified by Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variable C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as C...described in the HERWIG 6 documentation file. C C...First release: 12-NOV-2001 by Stefano Moretti C C----------------------------------------------------------------------- SUBROUTINE HWHIHH C----------------------------------------------------------------------- C PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE, & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2, & GHH(4), XWEIN, S2W, X(1), XL(1), & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2, & EMHWT1, EMHWT2, EMHHWT, SHAT INTEGER I, ID1, ID2, IH1, IH2, IH, JH EXTERNAL HWRGEN, HWUAEM SAVE HCS,MNN,MCC,EMHHWT,S,SHAT DOUBLE COMPLEX Z, GZ, A, D, E PARAMETER (Z = (0.D0,1.D0)) EQUIVALENCE (MZ, RMASS(200)) C...process event. IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE HCS = ZERO EVWGT = ZERO C...energy at parton level. ECM = PBEAM1+PBEAM2 S = ECM*ECM SHAT = S C...phase space variables. C...X(1)=COS(THETA_CM), C...phase space borders. XL(1)= -1. XU(1)= 1. C...single phase space point. WEIGHT=1. DO I=1,1 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...final state masses. IF((MOD(IPROC,10000).EQ.965).OR. & (MOD(IPROC,10000).EQ.975))THEN JH = IHIGGS-1 ID1 = 205 ID2 = 202 + JH ELSE IF(MOD(IPROC,10000).EQ.955)THEN JH = 4 ID1 = 206 ID2 = 207 END IF RMH1=RMASS(ID1) RMH2=RMASS(ID2) EMH1=RMH1 EMH2=RMH2 EMHWT1=1. EMHWT2=1. EMHHWT=EMHWT1*EMHWT2 C...polar angle. COSTH = X(1) SN2TH = 0.25D0 - 0.25D0*COSTH**2 EMSCA = EMH1+EMH2 EMSC2 = EMSCA*EMSCA EVWGT = ZERO FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/2. C...constant weight. FACTR = FACTR*WEIGHT C...couplings and propagators. XWEIN = TWO*SWEIN S2W = DSQRT(XWEIN*(TWO-XWEIN)) GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT GZ2 = DREAL(DCONJG(GZ)*GZ) C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-. GHH(1)= COSBMA GHH(2)= SINBMA GHH(3)= ONE GHH(4)= ONE-XWEIN C...set to zero all MEs. DO I=1,2 MNN(I)=ZERO END DO MCC=ZERO C...start subprocesses. IF((MOD(IPROC,10000).EQ.965).OR. & (MOD(IPROC,10000).EQ.975))THEN c c - + o o o c l l -> A h / H c DO IH = JH,JH QPE = SHAT-(EMH1+EMH2)**2 IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT MNN(IH) = & FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2 ELSE CONTINUE END IF END DO ELSE IF(MOD(IPROC,10000).EQ.955)THEN c c - + + - c l l -> H H c IH = JH QPE = SHAT-(EMH1+EMH2)**2 IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT A = GHH(IH)/GZ D = QFCH(11)+A*LFCH(11) E = QFCH(11)+A*RFCH(11) MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E) ELSE CONTINUE END IF END IF END IF HCS = ZERO IF(MOD(IPROC,10000).EQ.965)THEN IH1 = 205 IH2 = 203 HCS = HCS + EMHHWT*MNN(1) ELSE IF(MOD(IPROC,10000).EQ.975)THEN IH1 = 205 IH2 = 204 HCS = HCS + EMHHWT*MNN(2) ELSE IF(MOD(IPROC,10000).EQ.955)THEN IH1 = 206 IH2 = 207 HCS = HCS + EMHHWT*MCC END IF IF (GENEV.AND.HCS.GT.RCS) THEN C...generate event. IDN(1)=IDHW(1) IDN(2)=IDHW(2) IDN(3)=IH1 IDN(4)=IH2 IDCMF=15 XX(1) = ONE XX(2) = ONE CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN CALL HWVZRO(7,GCOEF) END IF END IF EVWGT = HCS END CDECK ID>, HWHISQ. *CMZ :- -30/06/01 18.41.23 by Stefano Moretti *-- Author : Stefano Moretti C----------------------------------------------------------------------- C...Generate completely differential cross section (EVWGT) in the variables C...X(I) with I=1,6 (see below) for the processes from IPROC=3110 C...to IPROC=3298, as described in the HERWIG 6 documentation file. C...It includes interface to PDFs and takes into account color connections C...among partons. C C...First release: 08-APR-2000 by Stefano Moretti C...Last modified: 29-JUN-2001 by Stefano Moretti C C----------------------------------------------------------------------- SUBROUTINE HWHISQ C----------------------------------------------------------------------- C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX INTEGER JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX INTEGER I,J,K,L,M,N INTEGER IQMIN,IQMAX,IGG,IQQ,JPP INTEGER NC,FLIP INTEGER IF1,IF2 INTEGER JHH,IMIX1,IMIX2 INTEGER JSQ,JSQ1,JSQ2 INTEGER IME,JME DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT DOUBLE PRECISION GSQ1,GSQ2 DOUBLE PRECISION X(6),XL(6),XU(6) DOUBLE PRECISION Q4(0:3),Q34(0:3) DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM DOUBLE PRECISION GGSQHT,GGSQHU,GGSQHN,QQSQH DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8) DOUBLE PRECISION ALPHA,ALPHAS,EMSC2 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3) DOUBLE PRECISION VCOL,GCOL,QAUX(0:3) DOUBLE PRECISION EPS,HCS,RCS,GACT,FACT(8),DIST DOUBLE PRECISION WEIGHT SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5 SAVE IME,JSQ1,JSQ2 LOGICAL HWRLOG EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG PARAMETER (EPS=1.D-9) EQUIVALENCE (NC,NCOLO) C...process the event. IF(GENEV)THEN RCS=HCS*HWRGEN(0) ELSE HCS=0. EVWGT=0. C...loop over final state flavours. IME=0 DO I=1,8 M2GG(I)=0. M2GGPL(I)=0. M2GGMN(I)=0. M2QQ(I)=0. FACT(I)=0. END DO DO 2 IF1=IF1MIN,IF1MAX IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2 DO 1 IF2=IF2MIN,IF2MAX IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1 C...assign squark flavour. JSQ1=IF1 JSQ2=IF2 C...check charge. IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1 IME=IME+1 IF((IME.LE.0).OR.(IME.GT.8)) THEN CALL HWWARN('HWHISQ',100) GOTO 999 ENDIF C...assign final state masses and widths. EMSQ1=RMASS(JSQ1) EMSQ2=RMASS(JSQ2) GAMSQ1=HBAR/RLTIM(JSQ1) GAMSQ2=HBAR/RLTIM(JSQ2) EMH=RMASS(201+JHIGGS+1) EMHWT=1. C...energy at hadron level. ECM_MAX=PBEAM1+PBEAM2 S=ECM_MAX*ECM_MAX C...phase space variables. C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH), C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34, C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2), C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU); C...phase space borders. XL(1)=0. XU(1)=1. XL(2)=-1. XU(2)=1. XL(3)=-1. XU(3)=1. XL(4)=0. XU(4)=2.*PIFAC XL(5)=0. XU(5)=1. XL(6)=0. XU(6)=1. C...single phase space point. 100 CONTINUE WEIGHT=1. DO I=1,6 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0) WEIGHT=WEIGHT*ABS(XU(I)-XL(I)) END DO C...energy at parton level. ECM=SQRT(1./(X(5)*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2) & +1./ECM_MAX**2)) IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN SHAT=ECM*ECM TAU=SHAT/S C...momentum fractions X1 and X2. XX(1)=EXP(LOG(TAU)*(1.-X(6))) XX(2)=TAU/XX(1) C...three particle kinematics. EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2 CT5=X(2) IF(HWRLOG(HALF))THEN ST5=+SQRT(1.-CT5*CT5) ELSE ST5=-SQRT(1.-CT5*CT5) END IF CT4=X(3) ST4=SQRT(1.-CT4*CT4) CF4=COS(X(4)) SF4=SIN(X(4)) RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**2)/ & (4.*ECM*ECM) IF(RQ52.LT.0.)THEN GOTO 100 ELSE RQ5=SQRT(RQ52) ENDIF P5(1)=0. P5(2)=RQ5*ST5 P5(3)=RQ5*CT5 P5(0)=SQRT(RQ52+EMH*EMH) DO I=1,3 Q34(I)=-P5(I) END DO Q34(0)=SQRT(RQ52+EMSQQ*EMSQQ) RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2 & -(2.*EMSQ1*EMSQ2)**2)/ & (4.*EMSQQ*EMSQQ) IF(RQ42.LT.0.)THEN GOTO 100 ELSE RQ4=SQRT(RQ42) ENDIF Q4(1)=RQ4*ST4*CF4 Q4(2)=RQ4*ST4*SF4 Q4(3)=RQ4*CT4 Q4(0)=SQRT(RQ42+EMSQ2*EMSQ2) PQ4=0. DO I=1,3 PQ4=PQ4+Q34(I)*Q4(I) END DO P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ P3(0)=Q34(0)-P4(0) DO I=1,3 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ) P3(I)=Q34(I)-P4(I) END DO C...incoming partons: all massless. EMIN=0. C...initial state momenta in the partonic CM. PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2 & -(2.*EMIN*EMIN)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN*EMIN) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN*EMIN) P2(1)=0. P2(2)=0. P2(3)=-PCM C...color structured ME summed/averaged over final/initial spins and colors. IGG=1 IQQ=1 JPP=(MOD(IPROC,10000)/10-ILBL/10) IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0 IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0 GSQ1=GAMSQ1*EMSQ1 GSQ2=GAMSQ2*EMSQ2 CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2, & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH) M2GG(IME)=GGSQHN/(8.*CFFAC) M2GGPL(IME)=GGSQHT/(8.*CFFAC) M2GGMN(IME)=GGSQHU/(8.*CFFAC) M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4. C...constant factors: phi along beam and conversion GeV^2->nb. GACT=2.*PIFAC*GEV2NB C...Jacobians from X1,X2 to X(5),X(6) GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2) C...phase space Jacobians, pi's and flux. GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5 & *(ECM-EMSQ1-EMSQ2-EMH) C...EW and QCD couplings. EMSCA=EMSQ1+EMSQ2+EMH EMSC2=EMSCA*EMSCA ALPHA=HWUAEM(EMSC2) ALPHAS=HWUALF(1,EMSCA) GACT=GACT*4.*PIFAC*ALPHA/SWEIN GACT=GACT*16.*PIFAC**2*ALPHAS**2 C...enhancement factor for MSSM. JHH=JHIGGS IF(JHIGGS.EQ.5)JHH=4 JSQ=JSQ1-400 IF(JSQ1.GT.412)JSQ=JSQ1-412 IMIX1=1 IMIX2=1 IF(JSQ1.GT.412)IMIX1=2 IF(JSQ2.GT.418)IMIX2=2 SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2) GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ) C...Higgs resonance. GACT=GACT*EMHWT C...constant weight. GACT=GACT*WEIGHT C...collects it. FACT(IME)=GACT 1 CONTINUE 2 CONTINUE END IF C...set up flavours in final state. FLIP=0 C...set up PDFs. HCS=0. CALL HWSGEN(.FALSE.) IQMAX=13 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12 IQMIN=1 IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1 DO 3 JME=1,IME IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3 DO I=IQMIN,IQMAX IF(DISF(I,1).LT.EPS)THEN GOTO 200 END IF K=I/7 L=+1-2*K IF(I.EQ.13)L=0 J=I+L*6 IF(DISF(J,2).LT.EPS)THEN GOTO 200 END IF DIST=DISF(I,1)*DISF(J,2)*S IF(I.LT.13)THEN C...set up color connections: qq-scattering. IF(J.EQ.I+6)THEN HCS=HCS+M2QQ(JME)*DIST*FACT(JME) IF(GENEV.AND.HCS.GT.RCS)THEN CONTINUE CALL HWHQCP(JSQ1,JSQ2,2413, 4) GOTO 9 END IF ELSE IF(I.EQ.J+6)THEN HCS=HCS+M2QQ(JME)*DIST*FACT(JME) IF(GENEV.AND.HCS.GT.RCS)THEN FLIP=1 CALL HWHQCP(JSQ2,JSQ1,3142,12) GOTO 9 END IF END IF ELSE C...set up color connections: gg-scattering. HCS=HCS & +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME) & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(JSQ1,JSQ2,2413,27) GOTO 9 ENDIF HCS=HCS & +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME) & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(JSQ1,JSQ2,4123,28) GOTO 9 ENDIF END IF 200 CONTINUE END DO 3 CONTINUE EVWGT=HCS RETURN C...generate event. 9 IDN(1)=I IDN(2)=J IDN(5)=JH C...incoming partons: now massive. EMIN1=RMASS(IDN(1)) EMIN2=RMASS(IDN(2)) C...redo initial state momenta in the partonic CM. PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT) PCM=SQRT(PCM2) P1(0)=SQRT(PCM2+EMIN1*EMIN1) P1(1)=0. P1(2)=0. P1(3)=PCM P2(0)=SQRT(PCM2+EMIN2*EMIN2) P2(1)=0. P2(2)=0. P2(3)=-PCM C...randomly rotate final state momenta around beam axis. PHI=2.*PIFAC*HWRGEN(0) CPHI=COS(PHI) SPHI=SIN(PHI) ROT(1,1)=+CPHI ROT(1,2)=+SPHI ROT(1,3)=0. ROT(2,1)=-SPHI ROT(2,2)=+CPHI ROT(2,3)=0. ROT(3,1)=0. ROT(3,2)=0. ROT(3,3)=1. DO L=1,3 DO M=1,3 QAUX(M)=0. DO N=1,3 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N) IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N) IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N) END DO END DO DO M=1,3 IF(L.EQ.1)P3(M)=QAUX(M) IF(L.EQ.2)P4(M)=QAUX(M) IF(L.EQ.3)P5(M)=QAUX(M) END DO END DO C...use HWETWO only to set up status and IDs of (s)quarks. COSTH=0. IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) C...do real incoming, outgoing momenta in the lab frame. VCOL=(XX(1)-XX(2))/(XX(1)+XX(2)) GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2)) DO M=NHEP-4,NHEP+1 IF(M.EQ.NHEP-2)GO TO 888 DO N=0,3 IF(M.EQ.NHEP-4)QAUX(N)=P1(N) IF(M.EQ.NHEP-3)QAUX(N)=P2(N) IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP IF(M.EQ.NHEP+1)QAUX(N)=P5(N) END DO C...perform boost. PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3)) PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0)) PHEP(2,M)=QAUX(2) PHEP(1,M)=QAUX(1) 888 CONTINUE END DO C...needs to set all final state masses. PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2 & -PHEP(3,NHEP-1)**2 & -PHEP(2,NHEP-1)**2 & -PHEP(1,NHEP-1)**2)) PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2 & -PHEP(3,NHEP )**2 & -PHEP(2,NHEP )**2 & -PHEP(1,NHEP )**2)) PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2 & -PHEP(3,NHEP+1)**2 & -PHEP(2,NHEP+1)**2 & -PHEP(1,NHEP+1)**2)) C...sets CMF. DO I=1,4 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3) END DO PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2 & -PHEP(3,NHEP-2)**2 & -PHEP(2,NHEP-2)**2 & -PHEP(1,NHEP-2)**2)) C...status and IDs for Higgs. ISTHEP(NHEP+1)=114 IDHW(NHEP+1)=IDN(5) IDHEP(NHEP+1)=IDPDG(IDN(5)) C...Higgs colour (self-)connections. JMOHEP(1,NHEP+1)=NHEP-2 JMOHEP(2,NHEP+1)=NHEP+1 JDAHEP(2,NHEP+1)=NHEP+1 JDAHEP(2,NHEP-2)=NHEP+1 NHEP=NHEP+1 IF(AZSPIN)THEN C...set to zero the coefficients of the spin density matrices. CALL HWVZRO(7,GCOEF) END IF 999 RETURN END CDECK ID>, HWHPH2. *CMZ :- -12/01/93 10.12.43 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHPH2 C----------------------------------------------------------------------- C QQD direct photon pair production: mean EVWGT = sigma in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2, & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ, & DSTU,HCS INTEGER ID,ID1,ID2 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB SAVE HCS,CSTU,DSTU,FACT PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK=ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) ) YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) ) YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=0.5*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN COSTH=(Z1-Z2)/(Z1+Z2) S=XX(1)*XX(2)*PHEP(5,3)**2 RS=0.5*SQRT(S) T=-0.5*S*(1.-COSTH) U=-S-T EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) C--BRW fix 15/07/10 put in ident particle factor of 1/2 FACT=GEV2NB*PIFAC*0.25*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) C--end fix & *(ALPHEM/S)**2 CALL HWSGEN(.FALSE.) CSTU=2.*(U/T+T/U)/CAFAC IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN TQSQ=0. DO 10 ID=1,6 10 IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2 DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U) & /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2 ELSE DSTU=0 ENDIF ENDIF HCS=0. DO 30 ID=1,6 FACTR=FACT*CSTU*QFCH(ID)**4 C q+qbar ---> gamma+gamma ID1=ID ID2=ID+6 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(59,59,2134,61) GOTO 99 ENDIF C qbar+q ---> gamma+gamma 20 ID1=ID+6 ID2=ID IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(59,59,2134,62) GOTO 99 ENDIF 30 CONTINUE C g+g ---> gamma+gamma ID1=13 ID2=13 HCS=HCS+DSTU IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(59,59,2134,63) GOTO 99 ENDIF EVWGT=HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHPHO. *CMZ :- -26/04/91 14.55.45 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHPHO C----------------------------------------------------------------------- C QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2, & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF, & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH INTEGER ID,ID1,ID2 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB SAVE HCS,FACT,CSTU,CTSU,CUST,DSTU PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK=ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) ) YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) ) YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=0.5*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN COSTH=(Z1-Z2)/(Z1+Z2) S=XX(1)*XX(2)*PHEP(5,3)**2 RS=0.5*SQRT(S) T=-0.5*S*(1.-COSTH) U=-S-T C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM & *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2 CALL HWSGEN(.FALSE.) C CF=2.*CFFAC/CAFAC AF=-1./CAFAC CSTU=CF*(U/T+T/U) CTSU=AF*(U/S+S/U) CUST=AF*(T/S+S/T) IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN TQCH=0. DO 10 ID=1,6 10 IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID) DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U) & *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2 ELSE DSTU=0 ENDIF ENDIF C HCS=0. DO 30 ID=1,6 FACTR=FACT*QFCH(ID)**2 C---QUARK FIRST ID1=ID IF (DISF(ID1,1).LT.EPS) GOTO 20 ID2=ID1+6 HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 59,2314,41) GOTO 9 ENDIF ID2=13 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1, 59,3124,42) GOTO 9 ENDIF C---QBAR FIRST 20 ID1=ID+6 IF (DISF(ID1,1).LT.EPS) GOTO 30 ID2=ID HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 59,3124,43) GOTO 9 ENDIF ID2=13 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1, 59,2314,44) GOTO 9 ENDIF 30 CONTINUE C---GLUON FIRST ID1=13 FACTF=FACT*CUST*DISF(ID1,1) DO 50 ID=1,6 FACTR=FACTF*QFCH(ID)**2 ID2=ID IF (DISF(ID2,2).LT.EPS) GOTO 40 HCS=HCS+FACTR*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID2, 59,2314,45) GOTO 9 ENDIF 40 ID2=ID+6 IF (DISF(ID2,2).LT.EPS) GOTO 50 HCS=HCS+FACTR*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID2, 59,3124,46) GOTO 9 ENDIF 50 CONTINUE C g+g ---> g+gamma ID2=13 HCS=HCS+DSTU IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 59,2314,47) GOTO 9 ENDIF EVWGT=HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHPPB. *CMZ :- -12/01/93 10.12.43 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHPPB(S,T,U) C----------------------------------------------------------------------- C Quark box diagram contribution to photon/gluon scattering C Internal quark mass neglected: m_q << U,T,S C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU PI2=ACOS(-1.D0)**2 S2=S**2 T2=T**2 U2=U**2 ALNTU=LOG(T/U) ALNST=LOG(-S/T) ALNSU=ALNST+ALNTU HWHPPB=5.*4. & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2 & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2 )/U2)**2 & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2 )/T2)**2 & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2 & +((U2-S2+(U2+S2)*ALNSU)/T2)**2) END CDECK ID>, HWHPPE. *CMZ :- -12/01/93 10.12.43 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHPPE C----------------------------------------------------------------------- C point-like photon/QCD heavy flavour single excitation, using exact C massive lightcone kinematics, mean EVWGT = sigma in nb. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR, & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2 EXTERNAL HWRGEN,HWRUNI,HWUALF SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS PARAMETER (EPS=1.E-9) IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1)) PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2)) XX(1)=1. IQ1=MOD(IPROC,100) IQ2=IQ1+6 QM2=RMASS(IQ1)**2 FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1 & *ALPHEM*QFCH(IQ1)**2 ENDIF IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(PT,PJ) PT2=PT**2 PTM=SQRT(PT2+QM2) EXY=EXP(HWRUNI(1,YJMIN,YJMAX)) T=-PP1*PT/EXY CC=T**2-4.*QM2*(PT2+T) IF (CC.LT.ZERO) RETURN EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM) IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN XX(2)=(PT/EXY+PTM/EXY2)/PP2 IF (XX(2).GT.ONE) RETURN C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q') S=XX(2)*PP1*PP2 U=-S-T COSTH=(1.+QM2/S)*(T-U)/S-QM2/S C Set hard process scale (Approx ET-jet) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) C=QM2*T/(U*S) SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C)) & /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2)) CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2) ENDIF HCS=0. ID1=59 C photon+Q ---> g+Q ID2=IQ1 IF (DISF(ID2,2).LT.EPS) GOTO 10 HCS=HCS+SIGE*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(13,ID2,1423,51) GOTO 99 ENDIF C photon+Qbar ---> g+Qbar 10 ID2=IQ2 IF (DISF(ID2,2).LT.EPS) GOTO 20 HCS=HCS+SIGE*DISF(ID2,2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(13,ID2,1342,52) GOTO 99 ENDIF 20 EVWGT=HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHPPH. *CMZ :- -12/01/93 10.12.43 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHPPH C----------------------------------------------------------------------- C Point-like photon/gluon heavy flavour pair production, with C exact lightcone massive kinematics, mean EVWGT = sigma in nb. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2, & EXY,EXY2,S,T,U,C INTEGER IQ1,IHAD1,IHAD2 EXTERNAL HWRUNI,HWUALF SAVE PP1,PP2,IQ1,QM2,FACTR PARAMETER (EPS=1.E-9) IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1)) PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2)) XX(1)=1. IQ1=MOD(IPROC,100) QM2=RMASS(IQ1)**2 IHPRO=53 FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2 ENDIF IF (GENEV) THEN C Generate event IDN(1)=59 IDN(2)=13 IDN(3)=IQ1 IDN(4)=IQ1+6 ICO(1)=1 ICO(2)=4 ICO(3)=2 ICO(4)=3 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) ELSE C Select kinematics EVWGT=0. CALL HWRPOW(ET,EJ) ET2=ET**2 EXY=EXP(HWRUNI(1,YJMIN,YJMAX)) EXY2=2.*PP1/ET-EXY IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2 IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN S=XX(2)*PP1*PP2 IF (S.LT.ET2) RETURN C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar) T=-.5*PP1*ET/EXY U=-S-T COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S)) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2) C photon+g ---> Q+Qbar IF (DISF(13,2).LT.EPS) THEN EVWGT=0. ELSE C=QM2*S/(U*T) EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA) & *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T) ENDIF ENDIF END CDECK ID>, HWHPPM. *CMZ :- -09/12/93 15.50.26 by Mike Seymour *-- Author : Ian Knowles & Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHPPM C----------------------------------------------------------------------- C Point-like photon/QCD direct meson production C See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details. C mean EVWGT = sigma in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2, & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX, & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3), 7 FRHO2,FPHI2(3),FOMEG2(3) INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2 LOGICAL SPIN0,SPIN1 EXTERNAL HWRGEN,HWRUNI,HWUALF SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT, & C1STU,C3STU PARAMETER (EPS=1.D-20) SAVE MNAME,N4,SPIN0,SPIN1,C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1 DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/ DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./ DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1 & /1.D0,3*0.093D0,3*0.107D0/ IF (FSTWGT) THEN FPI2=FPI**2 CMIX=COS(ETAMIX*PIFAC/180.D0) SMIX=SIN(ETAMIX*PIFAC/180.D0) FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE FETA2(2) =FETA2(1) FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE FETAP2(2)=FETAP2(1) FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE FRHO2=FRHO**2 CMIX=COS(PHIMIX*PIFAC/180.D0) SMIX=SIN(PHIMIX*PIFAC/180.D0) FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE FPHI2(2) =FPHI2(1) FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE FOMEG2(2)=FOMEG2(1) FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE ENDIF SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2) SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=ZERO IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1)) PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2)) XX(1)=ONE CALL HWRPOW(ET,EJ) EXY=EXP(HWRUNI(1,YJMIN,YJMAX)) EXY2=TWO*PP1/ET-EXY IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN XX(2)=PP1/(PP2*EXY*EXY2) IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN S=XX(2)*PP1*PP2 REDS=SQRT(S-ET*SQRT(S)) T=-HALF*PP1*ET/EXY U=-S-T COSTH=(T-U)/S C Set EMSCA to hard process scale (Approx ET-jet) EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U)) FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC & *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T) CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2) DO 10 I=1,3 DO 10 J=1,3 10 DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2 C1STU=-(S**2+U**2)/(T*S**2*U**2) C3STU=-8.D0*T/(S**2*U**2) ENDIF HCS=ZERO DO 50 I2=1,3 C Quark initiated processes ID2=I2 IF (DISF(ID2,2).LT.EPS) GOTO 30 DO 20 ID4=1,N4(I2) M1=MNAME(ID2,ID4,1) FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2) IF (ID2.EQ.ID4) FACTR=HALF*FACTR IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN C photon+q --> meson_0+q' HCS=HCS+HALF*FACTR*C1STU*FPI2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M1,ID4,1432,71) GOTO 99 ENDIF ENDIF M2=MNAME(ID2,ID4,2) IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN C photon+q --> meson_L+q' HCS=HCS+FACTR*C1STU*FRHO2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M2,ID4,1432,72) GOTO 99 ENDIF C photon+q --> meson_T+q' HCS=HCS+FACTR*C3STU*FRHO2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M2,ID4,1432,73) GOTO 99 ENDIF ENDIF 20 CONTINUE FACTR=FACT*DELT(I2,I2)*DISF(ID2,2) IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN C photon+q -->eta+q HCS=HCS+HALF*FACTR*C1STU*FETA2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(22,ID2,1432,71) GOTO 99 ENDIF ENDIF IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN C photon+q -->eta'+q HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(25,ID2,1432,71) GOTO 99 ENDIF ENDIF IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN C photon+q -->phi_L+q HCS=HCS+FACTR*C1STU*FPHI2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(56,ID2,1432,72) GOTO 99 ENDIF C photon+q -->phi_T+q HCS=HCS+FACTR*C3STU*FPHI2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(56,ID2,1432,73) GOTO 99 ENDIF ENDIF IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN C photon+q -->omega_L+q HCS=HCS+FACTR*C1STU*FOMEG2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(24,ID2,1432,72) GOTO 99 ENDIF C photon+q -->omega_T+q HCS=HCS+FACTR*C3STU*FOMEG2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(24,ID2,1432,73) GOTO 99 ENDIF ENDIF C Anti-quark initiated processes 30 ID2=I2+6 IF (DISF(ID2,2).LT.EPS) GOTO 50 DO 40 I4=1,N4(I2) ID4=I4+6 FACTR=FACT*DELT(I2,I4)*DISF(ID2,2) IF (ID2.EQ.ID4) FACTR=HALF*FACTR M1=MNAME(I4,I2,1) IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN C photon+qbar --> meson_0+qbar' HCS=HCS+HALF*FACTR*C1STU*FPI2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M1,ID4,1432,74) GOTO 99 ENDIF ENDIF M2=MNAME(I4,I2,2) IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN C photon+qbar --> meson_L+qbar' HCS=HCS+FACTR*C1STU*FRHO2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M2,ID4,1432,75) GOTO 99 ENDIF C photon+qbar --> meson_T+qbar' HCS=HCS+FACTR*C3STU*FRHO2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(M2,ID4,1432,76) GOTO 99 ENDIF ENDIF 40 CONTINUE FACTR=FACT*DELT(I2,I2)*DISF(ID2,2) IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN C photon+qbar -->eta+qbar HCS=HCS+HALF*FACTR*C1STU*FETA2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(22,ID2,1432,74) GOTO 99 ENDIF ENDIF IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN C photon+qbar -->eta'+qbar HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(25,ID2,1432,74) GOTO 99 ENDIF ENDIF IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN C photon+qbar -->phi_L+qbar HCS=HCS+FACTR*C1STU*FPHI2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(56,ID2,1432,75) GOTO 99 ENDIF C photon+qbar -->phi_T+qbar HCS=HCS+FACTR*C3STU*FPHI2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(56,ID2,1432,76) GOTO 99 ENDIF ENDIF IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN C photon+qbar -->omega_L+qbar HCS=HCS+FACTR*C1STU*FOMEG2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(24,ID2,1432,75) GOTO 99 ENDIF C photon+qbar -->omega_T+qbar HCS=HCS+FACTR*C3STU*FOMEG2(I2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(24,ID2,1432,76) GOTO 99 ENDIF ENDIF 50 CONTINUE EVWGT=HCS RETURN C Generate event 99 IDN(1)=59 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) C Set polarization vector IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN RHOHEP(2,NHEP-1)=ONE ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN RHOHEP(1,NHEP-1)=HALF RHOHEP(3,NHEP-1)=HALF ENDIF END CDECK ID>, HWHPPT. *CMZ :- -12/01/93 10.12.43 by Bryan Webber *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHPPT C----------------------------------------------------------------------- C point-like photon/QCD di-jet production: mean EVWGT = sigma in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ, & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2 EXTERNAL HWRGEN,HWRUNI,HWUALF SAVE CSTU,CTSU,HCS,FACTR,RS PARAMETER (EPS=1.E-9) IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1)) PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2)) XX(1)=1. CALL HWRPOW(ET,EJ) EXY=EXP(HWRUNI(1,YJMIN,YJMAX)) EXY2=2.*PP1/ET-EXY IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN XX(2)=PP1/(PP2*EXY*EXY2) IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN S=XX(2)*PP1*PP2 RS=.5*SQRT(S) T=-PP1*0.5*ET/EXY U=-S-T COSTH=(T-U)/S C Set EMSCA to hard process scale (Approx ET-jet) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM & *HWUALF(1,EMSCA)/(S*T) CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2) CSTU=U/T+T/U CTSU=-2.*CFFAC*(U/S+S/U) ENDIF HCS=0. ID1=59 DO 20 ID2=1,13 IF (DISF(ID2,2).LT.EPS) GOTO 20 IF (ID2.LT.7) THEN C photon+q ---> g+q HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13,ID2,1423,51) GOTO 99 ENDIF ELSEIF (ID2.LT.13) THEN C photon+qbar ---> g+qbar HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13,ID2,1342,52) GOTO 99 ENDIF ELSE C photon+g ---> q+qbar DO 10 ID3=1,6 IF (RS.GT.RMASS(ID3)) THEN ID4=ID3+6 HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,1423,53) GOTO 99 ENDIF ENDIF 10 CONTINUE ENDIF 20 CONTINUE EVWGT=FACTR*HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHPQS. *CMZ :- -27/03/95 13.27.22 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWHPQS C----------------------------------------------------------------------- C Compton scattering of point-like photon and (anti)quark C mean EVWGT = sigma in nb C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2, & FACTR,S,T,U,CTSU,HCS INTEGER ID1,ID2,IHAD1,IHAD2 EXTERNAL HWRGEN,HWRUNI SAVE CTSU,HCS,FACTR PARAMETER (EPS=1.E-9) IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1)) PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2)) XX(1)=1. CALL HWRPOW(ET,EJ) EXY=EXP(HWRUNI(1,YJMIN,YJMAX)) EXY2=2.*PP1/ET-EXY IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN XX(2)=PP1/(PP2*EXY*EXY2) IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN S=XX(2)*PP1*PP2 T=-PP1*0.5*ET/EXY U=-S-T COSTH=(T-U)/S C Set EMSCA to hard process scale (Approx ET-jet) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T) CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2) CTSU=-2.*(U/S+S/U) ENDIF HCS=0. ID1=59 DO 20 ID2=1,12 IF (DISF(ID2,2).LT.EPS) GOTO 20 IF (ID2.LT.7) THEN C photon+q ---> photon+q HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 59,ID2,1432,66) GOTO 99 ENDIF ELSE C photon+qbar ---> photon+qbar HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 59,ID2,1432,67) GOTO 99 ENDIF ENDIF 20 CONTINUE EVWGT=FACTR*HCS RETURN C Generate event 99 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHQCD. *CMZ :- -20/05/99 12.39.45 by Kosuke Odagiri *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHQCD C----------------------------------------------------------------------- C QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ, & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST, & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS, & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP INTEGER ID1,ID2,I EXTERNAL HWRGEN,HWRUNI,HWUALF SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS, & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US PARAMETER (EPS=1.E-9,HF=0.5) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK = ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) ) YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) ) YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=.5*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN COSTH=(Z1-Z2)/(Z1+Z2) S=XX(1)*XX(2)*PHEP(5,3)**2 RS=HF*SQRT(S) DO 3 I=1,NFLAV IF (RS.LT.RMASS(I)) GOTO 4 3 CONTINUE I=NFLAV+1 4 MAXFL=I-1 IF (MAXFL.EQ.0) THEN CALL HWWARN('HWHQCD',100) GOTO 999 ENDIF C T=-HF*S*(1.-COSTH) U=-S-T C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) CALL HWSGEN(.FALSE.) C ST=S/T TU=T/U US=U/S STU=TU/US TUS=US/ST UST=ST/TU C EN=CAFAC RN=CFFAC/EN GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2 AF=FACTR*RN ASTU=AF*(1.-2.*UST) ASUT=AF*(1.-2.*STU) AUST=AF*(1.-2.*TUS) C----------------------------------------------------------------------- C---Colour decomposition modifications below (KO) C----------------------------------------------------------------------- BF=HF-AF/EN/TUS/(ASTU+ASUT) BSTU=BF*ASTU BSUT=BF*ASUT BF=ONE-TWO*AF/EN/STU/(AUST+ASTU) BUST=BF*AUST BUTS=BF*ASTU C----------------------------------------------------------------------- C BF=2.*AF/EN C BSTU=HF*(ASTU+BF*ST) C BSUT=HF*(ASUT+BF/US) C BUST=AUST+BF*US C BUTS=ASTU+BF/TU C----------------------------------------------------------------------- CF=AF*EN CSTU=(CF*(RN-TUS))/TU CSUT=(CF*(RN-TUS))*TU CTSU=(FACTR*(UST-RN))*US CTUS=(FACTR*(UST-RN))/US DF=HF*FACTR/RN DSTU=DF*(1.+1./TUS-STU-UST) DTSU=DF*(1.+1./UST-STU-TUS) DUTS=DF*(1.+1./STU-UST-TUS) ENDIF C HCS=0. DO 6 ID1=1,13 IF (DISF(ID1,1).LT.EPS) GOTO 6 DO 5 ID2=1,13 IF (DISF(ID2,2).LT.EPS) GOTO 5 DIST=DISF(ID1,1)*DISF(ID2,2) IF (ID1.LT.7) THEN C---QUARK FIRST IF (ID2.LT.7) THEN IF (ID1.NE.ID2) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421, 3) GOTO 9 ENDIF ELSE HCS=HCS+BSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421, 1) GOTO 9 ENDIF HCS=HCS+BSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312, 2) GOTO 9 ENDIF ENDIF ELSEIF (ID2.NE.13) THEN IF (ID2.NE.ID1+6) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142, 9) GOTO 9 ENDIF ELSE HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(-ID1, 0,2413, 4) GOTO 9 ENDIF HCS=HCS+BUTS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142, 5) GOTO 9 ENDIF HCS=HCS+BUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413, 6) GOTO 9 ENDIF HCS=HCS+CSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 13,2413, 7) GOTO 9 ENDIF HCS=HCS+CSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 13,2341, 8) GOTO 9 ENDIF ENDIF ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142,10) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,11) GOTO 9 ENDIF ENDIF ELSEIF (ID1.NE.13) THEN C---QBAR FIRST IF (ID2.LT.7) THEN IF (ID1.NE.ID2+6) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,17) GOTO 9 ENDIF ELSE HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(-ID1, 0,3142,12) GOTO 9 ENDIF HCS=HCS+BUTS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,13) GOTO 9 ENDIF HCS=HCS+BUST*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142,14) GOTO 9 ENDIF HCS=HCS+CSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 13,3142,15) GOTO 9 ENDIF HCS=HCS+CSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 13, 13,4123,16) GOTO 9 ENDIF ENDIF ELSEIF (ID2.NE.13) THEN IF (ID1.NE.ID2) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,20) GOTO 9 ENDIF ELSE HCS=HCS+BSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,18) GOTO 9 ENDIF HCS=HCS+BSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,19) GOTO 9 ENDIF ENDIF ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,21) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,22) GOTO 9 ENDIF ENDIF ELSE C---GLUON FIRST IF (ID2.LT.7) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,23) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,24) GOTO 9 ENDIF ELSEIF (ID2.LT.13) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3142,25) GOTO 9 ENDIF HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,4312,26) GOTO 9 ENDIF ELSE HCS=HCS+GFLA*CSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 0, 0,2413,27) GOTO 9 ENDIF HCS=HCS+GFLA*CSUT*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP( 0, 0,4123,28) GOTO 9 ENDIF HCS=HCS+DTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2341,29) GOTO 9 ENDIF HCS=HCS+DSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3421,30) GOTO 9 ENDIF HCS=HCS+DUTS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,2413,31) GOTO 9 ENDIF ENDIF ENDIF 5 CONTINUE 6 CONTINUE EVWGT=HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR. & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN C qqbar-->gg or qbarq-->gg UT=1./TU GCOEF(1)=UT+TU GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=UT-TU GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR. & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR. & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR. & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar SU=1./US GCOEF(1)=-(SU+US) GCOEF(2)=0. GCOEF(3)=2. GCOEF(4)=0. GCOEF(5)=SU-US GCOEF(6)=GCOEF(1) GCOEF(7)=-GCOEF(5) ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN C gg-->qqbar UT=1./TU GCOEF(1)=TU+UT GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=TU-UT GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR. & IHPRO.EQ.31) THEN C gg-->gg GT=S*S+T*T+U*U GCOEF(2)=2.*U*U*T*T GCOEF(3)=2.*S*S*U*U GCOEF(4)=2.*S*S*T*T GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4) GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2) GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3) GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4) ELSE CALL HWVZRO(7,GCOEF) ENDIF ENDIF 999 RETURN END CDECK ID>, HWHQCP. *CMZ :- -26/04/91 10.18.57 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR) C----------------------------------------------------------------------- C IDENTIFIES HARD SUBPROCESS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3 EXTERNAL HWRINT IHPRO=IHPR IF (ID3.GT.0) THEN IDN(3)=ID3 IDN(4)=ID4 ELSE ND3=-ID3 IF (ID3.GT.-7) THEN 1 IDN(3)=HWRINT(1,MAXFL) IF (IDN(3).EQ.ND3) GOTO 1 IDN(4)=IDN(3)+6 ELSE 2 IDN(3)=HWRINT(1,MAXFL)+6 IF (IDN(3).EQ.ND3) GOTO 2 IDN(4)=IDN(3)-6 ENDIF ENDIF ICO(1)=IPERM/1000 ICO(2)=IPERM/100-10*ICO(1) ICO(3)=IPERM/10 -10*(IPERM/100) ICO(4)=IPERM -10*(IPERM/10) END CDECK ID>, HWHQPM. *CMZ :- -27/07/95 14.13.56 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHQPM C HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W- C MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC, $ HWRGEN INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2 SAVE HCS,FACTR,HQ,RS IHAD1=1 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1) IHAD2=2 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. RS=PHEP(5,3) S=RS**2 HQ=MOD(IPROC,100) IF (HQ.EQ.0) THEN EMSQ=0 BE=1 CFAC=3 ELSE IF (HQ.GT.6) HQ=2*HQ+107 IF (HQ.EQ.127) HQ=198 EMSQ=RMASS(HQ)**2 BE=1-4*EMSQ/S IF (BE.LT.ZERO) RETURN BE=SQRT(BE) CFAC=1 IF (HQ.LE.6) CFAC=3 ENDIF TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO))) TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO))) IF (TMIN.GE.TMAX) RETURN T=-(TMAX/TMIN)**HWRGEN(1)*TMIN IF (HWRGEN(2).GT.HALF) T=-S-T U=-S-T COSTH=(T-U)/(BE*S) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) IF (HQ.NE.198) THEN FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U) $ *2*PIFAC*CFAC*ALPHEM**2/S**2 $ *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2) ELSE FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U) $ *6*PIFAC*CFAC*ALPHEM**2/S**2 $ *(1-S/(T*U)*(4D0/3*S+2*EMSQ) $ +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2)) ENDIF ENDIF HCS=0. XX(1)=1. XX(2)=1. IF (HQ.EQ.0) THEN I1=1 I2=6 ELSE I1=HQ I2=HQ ENDIF DO 10 ID3=I1,I2 IF (RS.GT.2*RMASS(ID3)) THEN Q=ICHRG(ID3) IF (HQ.LE.6) Q=Q/THREE ID4=ID3+6 IF (HQ.EQ.198) ID4=199 HCS=HCS+Q**4 IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID3,ID4,1243,61) GOTO 99 ENDIF ENDIF 10 CONTINUE EVWGT=FACTR*HCS RETURN 99 IDN(1)=59 IDN(2)=59 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHRBB. *CMZ :- -20/10/99 09:46:43 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRBB C----------------------------------------------------------------------- C Subroutine for 2 parton -> 2 parton via UDD resonant squarks C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB, & SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12), & ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA, & CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3), & XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12) INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT, & GENR,GN,MIG,MXG,GEN LOGICAL FIRST EXTERNAL HWRGEN,HWRUNI PARAMETER(EPS=1D-20) COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD SAVE CONECT DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/ IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IF(FSTWGT) THEN C--Extract masses and width's needed DO I=1,3 MS(2*I-1) = RMASS(399+2*I) MS(2*I) = RMASS(411+2*I) MS(2*I+5) = RMASS(400+2*I) MS(2*I+6) = RMASS(412+2*I) SWD(2*I-1) = HBAR/RLTIM(399+2*I) SWD(2*I) = HBAR/RLTIM(411+2*I) SWD(2*I+5) = HBAR/RLTIM(400+2*I) SWD(2*I+6) = HBAR/RLTIM(412+2*I) ENDDO DO I=1,12 MS2(I) = MS(I)**2 MSWD(I) = MS(I)*SWD(I) ENDDO C--Now set up the parmaters for multichannel integration RAND = ZERO DO K=1,3 CHANPB(1) = ZERO CHANPB(2) = ZERO DO I=1,3 DO J=1,3 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2 ENDDO ENDDO RAND=RAND+CHANPB(1)+CHANPB(2) DO J=1,2 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2 MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2 MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2 ENDDO ENDDO IF(RAND.GT.ZERO) THEN DO I=1,12 CHAN(I)=CHAN(I)/RAND ENDDO ELSE HCS =ZERO CALL HWWARN('HWHRBB',500) ENDIF C--find the couplings DO GN=1,3 DO I=1,3 DO J=1,3 DO K=1,3 DO L=1,3 LAM(GN,I,J,K,L) =LAMDA3(I,J,GN)*LAMDA3(K,L,GN) LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L) ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF EVWGT = ZERO S = PHEP(5,3)**2 COSTH = HWRUNI(0,-ONE,ONE) C--Generate the smoothing RAND=HWRUNI(0,ZERO,ONE) DO I=1,12 IF(CHAN(I).GT.RAND) GOTO 20 RAND=RAND-CHAN(I) ENDDO 20 GENR=I C--Calculate hard scale and obtain parton distributions TAUA = MS2(GENR)/S TAUB = SWD(GENR)**2/S RTAB = SQRT(TAUA*TAUB) XUPP = XMAX IF(XMAX**2.GT.S) XUPP = SQRT(S) LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB TAU = HWRUNI(0,LOWTLM,UPPTLM) TAU = RTAB*TAN(RTAB*TAU)+TAUA SH = S*TAU SQSH = SQRT(SH) EMSCA = SQSH XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU))) XX(2) = TAU/XX(1) CALL HWSGEN(.FALSE.) C--Calculate the prefactor due multichannel approach FAC = ZERO DO GN=1,12 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2) FAC=FAC+CHAN(GN)*SCF(GN) ENDDO FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB & /(24*PIFAC*SQSH*SH*TAU*FAC*S**2) ENDIF C--loop over the quarks HCS = ZERO DO GN=1,2 IF(GN.EQ.1) THEN MIG = 1 MXG = 6 ELSE MIG = 7 MXG = 12 ENDIF DO K1=1,3 DO 70 L1=1,3 IF(GN.EQ.1) THEN K = 2*K1 L = 2*L1-1 ELSE K=2*K1-1 L=2*L1-1 IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70 ENDIF MQ1=RMASS(K) MQ2=RMASS(L) IF(SQSH.GT.(MQ1+MQ2)) THEN PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH)) WD = SH*(SH-MQ1**2-MQ2**2)*PCM ELSE GOTO 70 ENDIF DO I1=1,3 DO 60 J1=1,3 IF(GN.EQ.1) THEN I = 2*I1 J = 2*J1-1 ELSE I=2*I1-1 J=2*J1-1 IF(J1.GT.I1) GOTO 60 ENDIF IF(GENEV) GOTO 50 MATELM = ZERO DO 40 GEN=MIG,MXG IF(ABS(MIX(GEN)).LT.EPS.OR. & ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40 DO 30 GENR=MIG,MXG IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS. & OR.ABS(MIX(GENR)).LT.EPS) GOTO 30 MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD* & ((SH-MS2(GEN))*(SH-MS2(GENR))+ & MSWD(GEN)*MSWD(GENR)) & *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN) & *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR) 30 CONTINUE 40 CONTINUE ME(GN,I1,J1,K1,L1) = MATELM*FAC C--Add up the term to get the cross-section 50 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(1,I,J,K,L,0,0) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(2,J,I,K,L,0,0) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(1,I,J,K,L,1,0) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(2,J,I,K,L,1,0) GOTO 100 ENDIF 60 CONTINUE ENDDO 70 CONTINUE ENDDO ENDDO 100 IF(GENEV) THEN CALL HWETWO(.TRUE.,.TRUE.) C--first stage of the colour connection corrections DO THEP=1,5 IF(THEP.NE.3) THEN JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP) JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5) ENDIF ENDDO THEP = NHEP-4 IF(HWRINT(1,2).EQ.1) THEN HRDCOL(2,1) = THEP+3 HRDCOL(2,2) = THEP+4 HRDCOL(1,4) = THEP HRDCOL(1,5) = THEP+1 ELSE HRDCOL(2,1) = THEP+4 HRDCOL(2,2) = THEP+3 HRDCOL(1,4) = THEP+1 HRDCOL(1,5) = THEP ENDIF DO N=1,5 IF(N.LE.2) THEN HRDCOL(1,N)=HRDCOL(2,N) ELSEIF(N.GE.4) THEN HRDCOL(2,N)=HRDCOL(1,N) ENDIF ENDDO HRDCOL(1,3) = 4 COLUPD = .TRUE. ELSE EVWGT = HCS ENDIF END CDECK ID>, HWHRBS. *CMZ :- -20/10/99 09:46:43 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRBS C----------------------------------------------------------------------- C Subroutine for 2 parton -> parton SUSY particle via UDD resonant C squarks. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA, & TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2, & LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3), & MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF, & MQ,MN,MQS,TH,UH,FAC,MX(14),CHAN(12),MC(2), & MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP, & MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2), & ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12) INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2, & CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX, & CM,CN LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS, & CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH, & AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD,GUU,GDD PARAMETER(EPS=1D-20) SAVE CONECT DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4, & 3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3, & 1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1, & 1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0, & 1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/ IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IF(FSTWGT) THEN C--Extract masses and width's needed DO I=1,3 MS(2*I-1) = RMASS(399+2*I) MS(2*I) = RMASS(411+2*I) MS(2*I+5) = RMASS(400+2*I) MS(2*I+6) = RMASS(412+2*I) SWD(2*I-1) = HBAR/RLTIM(399+2*I) SWD(2*I) = HBAR/RLTIM(411+2*I) SWD(2*I+5) = HBAR/RLTIM(400+2*I) SWD(2*I+6) = HBAR/RLTIM(412+2*I) ENDDO DO I=1,12 MS2(I) = MS(I)**2 MSWD(I) = MS(I)*SWD(I) ENDDO C--Electroweak parameters SW = SQRT(SWEIN) CW = SQRT(1-SWEIN) MW = RMASS(198) MZ = RMASS(200) MW2 = MW**2 MZ2 = MZ**2 C--Now set up the parmaters for multichannel integration RAND = ZERO DO K=1,3 CHANPB(1) = ZERO CHANPB(2) = ZERO DO I=1,3 DO J=1,3 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2 ENDDO ENDDO RAND=RAND+CHANPB(1)+CHANPB(2) DO J=1,2 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2 MX(2*K-2+J) = QMIXSS(2*K-1,2,J) MX(2*K+4+J) = QMIXSS(2*K,2,J) ENDDO MX(13) = ZERO MX(14) = ZERO ENDDO IF(RAND.GT.ZERO) THEN DO I=1,12 CHAN(I)=CHAN(I)/RAND ENDDO ELSE CALL HWWARN('HWHRBS',500) ENDIF C--Couplings we need for the various processes C--Gluino DO I=1,3 DO J=1,2 A(1,2*I-2+J) = QMIXSS(2*I-1,2,J) B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J) A(1,2*I+4+J) = QMIXSS(2*I,2,J) B(1,2*I+4+J) = -QMIXSS(2*I,1,J) ENDDO ENDDO C--Now the neutralinos DO L=1,4 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW) MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW) DO I=1,3 DO J=1,2 A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)* & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J)) B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)* & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J) A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)* & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J)) B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)* & RMASS(2*I)+SLFCH(2*I, L)*QMIXSS(2*I,1,J) ENDDO ENDDO ENDDO C--Now for the charginos DO L=1,2 MC(1) = 1/(SQRT(2.0D0)*MW*COSB) MC(2) = 1/(SQRT(2.0D0)*MW*SINB) DO I=1,3 DO J=1,2 A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)* & RMASS(2*I)*QMIXSS(2*I-1,1,J) B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J) & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J) A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1) & *QMIXSS(2*I,1,J) B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J) & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J)) ENDDO ENDDO ENDDO C--Zero couplings DO I=1,7 A(I,13) = ZERO B(I,13) = ZERO A(I,14) = ZERO B(I,14) = ZERO ENDDO C--Couplings to the Z boson of squarks and right-handed quarks ZQRK(1) = -SW**2/6.0D0/CW ZQRK(2) = SW**2/3.0D0/CW ZSQU(1,1) = HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW ZSQU(1,2) = HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW C--Higgs Masses DO I=1,4 MH(I) = RMASS(202+I) ENDDO C--Higgs couplings to quarks DO I=1,3 GUU(I) = GHUUSS(I)**2*HALF**2/MW2 GDD(I) = GHDDSS(I)**2*HALF**2/MW2 ENDDO GUU(4) = ONE/TANB**2/MW2/8.0D0 GDD(4) = ONE*TANB**2/MW2/8.0D0 C--decide which processes to generate from IPROC RAD = .FALSE. NEUT = .FALSE. CHAR = .FALSE. HIGGS = .FALSE. SPMN = 1 SPMX = 5 CHARMN = 1 CHARMX = 2 IF(MOD(IPROC,10000).EQ.4100) THEN RAD = .TRUE. NEUT = .TRUE. CHAR = .TRUE. HIGGS = .TRUE. ELSEIF(MOD(IPROC,10000).LT.4120) THEN SPMN = 2 IF(MOD(IPROC,10000).NE.4110) THEN SPMN = MOD(IPROC,10)+1 SPMX = SPMN ENDIF NEUT=.TRUE. ELSEIF(MOD(IPROC,10000).LT.4130) THEN IF(MOD(IPROC,10000).NE.4120) THEN CHARMN = MOD(IPROC,10) CHARMX=CHARMN ENDIF CHAR = .TRUE. ELSEIF(MOD(IPROC,10000).EQ.4130) THEN SPMX = 1 NEUT=.TRUE. ELSEIF(MOD(IPROC,10000).EQ.4140) THEN RAD = .TRUE. ELSEIF(MOD(IPROC,10000).EQ.4150) THEN HIGGS = .TRUE. ELSE CALL HWWARN('HWHRBS',501) ENDIF ENDIF EVWGT = ZERO S = PHEP(5,3)**2 COSTH = HWRUNI(0,-ONE,ONE) C--zero the array DO I=1,6 DO J=1,3 DO K=1,3 DO L=1,7 MEN(L,I,J,K)=ZERO ENDDO DO L=1,2 MEC(L,I,J,K)=ZERO ENDDO ENDDO ENDDO ENDDO C--Multichannel peak RAND=HWRUNI(0,ZERO,ONE) DO I=1,12 IF(CHAN(I).GT.RAND) GOTO 25 RAND=RAND-CHAN(I) ENDDO 25 GENR=I C--Calculate the hard scale and obtain parton distributions TAUA = MS2(GENR)/S TAUB = SWD(GENR)**2/S RTAB = SQRT(TAUA*TAUB) XUPP = XMAX IF(XMAX**2.GT.S) XUPP = SQRT(S) LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB TAU = HWRUNI(0,LOWTLM,UPPTLM) TAU = RTAB*TAN(RTAB*TAU)+TAUA SH = S*TAU SQSH = SQRT(SH) EMSCA = SQSH XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU))) XX(2) = TAU/XX(1) CALL HWSGEN(.FALSE.) C--Strong, EM coupling and weak couplings AS = HWUALF(1,EMSCA) EC = SQRT(4*PIFAC*HWUAEM(SH)) G = EC/SW C--Calculate the prefactor due multichannel approach FAC = ZERO DO GN=1,12 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2) FAC=FAC+CHAN(GN)*SCF(GN) ENDDO FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB & /(48*PIFAC*SQSH*SH*TAU*FAC*S**2) ENDIF HCS = ZERO IF(.NOT.NEUT) GOTO 200 DO 140 GN=1,6 GR=2*GN IF(CHAN(GR).LT.EPS) GOTO 140 DO 130 L=SPMN,SPMX K = 2*GN+5 IF(GN.GT.3) K = 2*GN MQ = RMASS(K) MN = ABS(RMASS(448+L)) MQS = MQ**2 MNS = MN**2 IF(SQSH.LT.(MQ+MN)) GOTO 130 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH)) ECM=SQRT(PCM**2+MQS) TH = MQS-SQSH*(ECM-PCM*COSTH) UH = MQS-SQSH*(ECM+PCM*COSTH) DO I=1,3 DO 120 J=1,3 IF(GN.LE.3) THEN GU = 6+2*I I1 = 2*I LAMC(1) = LAMDA3(I,J,GN)**2 ELSE GU = 2*I I1 = 2*I-1 LAMC(1) = LAMDA3(GN-3,I,J)**2 IF(J.GT.I) LAMC(1) = ZERO ENDIF GT = 2*J J1 = 2*J-1 C--Now the matrix elements IF(LAMC(1).LT.EPS) GOTO 120 IF(GENEV) GOTO 110 C--S channel ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+ & B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR)) ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU) & /(TH-MS2(GT))/(UH-MS2(GU)) & +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH* & A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU)) & +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH* & A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT)) C--L/R s channel and interference IF(ABS(MX(GR-1)).GT.EPS) THEN ME(3) = ME(3)+ & MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2 & +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1)) & +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH* & ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))* & ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1) & +B(L,GR)*B(L,GR-1)) & -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR))) ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1)) & *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN) & /(UH-MS2(GU)) & +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH* & A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT)) IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)* & MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*( & A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1)) IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)* & MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH* & (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1)) ENDIF C--u channel and L/R mixing ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)* & (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2 IF(ABS(MX(GU-1)).GT.EPS) THEN ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)* & (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2 & +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)* & (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1)) & /(UH-MS2(GU))/(UH-MS2(GU-1)) ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))* & SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN) & /(UH-MS2(GU-1)) & -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)* & A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1)) IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1) & *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1) & /(TH-MS2(GT-1))/(UH-MS2(GU-1)) ENDIF C--t channel and t channel L/R mixing ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)* & (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2 IF(ABS(MX(GT-1)).GT.EPS) THEN ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)* & (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2 & +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)* & A(L,GT-1)+ B(L,GT)*B(L,GT-1)) & /(TH-MS2(GT))/(TH-MS2(GT-1)) ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)* & A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU)) & +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)* & A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN) & /(TH-MS2(GT-1)) ENDIF C--Angular ordering and the phase space factors IF(L.EQ.1) THEN ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3)) LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE DO GEN=1,3 MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4)) ENDDO ELSE LAMC(1) = TWO*LAMC(1)*EC**2 MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4)) ENDIF C--Multiply by the pdf's 110 IF(L.EQ.1) THEN CM = 1 CN = 3 ELSE CM = L+2 CN = L+2 ENDIF DO GEN=CM,CN CON = 4 IF(GEN.LE.3) CON = GEN HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(3,I1,J1,K,GEN,0,0) GOTO 900 ENDIF HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(4,J1,I1,K,GEN,0,0) GOTO 900 ENDIF HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(3,I1,J1,K,GEN,1,0) GOTO 900 ENDIF HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(4,J1,I1,K,GEN,1,0) GOTO 900 ENDIF ENDDO 120 CONTINUE ENDDO 130 CONTINUE 140 CONTINUE C--Now the chargino processes if wanted 200 IF(.NOT.CHAR) GOTO 300 DO 240 GN=1,6 GR=2*GN IF(CHAN(GR).LT.EPS) GOTO 240 DO 230 L=CHARMN,CHARMX SP =5+L K = 2*GN+6 IF(GN.GT.3) K = 2*GN-1 MQ = RMASS(K) MN = ABS(RMASS(453+L)) MQS = MQ**2 MNS = MN**2 IF(SQSH.LT.(MQ+MN)) GOTO 230 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH)) ECM=SQRT(PCM**2+MQS) TH = MQS-SQSH*(ECM-PCM*COSTH) UH = MQS-SQSH*(ECM+PCM*COSTH) DO I=1,3 DO 220 J=1,3 IF(GN.LE.3) THEN GU = 2*I GT = 14 I1 = 2*I LAMC(1) = LAMDA3(I,J,GN) LAMC(2) = LAMDA3(GN,I,J) LAMC(3) = ZERO ELSE GU = 6+2*I GT = 6+2*J I1 = 2*I-1 LAMC(1) = LAMDA3(GN-3,I,J) LAMC(2) = LAMDA3(I,J,GN-3) LAMC(3) = LAMDA3(J,GN-3,I) IF(J.GT.I) LAMC(1) = ZERO ENDIF J1 = 2*J-1 IF(ABS(LAMC(1)).LT.EPS) GOTO 220 IF(GENEV) GOTO 210 C--Matrix element C--S channel ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)* & (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR)) IF(ABS(MX(GU)).GT.EPS) THEN ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)* & (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2 & +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)* & (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH* & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU)) IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)* & TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)* & A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU)) ENDIF IF(ABS(MX(GT)).GT.EPS) THEN ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)* & (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2 & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)* & (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH* & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT)) ENDIF c--L/R s channel and interference IF(ABS(MX(GR-1)).GT.EPS) THEN ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH* & ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2) & -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1)) & +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)* & SCF(GR-1)*SH* & ((SH-MS2(GR))*(SH-MS2(GR-1))+ & MSWD(GR)*MSWD(GR-1))* & ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+ & B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN* & (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR))) IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)* & TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)* & A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN) & /(UH-MS2(GU)) IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)* & TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)* & A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN) & /(TH-MS2(GT)) IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)* & TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))* & SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+ & B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1)) IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)* & TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))* & SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+ & B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1)) ENDIF C--u channel and L/R mixing IF(ABS(MX(GU-1)).GT.EPS) THEN ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)* & (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2 & +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)* & (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1)) & /(UH-MS2(GU))/(UH-MS2(GU-1)) & +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)* & (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH* & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1)) IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO* & MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1) & /(TH-MS2(GT))/(UH-MS2(GU-1)) IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)* & TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)* & A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1)) ENDIF C--t channel and t channel L/R mixing IF(ABS(MX(GT-1)).GT.EPS) THEN ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)* & (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2 & +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)* & (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1)) & /(TH-MS2(GT))/(TH-MS2(GT-1)) & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)* & (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH* & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1)) IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO* & MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU) & /(TH-MS2(GT-1))/(UH-MS2(GU)) ENDIF c--phase space factors MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM 210 CON = 4 I2 = SP+2 IF(MOD(K,2).EQ.1) I2 =I2+2 HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(3,I1,J1,K,I2,0,0) GOTO 900 ENDIF HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(4,J1,I1,K,I2,0,0) GOTO 900 ENDIF HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(3,I1,J1,K,I2+2,1,0) GOTO 900 ENDIF HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(4,J1,I1,K,I2+2,1,0) GOTO 900 ENDIF 220 CONTINUE ENDDO 230 CONTINUE 240 CONTINUE C--Now the radiative decays, if possible 300 IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400 IF(GENEV) GOTO 320 DO 310 I=1,6 310 MER(I)=ZERO C--stop to light stop and Z IF(SH.GT.(MZ+MS(11))**2) THEN PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH ECM=SQRT(PCM**2+MZ2) TH = MZ2-SQSH*(ECM-PCM*COSTH) UH = MZ2-SQSH*(ECM+PCM*COSTH) MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2 & +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2 & +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)* & ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))* & (SH-MS2(12))+MSWD(11)*MSWD(12))) & +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*( & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH) & +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*( & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH) & +ZQRK(1)*SH*QMIXSS(6,2,1)* & (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11) & +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12)) & *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH & +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH) & -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2* & (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH) MER(3) = MER(3)*FOUR*PCM/MZ2 ENDIF C--sbottom to light sbottom and Z IF(SH.GT.(MZ+MS(5))**2) THEN PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH ECM=SQRT(PCM**2+MZ2) TH = MZ2-SQSH*(ECM-PCM*COSTH) UH = MZ2-SQSH*(ECM+PCM*COSTH) MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2 & +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2 & +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)* & ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))* & (SH-MS2(6))+MSWD(5)*MSWD(6))) & +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2* & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH) & +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2* & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH) & +QMIXSS(5,2,1)*SH* & (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5) & +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))* & (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH) & +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH)) & -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH* & (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH) MER(6) = MER(6)*FOUR*PCM/MZ2 ENDIF C--stop to sbottom and W DO J=1,2 IF(SH.GT.(MW+MS(4+J))**2) THEN PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH C--diagram square pieces DO I=1,2 MER(J)=MER(J)+SCF(10+I)* & (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2 ENDDO C--light/heavy interference MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)* & ((SH-MS2(11))*(SH-MS2(12)) & +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2* & QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2)) ENDIF C--sbottom to stop and W IF(SH.GT.(MW+MS(10+J))**2) THEN PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH C--diagram square pieces DO I=1,2 MER(J+3)=MER(J+3)+SCF(4+I)* & (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2 ENDDO C--light/heavy interference MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)* & ((SH-MS2(5))*(SH-MS2(6))+ & MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2* & QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2)) ENDIF ENDDO C--Now multiply by the parton distributions and phase space factors 320 DO J=1,3 DO K=1,3 CON = 5 C--resonant stop's IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN FAC2 = LAMDA3(3,J,K)**2*FAC*G**2 DO I=1,3 I1=2*J-1 J1=2*K-1 ME2 = MER(I)*FAC2 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(5,I1,J1,I,I,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(6,J1,I1,I,I,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(5,I1,J1,I,I,1,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(6,J1,I1,I,I,1,0) GOTO 900 ENDIF ENDDO ENDIF C--resonant sbottom's IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN FAC2 = LAMDA3(J,K,3)**2*FAC*G**2 DO I=4,6 I1=2*J J1=2*K-1 ME2 = MER(I)*FAC2 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(5,I1,J1,I,I,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(6,J1,I1,I,I,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(5,I1,J1,I,I,1,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(6,J1,I1,I,I,1,0) GOTO 900 ENDIF ENDDO ENDIF ENDDO ENDDO C--Now the Higgs decays if possible 400 IF(.NOT.HIGGS) GOTO 900 IF(GENEV) GOTO 490 DO I=1,3 DO 405 J=1,42 405 MEH(I,J) = ZERO ENDDO DO I=1,3 DO 420 J=1,3 C--Neutral Higgs down type squark IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410 PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)* & (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH ECM=SQRT(PCM**2+MH(J)**2) TH = MH(J)**2-SQSH*(ECM-PCM*COSTH) UH = MH(J)**2-SQSH*(ECM+PCM*COSTH) MEH(1,3*I-3+J) = PCM*SH*( & QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2 & +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2 & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1) & *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)* & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I))) MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2* & (TH*UH-MH(J)**2*MS2(2*I-1)) MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2* & (TH*UH-MH(J)**2*MS2(2*I-1)) C--Neutral Higgs up type squarks 410 IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420 PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)* & (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH ECM=SQRT(PCM**2+MH(J)**2) TH = MH(J)**2-SQSH*(ECM-PCM*COSTH) UH = MH(J)**2-SQSH*(ECM+PCM*COSTH) MEH(1,3*I+6+J) = PCM*SH*( & QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2 & +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2 & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5) & *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)* & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+ & MSWD(2*I+5)*MSWD(2*I+6))) MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2* & (TH*UH-MH(J)**2*MS2(2*I+5)) MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2* & (TH*UH-MH(J)**2*MS2(2*I+5)) 420 CONTINUE C--Charged Higgs up type squark DO 440 J=1,2 IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430 PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)* & (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH ECM=SQRT(PCM**2+MH(4)**2) TH = MH(4)**2-SQSH*(ECM-PCM*COSTH) UH = MH(4)**2-SQSH*(ECM+PCM*COSTH) MEH(1,4*I+14+J) = PCM*SH*( & QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1) & +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I) & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1) & *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)* & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+ & MSWD(2*I-1)*MSWD(2*I))) MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2* & (UH*TH-MS2(2*I+4+J)*MH(4)**2) C--Charged Higgs down type squark 430 IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440 PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)* & (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH ECM=SQRT(PCM**2+MH(4)**2) TH = MH(4)**2-SQSH*(ECM-PCM*COSTH) UH = MH(4)**2-SQSH*(ECM+PCM*COSTH) MEH(1,4*I+16+J) = PCM*SH*( & QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5) & +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6) & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5) & *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)* & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+ & MSWD(2*I+5)*MSWD(2*I+6))) MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2* & (UH*TH-MS2(2*I-2+J)*MH(4)**2) MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2* & (UH*TH-MS2(2*I-2+J)*MH(4)**2) 440 CONTINUE ENDDO 490 DO I=1,3 DO J=1,3 DO K=1,3 CON = 5 DO L=1,3 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN C--neutral higgs and sdown FAC2 = FAC*G**2*LAMDA3(J,K,I)**2 I1=2*J J1=2*K-1 ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L) & +RMASS(J1)**2*MEH(3,3*I-3+L)) HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,L,2*I-1,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,L,2*I-1,0,0) GOTO 900 ENDIF IF(I2.NE.200) I2=198 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,L,2*I-1,1,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,L,2*I-1,1,0) GOTO 900 ENDIF ENDIF IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN FAC2 = FAC*G**2*LAMDA3(I,J,K)**2 C--neutral higgs and sup I1=2*J-1 J1=2*K-1 ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L) & +RMASS(J1)**2*MEH(3,3*I+6+L)) HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,L,2*I+5,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,L,2*I+5,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,L,2*I+5,1,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,L,2*I+5,1,0) GOTO 900 ENDIF ENDIF ENDDO DO L=1,2 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN C--charged higgs and sup I1=2*J J1=2*K-1 FAC2 = FAC*G**2 ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14) & +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14)) HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0) GOTO 900 ENDIF HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0) GOTO 900 ENDIF HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0) GOTO 900 ENDIF HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0) GOTO 900 ENDIF ENDIF C--charged higgs and sdown IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN I1=2*J-1 J1=2*K-1 FAC2 = FAC*G**2 ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2 & +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16) & +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16)) HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0) GOTO 900 ENDIF HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0) GOTO 900 ENDIF ENDIF ENDDO ENDDO ENDDO ENDDO C--calculate of the matrix elements 900 IF(GENEV) THEN CALL HWETWO(.TRUE.,.TRUE.) IF(IERROR.NE.0) RETURN HVFCEN = .TRUE. C--first stage of the colour connection corrections DO THEP=1,5 IF(THEP.NE.3) THEN JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP & +CONECT(HWRINT(1,2),THEP,CON) JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5) ENDIF ENDDO IF(IDHEP(NHEP-4).LT.0) THEN JDAHEP(2,NHEP-4)=NHEP-1 JDAHEP(2,NHEP-3)=NHEP-3 JDAHEP(2,NHEP-1)=NHEP-4 IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP ELSE JMOHEP(2,NHEP-4)=NHEP-1 JMOHEP(2,NHEP-3)=NHEP-3 JMOHEP(2,NHEP-1)=NHEP-4 IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP ENDIF IF(CON.EQ.5) THEN SP=JDAHEP(2,NHEP) JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1) JDAHEP(2,NHEP-1) = SP SP=JMOHEP(2,NHEP) JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1) JMOHEP(2,NHEP-1) = SP ENDIF HRDCOL(1,1) = NHEP HRDCOL(1,2) = NHEP-2 ELSE EVWGT = HCS ENDIF END CDECK ID>, HWHREE. *CMZ :- -05/04/02 15:40:41 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHREE C----------------------------------------------------------------------- C SUSY E+E- --> SM PARTICLES VIA RPV C MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA, & S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ, & MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN, & MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3) DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ, & SCF(3) INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2) SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID, & FID EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0)) C--Start of the code IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IF(FSTWGT) THEN C--identify the beam particles IF(ABS(IDHEP(1)).EQ.11) THEN C--electron beams RSID(1) = 2 IL = 1 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN C--muon beams RSID(1) = 1 IL = 2 C--unrecognized beam particles issue warning ELSE CALL HWWARN('HWHREE',500) ENDIF RSID(2) = 3 C--masses of the sleptons DO I=1,3 MSL2(I) = RMASS(424+2*I) MWD(I) = MSL2(I)*HBAR/RLTIM(424+2*I) MSL2(I) = MSL2(I)**2 ENDDO C--masses and mixings of the t channel squarks DO I=1,3 MSU2(I,1) = RMASS(400+2*I) MSU2(I,2) = RMASS(412+2*I) DO J=1,2 MIX(I,J) = QMIXSS(2*I,1,J)**2 MSU2(I,J) = MSU2(I,J)**2 ENDDO ENDDO C--Z mass MZ = RMASS(200) MZ2 = MZ**2 C--find the couplings DO GN=1,3 DO I=1,3 DO J=1,3 DO K=1,3 DO L=1,3 LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L) LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L) LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L) LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L) ENDDO ENDDO ENDDO ENDDO ENDDO C--Z couplings GL = LFCH(11) GR = RFCH(11) C--select the process from the IPROC code IF(IPROC.EQ.860) THEN GNMN = 1 GNMX = 2 FID(1) = 0 FID(2) = 0 ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN J = MOD(IPROC,10) IF(MOD(IPROC,10).EQ.0) THEN FID(1) = 0 FID(2) = 0 ELSE FID(1) = MOD(J-1,3)+1 FID(2) = INT((J-1)/3)+1 ENDIF IF(IPROC.LT.880) THEN GNMN = 1 ELSE GNMN = 2 ENDIF GNMX = GNMN ELSE CALL HWWARN('HWHREE',501) ENDIF ENDIF C--calculate the kinematic varibles EVWGT = ZERO S = PHEP(5,3)**2 THTMIN = ONE-FOUR*PTMIN**2/S IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502) THTMIN = SQRT(THTMIN) COSTH = HWRUNI(0,-THTMIN,THTMIN) EMSCA = PHEP(5,3) GZ = ONE/(S-MZ**2+Z*MZ*GAMZ) EE = HWUAEM(S) FACA = GEV2NB*EE**2*PIFAC*S/FOUR EE = 0.25D0/EE/PIFAC SP = ONE/S T = -HALF*S*(ONE-COSTH) TP = ONE/T TPZ = ONE/(T-MZ2) C--Calculate the prefactor due multichannel approach DO GN=1,3 IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN)) ELSE SCF(GN) = Z0 ENDIF ENDDO ENDIF C--Now the loop to actually calculate the cross sections HCS = ZERO DO GN=GNMN,GNMX GNR = GN+2 DO K1=1,3 DO 80 L1=1,3 IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND. & (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80 IF(GN.EQ.1) THEN K = 119+2*K1 L = 125+2*L1 GLP = GL GRP = GR EC = ONE CFAC = ONE ELSEIF(GN.EQ.2) THEN K = 2*K1-1 L = 2*L1+5 GLP = LFCH(K) GRP = RFCH(K) EC = ONE/THREE CFAC = THREE ENDIF MQ1 = RMASS(K) MQ2 = RMASS(L) IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80 MET = ZERO IF(GENEV) GOTO 60 C--calculate the matrix element C--set all coefficents to zero FSLL = Z0 FSLR = Z0 FSRL = Z0 FSRR = Z0 FTLL = Z0 FTLR = Z0 FTRL = Z0 FTRR = Z0 C--Standard Model terms IF(K1.EQ.L1) THEN C--first if same flavour pair production FSLL = EC*SP+GL*GRP*GZ FSLR = EC*SP+GL*GLP*GZ FSRL = EC*SP+GR*GRP*GZ FSRR = EC*SP+GR*GLP*GZ C--t channel terms if e+e- --> e+e- IF(K1.EQ.IL.AND.GN.EQ.1) THEN FTLL = TP+GL*GR*TPZ FTLR = TP+GL**2*TPZ FTRL = TP+GR**2*TPZ FTRR = TP+GL*GR*TPZ ENDIF ENDIF C--Now add the RPV terms DO I=1,3 IF(GN.EQ.1) THEN TPN = ONE/(T-MSL2(I)) TPN2 = TPN ELSE TPN = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2)) TPN2 = ZERO ENDIF FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2 FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I) FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I) ENDDO C--now calculate the matrix element (including beam polarization) MET =(ONE+COSTH)**2*DREAL( & DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3)) & +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3)) & +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3)) & +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3)) & +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3)) & +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3))) & +(ONE-COSTH)**2*DREAL( & DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3)) & +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3))) & +FOUR*DREAL( & DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3)) & +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3))) C--final phase space factors ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN 60 HCS = HCS+ME(GN,K1,L1) IF(HCS.GT.RCS.AND.GENEV) GOTO 900 80 CONTINUE ENDDO ENDDO 900 IF(GENEV) THEN C--change sign of COSTH if antiparticle first IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH C-Set up the particle types IDHW(NHEP+1) = 15 IDHEP(NHEP+1) = 0 ISTHEP(NHEP+1) = 110 IDHW(NHEP+2) = K IDHW(NHEP+3) = L IDHEP(NHEP+2) = IDPDG(K) IDHEP(NHEP+3) = IDPDG(L) C--Select the masses of the particles and the final-state momenta 910 NTRY = NTRY+1 PHEP(5,NHEP+2) = HWUMBW(K) PHEP(5,NHEP+3) = HWUMBW(L) CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN GOTO 910 ELSEIF(PCM.LT.ZERO) THEN CALL HWWARN('HWHREE',100) GOTO 999 ENDIF C--Set up the colours etc ISTHEP(NHEP+2) = 113 ISTHEP(NHEP+3) = 114 JMOHEP(1,NHEP+1) = 1 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1) = 2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2) = NHEP+1 JMOHEP(2,NHEP+2) = NHEP+3 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+2 JDAHEP(1,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+3 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+2) = NHEP+3 JDAHEP(1,NHEP+3) = 0 JDAHEP(2,NHEP+3) = NHEP+2 C--Set up the momenta IHEP = NHEP+2 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP) = PCM*COSTH PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) PHEP(2,IHEP) = ZERO CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1)) NHEP = NHEP+3 ELSE EVWGT = HCS ENDIF 999 RETURN END CDECK ID>, HWHREM. *CMZ :- -01/06/94 17.03.31 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHREM(IBEAM,ITARG) C----------------------------------------------------------------------- C IDENTIFY THE REMNANTS OF THE HARD SCATTERING C AND BREAK THEIR COLOUR CONNECTION IF NECESSARY C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PCL(5), $ P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT LOGICAL LTEMP,T,COL,ANT PARAMETER (T=.TRUE.) COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120 ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114 C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS IBEAM=0 ITARG=0 DO 10 IHEP=1,NHEP IF (ISTHEP(IHEP).EQ.148) THEN IF (ITARG.NE.0) THEN CALL HWWARN('HWHREM',100) GOTO 999 ENDIF ITARG=IHEP ELSEIF (ISTHEP(IHEP).EQ.147) THEN IF (IBEAM.NE.0) THEN CALL HWWARN('HWHREM',101) GOTO 999 ENDIF IBEAM=IHEP ENDIF 10 CONTINUE IF (ITARG.EQ.0) THEN CALL HWWARN('HWHREM',102) GOTO 999 ENDIF IF (IBEAM.EQ.0) THEN CALL HWWARN('HWHREM',103) GOTO 999 ENDIF C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS C---FIND REMNANT MOMENTA AND MASSES P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG)) P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM)) P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG)) S=P1SQ+2*P1P2+P2SQ TMP1=P1P2**2-P1SQ*P2SQ IF (TMP1.LE.0) THEN CALL HWWARN('HWHREM',104) GOTO 999 ENDIF TMP1=SQRT(TMP1) M1SQ=RMASS(IDHW(IBEAM))**2 M2SQ=RMASS(IDHW(ITARG))**2 TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ IF (TMP2.LE.0) THEN CALL HWWARN('HWHREM',105) GOTO 999 ENDIF TMP2=SQRT(TMP2) C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL A=(1-(P1P2+P2SQ)/TMP1)/2 B=(1-(P1P2+P1SQ)/TMP1)/2 C=(S-M1SQ+M2SQ-TMP2)/(2*S) D=(S+M1SQ-M2SQ-TMP2)/(2*S) CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT) CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM)) CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG)) CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM)) CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG)) CALL HWUMAS(PHEP(1,IBEAM)) CALL HWUMAS(PHEP(1,ITARG)) C---END MHS FIX C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT C GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS C (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION) C---LOOP OVER COLOUR/ANTICOLOUR LINE DO 20 I=1,2 IF (I.EQ.1) THEN ICOL=IBEAM IANT=ITARG ELSE ICOL=ITARG IANT=IBEAM ENDIF IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND. $ JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL) CALL HWUMAS(PCL) NTEMP=NHEP CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP) IF (IERROR.NE.0) RETURN C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP IF (NHEP.NE.NTEMP+2) RETURN C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD ISTHEP(NHEP-1)=149 ISTHEP(NHEP)=149 ENDIF 20 CONTINUE 999 RETURN END CDECK ID>, HWHREP. *CMZ :- -18/10/00 13:46:47 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHREP C----------------------------------------------------------------------- C SUSY E+E- RPV PRODUCTION C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' IF(IPROC.GE.800.AND.IPROC.LE.850) THEN CALL HWHRES ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN CALL HWHREE C---UNRECOGNIZED PROCESS ELSE CALL HWWARN('HWHREP',500) ENDIF END CDECK ID>, HWHRES. *CMZ :- -07/04/02 10:38:51 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRES C----------------------------------------------------------------------- C SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION C POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA, & FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2), & MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2, & MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3), & MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM, & PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN, & A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2), & HL(4),M4(10,2),HNU(3) INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY, & ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2, & RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL, & MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX, & RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW PARAMETER (SSNU=449,SSCH = 455) C--Start of the code IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE C--Initialise the hard processes IF(FSTWGT) THEN C--Decide which processes to generate NEUT = .FALSE. CHAR = .FALSE. RAD = .FALSE. HIGGS = .FALSE. C--all single sparticle production IF(IPROC.EQ.800) THEN NEUT = .TRUE. CHAR = .TRUE. RAD = .TRUE. HIGGS = .TRUE. NTID(1) = 1 NTID(2) = 4 CHID(1) = 1 CHID(2) = 2 GMIN = 1 GMAX = 6 C--single neutralino production ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN NEUT = .TRUE. IF(IPROC.EQ.810) THEN NTID(1) = 1 NTID(2) = 4 ELSE NTID(1) = IPROC-810 NTID(2) = NTID(1) ENDIF C--single chargino production ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN CHAR = .TRUE. IF(IPROC.EQ.820) THEN CHID(1) = 1 CHID(2) = 2 ELSE CHID(1) = IPROC-820 CHID(2) = CHID(1) ENDIF C--single slepton production with gauge boson ELSEIF(IPROC.EQ.830) THEN RAD = .TRUE. GMIN = 1 GMAX = 6 C--single slepton production with Higgs boson ELSEIF(IPROC.EQ.840) THEN HIGGS = .TRUE. C--photon radiation processes ELSEIF(IPROC.EQ.850) THEN RAD = .TRUE. GMIN = 7 GMAX = 8 C--unrecognized process issue warning ELSE CALL HWWARN('HWHRES',500) ENDIF C--check the particles in the beam RSID(2) = 3 IF(ABS(IDHEP(1)).EQ.11) THEN C--electron beams ISL = 425 ISR = 437 ISN = 426 RSID(1) = 2 IL = 1 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN C--muon beams ISL = 427 ISR = 439 ISN = 428 RSID(1) = 1 IL = 2 C--unrecognised beam particles issue warning ELSE CALL HWWARN('HWHRES',501) ENDIF IDL=ABS(IDHEP(1)) C--masses and electroweak parameters SW = SQRT(SWEIN) CW = SQRT(1-SWEIN) MW = RMASS(198) MZ = RMASS(200) MW2 = MW**2 MZ2 = MZ**2 SIN2B = TWO*SINB*COSB C--neutralino and chargino masses DO I=1,4 MNU(I) = RMASS(SSNU+I) MNU2(I) = MNU(I)**2 ENDDO DO I = 1,2 MCH(I) = RMASS(I+SSCH) MCH2(I) = MCH(I)**2 ENDDO C--incoming lepton mass MLT(1) = RMASS(IDL+110) C--lepton masses in chargino production DO I=1,2 MLT(I+1) = RMASS(119+2*RSID(I)) ENDDO DO I=1,3 MLT2(I) = MLT(I)**2 ENDDO C--t-channel slepton masses MSL2 = RMASS(ISL)**2 MSR2 = RMASS(ISR)**2 MSNU2 = RMASS(ISN)**2 C--resonant sneutrino masses and widths DO I=1,2 MNUT(I) = RMASS(424+2*RSID(I)) MNUT2(I) = MNUT(I)**2 RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2 ENDDO C--now calculate the coefficients for the processes C--first neutralino production DO L=1,4 MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW) C--first for the left slepton A(L,1) = SLFCH(IDL,L) B(L,1) = ZSGNSS(L)*MC C--then the right slepton A(L,2) = ZSGNSS(L)*SRFCH(IDL,L) B(L,2) = MC C--the resonant sneutrino DO I=1,2 A(L,2+I) = SLFCH(10+2*RSID(I),L) B(L,2+I) = ZERO ENDDO ENDDO C--now chargino production DO L=1,2 J=L+4 MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW) C--first for the t channel sneutrino A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW B(J,1) = -MLT(1)*MC C--now for the resonant sneutrinos DO I=1,2 A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW B(J,I+1) = -MLT(I+1)*MC ENDDO ENDDO C--coupling of the Z to the sneutrino ZNU = HALF/SW/CW C--now the masses and IDs of the slepton in the radiative processes C--IDs and masses of the charged sleptons DO I=1,2 RADID(2,2*I-1) = 423+RSID(I)*2 RADID(2,2*I ) = 435+RSID(I)*2 MSCL(I,1) = RMASS(RADID(2,2*I-1)) MSCL(I,2) = RMASS(RADID(2,2*I)) DO J=1,2 MSCL2(I,J) = MSCL(I,J)**2 ENDDO ENDDO C--ID of the W for charged slepton processes DO I=1,4 RADID(1,I) = 198 ENDDO C--ID's for the Z and gamma processes DO I=1,2 RADID(1,I+4) = 200 RADID(1,I+6) = 59 RADID(2,I+4) = 424+RSID(I)*2 RADID(2,I+6) = RADID(2,I+4) ENDDO C--couplings of the sleptons to the Higgs DO I=1,2 DO J=1,2 K = 2*RSID(I)-1 L = 119+2*RSID(I) HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B) & +LMIXSS(K,2,J)*RMASS(L)*MUSS IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J) & +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW ENDDO ENDDO C--coupling of the sneutrino to the Higgs HNU(1) = HALF*MZ*SINBPA/CW HNU(2) = -HALF*MZ*COSBPA/CW HNU(3) = ZERO C--couplings of the leptons to the Higgs RHO = HALF*MLT(1)/MW HL(1) = -RHO*SINA/COSB HL(2) = RHO*COSA/COSB HL(3) = RHO*TANB HL(4) = RHO*TANB/SQRT(HALF) C--Higgs Masses DO I=1,4 MH(I) = RMASS(202+I) MH2(I) = MH(I)**2 ENDDO ENDIF C--Now calculate the weights COSTH = HWRUNI(1,-ONE,ONE) S = PHEP(5,3)**2 EMSCA = PHEP(5,3) FACA = HWUAEM(S)*GEV2NB/S/8.0D0 FACD = HALF*FACA/SWEIN FACB = HALF*FACD/MW2 FACC = HALF*FACA/MZ2 FACE = ALPHEM*GEV2NB/S/8.0D0 DO I=1,2 SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I)) ENDDO C--single neutralino production IF(.NOT.NEUT) THEN DO L=1,4 DO J=1,4 M1(L,J) = ZERO ENDDO ENDDO GOTO 100 ENDIF DO L=NTID(1),NTID(2) DO J=1,2 SQPE = S - MNU2(L) K = J+2 IF(SQPE.GE.ZERO) THEN PF = SQPE/S T = HALF*(SQPE*COSTH-S+MNU2(L)) U = -T-S+MNU2(L) UP = ONE/(U-MSL2) TP = ONE/(T-MSR2) C--neutralino antineutrino production (including beam polarization) M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*( & A(L,K)**2*S*(S-MNU2(L))*SCF(J) & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1) & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2) & +TWO*U*T*UP*TP*A(L,1)*A(L,2)) & +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))* & (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3))) & +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))* & (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3))) C--neutralino neutrino production (including beam polarization) M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*( & A(L,K)**2*S*(S-MNU2(L))*SCF(J) & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1) & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2) & +TWO*U*T*UP*TP*A(L,1)*A(L,2)) & +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))* & (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3))) & +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))* & (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3))) C--final coefficients M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J) M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K) ELSE M1(L,J) = ZERO M1(L,K) = ZERO ENDIF ENDDO ENDDO C--single chargino production 100 IF(.NOT.CHAR) THEN DO L=1,2 DO J=1,4 M2(L,J) = ZERO ENDDO ENDDO GOTO 200 ENDIF DO L = CHID(1),CHID(2) DO J = 1,2 K = J+1 L2 = L+4 SM = MCH(L) + MLT(K) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MCH(L) - MLT(K) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K)) U = -T-S+MCH2(L)+MLT2(K) UP = ONE/(U-MSNU2) C--chargino antilepton (including beam polarization) M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K) & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))* & (ONE-EPOLN(3))*(ONE-PPOLN(3)) & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))* & (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3))) & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))* & (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K)) C--chargino lepton (including beam polarization) M2(L,J+2) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K) & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))* & (ONE+EPOLN(3))*(ONE+PPOLN(3)) & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))* & (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3))) & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))* & (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K)) C--final coefficients M2(L,J) =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J) M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2) ELSE M2(L,J) = ZERO M2(L,J+2) = ZERO ENDIF ENDDO ENDDO C--Radiative processes 200 IF(.NOT.RAD) THEN DO I=1,8 DO J=1,2 M3(I,J) = ZERO ENDDO ENDDO GOTO 300 ENDIF IF(GMAX.LT.7) THEN C--W charged slepton production DO I=1,2 DO J=1,2 QPE = S-(MW+MSCL(I,J))**2 IF(QPE.GE.ZERO) THEN DM = MW-MSCL(I,J) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J)) U = -T-S+MW2+MSCL2(I,J) UP = ONE/U C--W slepton M3(2*I+J-2,1) = SCF(I)*S*SQPE**2 & +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S) & -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+ & U*(S-MSCL2(I,J))) M3(2*I+J-2,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF & *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1) C--W- antislepton (including beam polarization) M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))* & M3(2*I+J-2,1) C--W+ antislepton (including beam polarization) M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))* & M3(2*I+J-2,1) ELSE M3(2*I+J-2,1) = ZERO M3(2*I+J-2,2) = ZERO ENDIF ENDDO ENDDO C--Z sneutrino production DO I=1,2 QPE = S-(MZ+MNUT(I))**2 IF(QPE.GE.ZERO) THEN DM = MZ-MNUT(I) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I)) U = -T-S+MZ2+MNUT2(I) UP = ONE/U TP = ONE/T IDZ = 9+RSID(I)*2 C--Z sneutrino production M3(I+4,1) = SCF(I)*S*SQPE**2*ZNU**2 & +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2) & +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2) & -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))* & (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I))) & +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))* & (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I))) & +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP* & (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T) M3(I+4,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1) C--Z antisneutrino (including beam polarization) M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1) C--Z sneutrino (including beam polarization) M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1) ELSE M3(I+4,1) = ZERO M3(I+4,2) = ZERO ENDIF ENDDO ELSE C--gamma sneutrino production (includes Jacobian 1-costh**2) C--now includes polarization effects DO I=1,2 SQPE = S-MNUT2(I) IF(SQPE.GE.ZERO) THEN PF = SQPE/S PCM = HALF*EMSCA*PF THTMIN = PTMIN/PCM IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502) THTMIN = ONE-THTMIN**2 THTMIN = HALF*LOG((1+THTMIN)/(1-THTMIN)) RHO = HWRUNI(2,-THTMIN,THTMIN) THCOS(I) = -TANH(RHO) T = HALF*(SQPE*THCOS(I)-S+MNUT2(I)) U = -T-S+MNUT2(I) UP = ONE/U TP = ONE/T M3(I+6,1) = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T) M3(I+6,1) = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)* & (ONE-THCOS(I)**2)*THTMIN M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3)) M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3)) ELSE M3(I+6,1) = ZERO M3(I+6,2) = ZERO ENDIF ENDDO ENDIF C--Higgs processes 300 IF(.NOT.HIGGS) THEN DO I=1,10 DO J=1,2 M4(I,J) = ZERO ENDDO ENDDO GOTO 500 ENDIF C--Charged Higgs charged slepton production DO I=1,2 DO J=1,2 QPE = S-(MH(4)+MSCL(I,J))**2 IF(QPE.GE.ZERO) THEN DM = MH(4)-MSCL(I,J) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J)) U = -T-S+MH2(4)+MSCL2(I,J) C--charged Higgs antislepton M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)* & (ONE-EPOLN(3))*(ONE-PPOLN(3)) & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2 & *(U*T-MSCL2(I,J)*MH2(4))/U**2* & (ONE+EPOLN(3))*(ONE-PPOLN(3)) C--charged Higgs slepton M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)* & (ONE+EPOLN(3))*(ONE+PPOLN(3)) & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2 & *(U*T-MSCL2(I,J)*MH2(4))/U**2* & (ONE-EPOLN(3))*(ONE+PPOLN(3)) C--final coefficients M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2* & M4(2*I+J-2,1)*PF M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2* & M4(2*I+J-2,2)*PF ELSE M4(2*I+J-2,1) = ZERO M4(2*I+J-2,2) = ZERO ENDIF ENDDO ENDDO C--neutral higgs sneutrino production DO L=1,3 DO I=1,2 QPE = S-(MH(L)+MNUT(I))**2 IF(QPE.GE.ZERO) THEN DM = MH(L)-MNUT(I) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I)) U = -T-S+MH2(L)+MNUT2(I) IF(L.NE.3) THEN C--h0, H0 antisneutrino (including beam polarization) M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)* & (ONE-EPOLN(3))*(ONE-PPOLN(3)) & +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)) & +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))) & *(U*T-MH2(L)*MNUT2(I)) C--h0, H0 sneutrino (including beam polarization) M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)* & (ONE+EPOLN(3))*(ONE+PPOLN(3)) & +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)) & +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))) & *(U*T-MH2(L)*MNUT2(I)) ELSE C--A0 antisneutrino (including beam polarization) M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*( & HNU(L)**2*S*SCF(I) & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I))) C--A0 sneutrino (including beam polarization) M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*( & HNU(L)**2*S*SCF(I) & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I))) ENDIF C--final coefficients M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2* & M4(2*L+I+2,1)*PF M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2* & M4(2*L+I+2,2)*PF ELSE M4(2*L+I+2,1) = ZERO M4(2*L+I+2,2) = ZERO ENDIF ENDDO ENDDO ENDIF C--Add up the weights now 500 HCS = ZERO C--single neutralino production IF(.NOT.NEUT) GOTO 550 DO L=NTID(1),NTID(2) IG1= SSNU+L DO J=1,4 IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2) HCS = HCS+M1(L,J) THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR. & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 ENDDO ENDDO C--single chargino production 550 IF(.NOT.CHAR) GOTO 600 DO L=CHID(1),CHID(2) DO J=1,4 IG1 = SSCH+L-2*INT((J-1)/2) IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2) HCS = HCS + M2(L,J) THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR. & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2) IF (GENEV.AND.HCS.GT.RCS) GOTO 900 ENDDO ENDDO C--gauge boson slepton production 600 IF(.NOT.RAD) GOTO 650 DO I=GMIN,GMAX IG1 = RADID(1,I) IG2 = RADID(2,I) IF(I.GE.7) COSTH = THCOS(I-6) DO J=1,2 HCS = HCS+M3(I,J) THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR. & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 IF(I.LE.4) IG1 = IG1+1 IG2 = IG2+6 ENDDO ENDDO C--higgs slepton production 650 IF(.NOT.HIGGS) GOTO 900 C--charged Higgs slepton DO I=1,4 IG1 = 207 IG2 = RADID(2,I)+6 DO J=1,2 HCS=HCS+M4(I,J) THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR. & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 IG1 = IG1-1 IG2 = IG2-6 ENDDO ENDDO C--Neutral Higgs sneutrino DO L=1,3 DO I=1,2 IG1 = 202+L IG2 = 430+2*RSID(I) DO J=1,2 HCS = HCS+M4(2+2*L+I,J) THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR. & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2) IF(GENEV.AND.HCS.GT.RCS) GOTO 900 IG2 = IG2-6 ENDDO ENDDO ENDDO 900 IF(GENEV) THEN C--change sign of COSTH if antiparticle first IF(THSGN) COSTH = -COSTH C-Set up the particle types IDHW(NHEP+1) = 15 IDHEP(NHEP+1) = 0 ISTHEP(NHEP+1) = 110 IDHW(NHEP+2) = IG1 IDHW(NHEP+3) = IG2 IDHEP(NHEP+2) = IDPDG(IG1) IDHEP(NHEP+3) = IDPDG(IG2) C--generate the particle masses and final-state momenta NTRY = 0 910 NTRY = NTRY+1 PHEP(5,NHEP+2) = HWUMBW(IG1) PHEP(5,NHEP+3) = HWUMBW(IG2) C--Set up the Centre-of-mass energy CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1)) PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3)) IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN GOTO 910 ELSEIF(PCM.LT.ZERO) THEN CALL HWWARN('HWHRES',100) GOTO 999 ENDIF C--Set up the colours etc ISTHEP(NHEP+2) = 113 ISTHEP(NHEP+3) = 114 JMOHEP(1,NHEP+1) = 1 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1) JMOHEP(2,NHEP+1) = 2 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2) JMOHEP(1,NHEP+2) = NHEP+1 JMOHEP(2,NHEP+2) = NHEP+2 JMOHEP(1,NHEP+3) = NHEP+1 JMOHEP(2,NHEP+3) = NHEP+3 JDAHEP(1,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+3 JDAHEP(1,NHEP+2) = 0 JDAHEP(2,NHEP+2) = NHEP+2 JDAHEP(1,NHEP+3) = 0 JDAHEP(2,NHEP+3) = NHEP+3 C--set up the rest of the momenta IHEP = NHEP+2 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2) PHEP(3,IHEP) = PCM*COSTH PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP))) PHEP(2,IHEP) = ZERO CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP)) CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1)) NHEP = NHEP+3 ELSE EVWGT = HCS ENDIF 999 RETURN END CDECK ID>, HWHRLL. *CMZ :- -08/04/02 09:00:27 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRLL C----------------------------------------------------------------------- C Subroutine for resonant sleptons to standard model particles C slepton mass and mass*width added to save statement to C avoid problems with Linux by Peter Richardson C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH, & TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12), & SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2), & RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB, & WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12), & MSWD(12) INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF LOGICAL FIRST EXTERNAL HWRGEN,HWRUNI PARAMETER(EPS=1D-20) COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF,MSL2, & MSWD IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IF(FSTWGT) THEN DO I=1,3 MSL(2*I-1) = RMASS(423+2*I) MSL(2*I) = RMASS(435+2*I) MSL(2*I+5) = RMASS(424+2*I) MSL(2*I+6) = RMASS(436+2*I) SLWD(2*I-1) = HBAR/RLTIM(423+2*I) SLWD(2*I) = HBAR/RLTIM(435+2*I) SLWD(2*I+5) = HBAR/RLTIM(424+2*I) SLWD(2*I+6) = HBAR/RLTIM(436+2*I) ENDDO DO I=1,12 MSL2(I) = MSL(I)**2 MSWD(I) = MSL(I)*SLWD(I) ENDDO RAND = ZERO DO I=1,3 CHANPB=ZERO DO J=1,3 DO K=1,3 CHANPB=CHANPB+LAMDA2(I,J,K)**4 ENDDO ENDDO RAND=RAND+2*CHANPB DO J=1,2 CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB CHAN(2*I+4+J) = LMIXSS(2*I ,1,J)**2*CHANPB MIX(2*I-2+J) = LMIXSS(2*I-1,1,J)**2 MIX(2*I+4+J) = LMIXSS(2*I ,1,J)**2 ENDDO ENDDO IF(RAND.GT.ZERO) THEN DO I=1,12 CHAN(I)=CHAN(I)/RAND ENDDO ELSE CALL HWWARN('HWHRLL',500) ENDIF C--find the couplings DO GN=1,3 DO I=1,3 DO J=1,3 DO K=1,3 DO L=1,3 LAM(1,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA1(GN,K,L) LAM(2,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA2(GN,K,L) LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L) LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L) ENDDO ENDDO ENDDO ENDDO ENDDO C--select the process from the IPROC code GNMN = 1 GNMX = 4 IF(MOD(IPROC,10000).EQ.4070) THEN GNMX = 2 ELSEIF(MOD(IPROC,10000).EQ.4080) THEN GNMN = 3 ENDIF ENDIF EVWGT = ZERO S = PHEP(5,3)**2 COSTH = HWRUNI(0,-ONE,ONE) C--Generate the smoothing RAND=HWRUNI(0,ZERO,ONE) DO I=1,12 IF(CHAN(I).GT.RAND) GOTO 20 RAND=RAND-CHAN(I) ENDDO 20 GR = I C--Calculate hard scale and obtain parton distributions TAUA = MSL2(GR)/S TAUB = SLWD(GR)**2/S RTAB = SQRT(TAUA*TAUB) XUPP = XMAX IF(XMAX**2.GT.S) XUPP = SQRT(S) LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB TAU = HWRUNI(0,LOWTLM,UPPTLM) TAU = RTAB*TAN(RTAB*TAU)+TAUA SH = S*TAU SQSH = SQRT(SH) EMSCA = SQSH XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU))) XX(2) = TAU/XX(1) CALL HWSGEN(.FALSE.) C--Calculate the prefactor due multichannel approach FAC = ZERO DO GN=1,12 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2) FAC=FAC+CHAN(GN)*SCF(GN) ENDDO FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB & /(96*PIFAC*SQSH*SH*TAU*FAC*S**2) ENDIF C--Now the loop to actually calculate the cross-sections HCS = ZERO DO GN=GNMN,GNMX IF(MOD(GN,2).EQ.1) THEN MIG = 1 MXG = 6 ELSE MIG = 7 MXG = 12 ENDIF IF(GN.LE.2) THEN CFAC = THREE*FAC CUP=2 ELSE CFAC = FAC CUP=1 ENDIF DO K1=1,3 DO 80 L1=1,3 IF(GN.EQ.1) THEN K = 2*K1 L = 2*L1+5 ELSEIF(GN.EQ.2) THEN K = 2*K1-1 L = 2*L1+5 ELSEIF(GN.EQ.3) THEN K = 120+2*K1 L = 125+2*L1 ELSEIF(GN.EQ.4) THEN K = 119+2*K1 L = 125+2*L1 ENDIF MQ1 = RMASS(K) MQ2 = RMASS(L) IF(SQSH.GT.(MQ1+MQ2)) THEN PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH) WD = (SH-MQ1**2-MQ2**2)*SH*PCM ELSE GOTO 80 ENDIF DO I1=1,3 DO 70 J1=1,3 IF(MOD(GN,2).EQ.1) THEN I=2*I1 J=2*J1+5 ELSE I=2*I1-1 J=2*J1+5 ENDIF DO GR =1,2 MET(GR) = ZERO ENDDO IF(GENEV) GOTO 60 DO 50 GEN=MIG,MXG IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS. & OR.ABS(MIX(GEN)).LT.EPS) GOTO 50 DO GR=MIG,MXG IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS. & AND.ABS(MIX(GR)).GT.EPS) THEN MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD* & ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR)) & *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN) & *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR) ENDIF ENDDO C--Now the t-channel diagrams if the s-channel particles is a sneutrino IF(GN.EQ.2) THEN ECM=SQRT(PCM**2+MQ1**2) TH=MQ1**2-SQSH*(ECM-PCM*COSTH) DO GR=MIG,MXG MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM* & LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)* & LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR) & /((TH-MSL2(GEN))*(TH-MSL2(GR))) ENDDO ENDIF 50 CONTINUE C--final phase space factors IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70 DO GR = 1,2 ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC ENDDO 60 DO GR = 1,2 CF = GR IF(CUP.EQ.1) CF=0 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(9,I,J,K,L,0,CF) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(10,J,I,K,L,0,CF) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1,GR) & *DISF(I+6,1)*DISF(J-6,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(9,I,J,K,L,1,CF) GOTO 100 ENDIF HCS = HCS+ME(GN,I1,J1,K1,L1,GR) & *DISF(J-6,1)*DISF(I+6,2) IF(HCS.GT.RCS.AND.GENEV) THEN CALL HWHRSS(10,J,I,K,L,1,CF) GOTO 100 ENDIF ENDDO 70 CONTINUE ENDDO 80 CONTINUE ENDDO ENDDO 100 IF(GENEV) THEN CALL HWETWO(.TRUE.,.TRUE.) ELSE EVWGT = HCS ENDIF END CDECK ID>, HWHRLS. *CMZ :- -23/10/00 13:53:06 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRLS C----------------------------------------------------------------------- C Subroutine for 2 parton -> sparticle + X via LQD C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2, & MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC, & SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH, & TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM, & MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12), & CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3), & MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4), & ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4), & MSL2(12),MH(4),MSWD(12) INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN & ,NEUTMX,CHARMN,CHARMX,P LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST EXTERNAL HWRGEN,HWRUNI,HWUAEM COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU, & SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT, & CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU, & GDD,MSL2,MH,MSWD PARAMETER(EPS=1D-20) IF(GENEV) THEN RCS = HCS*HWRGEN(0) ELSE IF(FSTWGT) THEN C--Calculate Electroweak parameters needed SW = SQRT(SWEIN) CW = SQRT(1-SWEIN) MW = RMASS(198) MZ = RMASS(200) MW2 = MW**2 MZ2 = MZ**2 SIN2B = TWO*SINB*COSB C--Masses and widths DO I=1,3 MSL(2*I-1) = RMASS(423+2*I) MSL(2*I) = RMASS(435+2*I) MSL(2*I+5) = RMASS(424+2*I) MSL(2*I+6) = RMASS(436+2*I) SLWD(2*I-1) = HBAR/RLTIM(423+2*I) SLWD(2*I) = HBAR/RLTIM(435+2*I) SLWD(2*I+5) = HBAR/RLTIM(424+2*I) SLWD(2*I+6) = HBAR/RLTIM(436+2*I) MSU(2*I-1) = RMASS(400+2*I)**2 MSU(2*I) = RMASS(412+2*I)**2 MSU(2*I+5) = RMASS(399+2*I)**2 MSU(2*I+6) = RMASS(411+2*I)**2 MST(2*I-1) = RMASS(399+2*I)**2 MST(2*I) = RMASS(411+2*I)**2 MLT(2*I) = ZERO MLT(2*I-1) = RMASS(119+2*I) ENDDO DO I=1,12 MSL2(I) = MSL(I)**2 MSWD(I) = MSL(I)*SLWD(I) ENDDO DO I=1,4 MNT(I) = ABS(RMASS(449+I)) ENDDO MCR(1) = ABS(RMASS(454)) MCR(2) = ABS(RMASS(455)) C--Couplings for the neutralinos DO L=1,4 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW) MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW) DO I=1,3 DO J=1,2 C--resonant charged sleptons A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J) & +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J) B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)* & LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J)) C--resonant sneutrinos A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J) B(L,2*I+4+J) = ZERO C--u channel up type squarks C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)* & RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J) D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)* & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J)) C--u channel down type squarks C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)* & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J) D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)* & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J)) C--t channel down type squarks C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)* & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J)) D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)* & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J) ENDDO ENDDO DO I=1,6 C(2,L,6+I) = C(2,L,I) D(2,L,6+I) = D(2,L,I) ENDDO ENDDO C--Couplings for charginos DO L=1,2 MC(1) = 1/(SQRT(2.0D0)*MW*COSB) MC(2) = 1/(SQRT(2.0D0)*MW*SINB) SP=L+4 DO I=1,3 DO J=1,2 C--resonant charged slepton A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J) & -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)* & MLT(2*I-1)*MC(1) B(SP,2*I-2+J) = ZERO C--resonant sneutrinos A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J) B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J) & *MC(1) C--u channel sup C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J) & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J)) D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1) & *QMIXSS(2*I,1,J) C--u channel sdown C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J) & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J) D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)* & RMASS(2*I)*QMIXSS(2*I-1,1,J) ENDDO ENDDO ENDDO C--Couplings and massesfor Higgs DO I=1,4 MH(I) = RMASS(202+I) ENDDO C--first the neutral Higgs C--fix to the sign of the A and mu term 31/03/00 PR DO I=1,3 H(I) = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA H(I+8) = -MLT(2*I-1)*HALF/MW*MUSS ENDDO H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO* & LMIXSS(5,2,1)*LMIXSS(5,1,1) & -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN) & +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN) & +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2)) & +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)* & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1)) H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO* & LMIXSS(5,2,1)*LMIXSS(5,1,1) & +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN) & +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN) & +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN) & +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)* & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1)) H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB H(11) = ZERO C--Now the charged Higgs DO J=1,2 DO I=1,3 H(10+2*I+J) = LMIXSS(2*I-1,1,J)* & (MLT(2*I-1)**2*TANB-MW2*SIN2B) & +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS ENDDO H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB ENDDO C--End of fix C--couplings of the Higgs to quarks DO I=1,3 GUU(I) = GHUUSS(I)**2/MW2*HALF**2 GDD(I) = GHDDSS(I)**2/MW2*HALF**2 ENDDO GUU(4) = ONE/TANB**2/MW2/8.0D0 GDD(4) = ONE*TANB**2/MW2/8.0D0 C--Couplings of the Z to quarks, left up right down, and charged sleptons ZQRK(1) = -SW**2/6.0D0/CW ZQRK(2) = (SW**2/3.0D0-HALF**2)/CW ZSLP(1) = HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW ZSLP(2) = HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW C--parameters for multichannel integration RAND = ZERO DO I=1,3 CHPROB = ZERO DO J=1,3 DO K=1,3 CHPROB=CHPROB+LAMDA2(I,J,K)**2 ENDDO ENDDO RAND = RAND+2*CHPROB DO J=1,2 MXS(2*I-2+J) = LMIXSS(2*I-1,1,J) MXS(2*I+4+J) = LMIXSS(2*I,1,J) MXU(2*I-2+J) = QMIXSS(2*I,1,J) MXU(2*I+4+J) = QMIXSS(2*I-1,1,J) MXT(2*I-2+J) = QMIXSS(2*I-1,2,J) MXT(2*I+4+J) = QMIXSS(2*I-1,2,J) CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB ENDDO ENDDO IF(RAND.GT.ZERO) THEN DO I=1,12 CHAN(I)=CHAN(I)/RAND ENDDO ELSE CALL HWWARN('HWHRLS',500) ENDIF C--decide what processes to generate RAD = .FALSE. NEUT = .FALSE. CHAR = .FALSE. HIGGS = .FALSE. NEUTMN= 1 NEUTMX = 4 CHARMN = 1 CHARMX = 2 C--Decide which process to generate IF(MOD(IPROC,10000).EQ.4000) THEN RAD = .TRUE. NEUT = .TRUE. CHAR = .TRUE. HIGGS = .TRUE. ELSEIF(MOD(IPROC,10000).LT.4020) THEN IF(MOD(IPROC,10000).NE.4010) THEN NEUTMN = MOD(IPROC,10) NEUTMX = NEUTMN ENDIF NEUT=.TRUE. ELSEIF(MOD(IPROC,10000).LT.4030) THEN IF(MOD(IPROC,10000).NE.4020) THEN CHARMN = MOD(IPROC,10) CHARMX=CHARMN ENDIF CHAR = .TRUE. ELSEIF(MOD(IPROC,10000).EQ.4040) THEN RAD = .TRUE. ELSEIF(MOD(IPROC,10000).EQ.4050) THEN HIGGS = .TRUE. ENDIF ENDIF C--basic parameters EVWGT = ZERO S = PHEP(5,3)**2 COSTH = HWRUNI(0,-ONE,ONE) RAND = HWRUNI(0,ZERO,ONE) C--zero arrays DO I=1,6 DO J=1,3 DO K=1,3 DO L=1,2 MEN(L,I,J,K) = ZERO MEN(L+2,I,J,K) = ZERO MEC(L,I,J,K) = ZERO ENDDO ENDDO ENDDO ENDDO DO I=1,8 MER(I)=ZERO ENDDO C--Perform multichannel integration DO I=1,12 IF(CHAN(I).GT.RAND) THEN GR=I GOTO 25 ENDIF RAND=RAND-CHAN(I) ENDDO C--Calculate the hard scale and obtain parton distributions 25 TAUA = MSL2(GR)/S TAUB = SLWD(GR)**2/S RTAB = SQRT(TAUA*TAUB) XUPP = XMAX IF(XMAX**2.GT.S) XUPP = SQRT(S) LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB TAU = HWRUNI(0,LOWTLM,UPPTLM) TAU = RTAB*TAN(RTAB*TAU)+TAUA SH = S*TAU SQSH = SQRT(SH) EMSCA = SQSH XX(1) = EXP(HWRUNI(0,LOG(TAU),ZERO)) XX(2) = TAU/XX(1) CALL HWSGEN(.FALSE.) C--EM and Weak couplings EC = SQRT(4*PIFAC*HWUAEM(SH)) G = EC/SW C--Calculate the prefactor due multichannel approach FAC = ZERO DO GN=1,12 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2) FAC=FAC+CHAN(GN)*SCF(GN) ENDDO FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/ & (48*TAU*FAC*PIFAC*S**2*SH*SQSH) ENDIF HCS = ZERO C--First we do the neutralino production IF(.NOT.NEUT) GOTO 200 DO 140 GN=1,6 I=GN GR = 2*GN-1 I1 = 2*GN-1 IF(GN.GT.3) THEN I=I-3 I1=I1-5 ENDIF IF(CHAN(GR).LT.EPS) GOTO 140 DO 130 L=NEUTMN,NEUTMX MN = MNT(L) MNS = MN**2 ML = MLT(I1) MLS = ML**2 IF((ML+MN).GT.SQSH) GOTO 130 C--that and uhat PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH ECM = SQRT(PCM**2+MLS) TH = MLS-SQSH*(ECM-PCM*COSTH) UH = MLS-SQSH*(ECM+PCM*COSTH) DO J=1,3 DO 120 K=1,3 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120 J1 = 2*J K1 = 2*K+5 IF(GN.GT.3) J1=J1-1 IF(GENEV) GOTO 110 C--squarks in u and t channels GU = 6*INT((GN-1)/3)+2*J-1 GT = 2*K C--calulate the matrix element ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)* & (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR)) & +MXU(GU)**2*(MLS-UH)*(MNS-UH)* & (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2 & +MXT(GT)**2*(MLS-TH)*(MNS-TH)* & (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2 & -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH) & /(UH-MSU(GU))/(TH-MST(GT)) & +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)* & SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU)) & +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)* & SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT)) C--s channel mixing L/R mixing IF(ABS(MXS(GR+1)).GT.EPS) THEN ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)* & (A(L,GR+1)**2+B(L,GR+1)**2) & -4*ML*MN*A(L,GR+1)*B(L,GR+1)) & +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)* & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+ & MSWD(GR)*MSWD(GR+1))*SH* & ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1)) & -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR))) & +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)* & SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1)) & /(UH-MSU(GU)) & +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)* & SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1)) & /(TH-MST(GT)) IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)* & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)* & (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1)) IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)* & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)* & (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1)) ENDIF C--u channel L/R mixing IF(ABS(MXU(GU+1)).GT.EPS) THEN ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+ & D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2 & +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)* & (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1)) & /(UH-MSU(GU))/(UH-MSU(GU+1)) & -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)* & (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT)) & +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)* & SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR)) & /(UH-MSU(GU+1)) IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)* & C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH) & /(UH-MSU(GU+1))/(TH-MST(GT-1)) ENDIF C--t channel L/R mixing IF(ABS(MXT(GT-1)).GT.EPS) THEN ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2 & +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2 & +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)* & (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1)) & /(TH-MST(GT))/(TH-MST(GT-1)) & -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)* & (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1)) & +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)* & SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR)) & /(TH-MST(GT-1)) ENDIF C--multiply by lamda and factors MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM 110 I2=I1+6 HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(11,J1,K1,I2,L,0,0) GOTO 500 ENDIF HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(12,K1,J1,I2,L,0,0) GOTO 500 ENDIF HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(11,J1,K1,I2,L,1,0) GOTO 500 ENDIF HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(12,K1,J1,I2,L,1,0) GOTO 500 ENDIF 120 CONTINUE ENDDO 130 CONTINUE 140 CONTINUE 200 IF(.NOT.CHAR) GOTO 300 C--Chargino production DO 240 GN=1,6 GR=2*GN-1 I=GN I1 = 2*GN IF(GN.GT.3) THEN I1=I1-7 I=GN-3 ENDIF IF(CHAN(GR).LT.EPS) GOTO 240 DO 230 L=CHARMN,CHARMX MN = MCR(L) MNS = MN**2 ML = MLT(I1) MLS = ML**2 SP = L+4 IF((ML+MN).GT.EMSCA) GOTO 230 PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH ECM = SQRT(PCM**2+MLS) TH = MLS-SQSH*(ECM-PCM*COSTH) UH = MLS-SQSH*(ECM+PCM*COSTH) DO J=1,3 DO 220 K=1,3 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220 J1=2*J K1=2*K+5 IF(GN.GT.3) J1=J1-1 IF(GENEV) GOTO 210 GU = 2*J-1 IF(GN.LE.3) GU=GU+6 C--Calculate the matrix element, s and u terms ME2 =MXS(GR)**2*SCF(GR)*SH*( & (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2) & -4*ML*MN*A(SP,GR)*B(SP,GR)) & +MXU(GU)**2*(MLS-UH)*(MNS-UH)* & (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2 & -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)* & SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU)) C--s channel L/R mixing IF(ABS(MXS(GR+1)).GT.EPS) THEN ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)* & (A(SP,GR+1)**2+B(SP,GR+1)**2) & -4*ML*MN*A(SP,GR+1)*B(SP,GR+1)) & +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)* & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+ & MSWD(GR)*MSWD(GR+1))*SH* & ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1) & +B(SP,GR)*B(SP,GR+1))-4*ML*MN* & (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1))) & -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH* & C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN) & /(UH-MSU(GU)) IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)* & (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH* & (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1)) ENDIF C--u channel L/R mixing IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)* & (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2) & /(UH-MSU(GU+1))**2 & +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)* & (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1)) & /(UH-MSU(GU))/(UH-MSU(GU+1)) & -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH* & C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN) & /(UH-MSU(GU+1)) MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF 210 I2 = I1+6 P = L+4 HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2) IF(GN.GT.3) P = P+2 IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(11,J1,K1,I2,P,0,0) GOTO 500 ENDIF HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(12,K1,J1,I2,P,0,0) GOTO 500 ENDIF HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(11,J1,K1,I2,P,1,0) GOTO 500 ENDIF HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(12,K1,J1,I2,P,1,0) GOTO 500 ENDIF 220 CONTINUE ENDDO 230 CONTINUE 240 CONTINUE 300 IF(.NOT.RAD) GOTO 400 C--Radiative decays IF(GENEV) GOTO 320 DO 310 GN=1,3 I1= 2*GN+5 I = 2*GN-1 C--charged slepton to sneutrino W IF(SQSH.GT.(MW+MSL(I1))) THEN PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH ECM = SQRT(PCM**2+MW2) TH = MW2-SQSH*(ECM-PCM*COSTH) UH = MW2-SQSH*(ECM+PCM*COSTH) ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2 & +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH) & -HALF*MXS(I)**2*SH*(SH-MSL2(I))*SCF(I)/TH* & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH) IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2 & +2.0D0*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2 & *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1)) & -HALF*MXS(I+1)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH* & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH) MER(GN) = ME2*PCM/MW2 ENDIF C--sneutrino to charged slepton W IF(SQSH.GT.(MW+MSL(I))) THEN PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH ECM = SQRT(PCM**2+MW2) TH = MW2-SQSH*(ECM-PCM*COSTH) UH = MW2-SQSH*(ECM+PCM*COSTH) ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2 & +HALF**2*MXS(I)**2/TH**2* & (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH) & -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH* & (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH) MER(GN+4) = ME2*PCM/MW2 ENDIF 310 CONTINUE C--now the decay stau_2 to stau_1 Z IF(SQSH.GT.(MZ+MSL(5))) THEN PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH ECM = SQRT(PCM**2+MZ2) TH = MZ2-SQSH*(ECM-PCM*COSTH) UH = MZ2-SQSH*(ECM+PCM*COSTH) ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2 & +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)* & MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))* & (SH-MSL2(6))+MSWD(5)*MSWD(6))) & +MXS(5)**2*ZQRK(2)**2/TH**2* & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH) & +MXS(5)**2*ZQRK(1)**2/UH**2* & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH) & +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5)) & +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))* & (-ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5))) & +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5)))) & +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH* & (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH) MER(4) = TWO*ME2*PCM/MZ2 ENDIF C--now the decay tau sneutrino to tau_2 W IF(SQSH.GT.(MW+MSL(6))) THEN PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH ECM = SQRT(PCM**2+MW2) TH = MW2-SQSH*(ECM-PCM*COSTH) UH = MW2-SQSH*(ECM+PCM*COSTH) ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2 & +HALF**2*MXS(6)**2/TH**2* & (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH) & -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH* & (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH) MER(8) = ME2*PCM/MW2 ENDIF C--Multiply by the parton distributions 320 DO I=1,4 DO J=1,3 DO 330 K=1,3 IF(I.LE.3) THEN LC = LAMDA2(I,J,K)**2 ELSE LC = LAMDA2(3,J,K)**2 ENDIF IF(LC.LT.EPS) GOTO 330 FAC2 = G**2*LC*FAC C--radiative cross-sections J1=2*J K1=2*K+5 ME2 = FAC2*MER(I) HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(13,J1,K1,I,I,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(14,K1,J1,I,I,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(13,J1,K1,I,I,1,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(14,K1,J1,I,I,1,0) GOTO 500 ENDIF J1=2*J-1 K1=2*K+5 ME2 = FAC2*MER(I+4) HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(13,J1,K1,I+4,I+4,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(14,K1,J1,I+4,I+4,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(13,J1,K1,I+4,I+4,1,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(14,K1,J1,I+4,I+4,1,0) GOTO 500 ENDIF 330 CONTINUE ENDDO ENDDO 400 IF(.NOT.HIGGS) GOTO 500 IF(GENEV) GOTO 480 DO I=1,3 DO 405 J=1,18 405 MEH(I,J) = ZERO ENDDO C--Neutral higgs charged slepton DO 420 L=1,3 DO 410 I=1,2 C--first two generations IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410 PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)* & (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2 410 CONTINUE C--third generation IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420 PCM = SQRT((SH-(MSL(5)+MH(L))**2)* & (SH-(MSL(5)-MH(L))**2))*HALF/SQSH ECM = SQRT(PCM**2+MH(L)**2) TH = MH(L)**2-SQSH*(ECM-PCM*COSTH) UH = MH(L)**2-SQSH*(ECM+PCM*COSTH) MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2 & +MXS(6)**2*SCF(6)*H(4*L)**2 & +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)* & H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+ & MSWD(5)*MSWD(6)) ) ME2 = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2) MEH(2,3*L) =ME2*GUU(L)/TH**2 MEH(3,3*L) =ME2*GDD(L)/UH**2 420 CONTINUE C--Charged higgs DO 440 I=1,3 C--charged slepton charged Higgs DO 430 J=1,2 IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430 PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)* & (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH ECM = SQRT(PCM**2+MH(4)**2) TH = MH(4)**2-SQSH*(ECM-PCM*COSTH) UH = MH(4)**2-SQSH*(ECM+PCM*COSTH) MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I) MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2* & (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2 430 CONTINUE C--Sneutrino Charged Higgs IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440 PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)* & (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH ECM = SQRT(PCM**2+MH(4)**2) TH = MH(4)**2-SQSH*(ECM-PCM*COSTH) UH = MH(4)**2-SQSH*(ECM+PCM*COSTH) MEH(1,15+I) = PCM*SH*HALF/MW2*( & MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2 & +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2 & +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)* & SCF(2*I)*H(11+2*I)*H(12+2*I)* & ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+ & MSWD(2*I-1)*MSWD(2*I))) MEH(2,15+I) = PCM*GUU(4)* & (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2 440 CONTINUE C--Multiply by the parton distributions 480 DO I=1,3 DO J=1,3 DO 490 K=1,3 IF(LAMDA2(I,J,K).LT.EPS) GOTO 490 C--Higgs cross-sections J1=2*J K1=2*K+5 FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF DO L=1,3 ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I) & +RMASS(K1)**2*MEH(3,3*L-3+I)) HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,I,L,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,I,L,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,I,L,1,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,I,L,1,0) GOTO 500 ENDIF ENDDO ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I)) HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,9+I,4,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,9+I,4,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,9+I,5,1,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,9+I,5,1,0) GOTO 500 ENDIF J1=2*J-1 K1=2*K+5 DO L=2,3 ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6)) HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,2*I+L,5,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,2*I+L,5,0,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(15,J1,K1,2*I+L,4,1,0) GOTO 500 ENDIF HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2) IF(GENEV.AND.HCS.GT.RCS) THEN CALL HWHRSS(16,K1,J1,2*I+L,4,1,0) GOTO 500 ENDIF ENDDO 490 CONTINUE ENDDO ENDDO C--Setup to generate the event 500 IF(GENEV) THEN CALL HWETWO(.TRUE.,.TRUE.) ELSE EVWGT = HCS ENDIF END CDECK ID>, HWHRSP. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRSP C----------------------------------------------------------------------- C Subroutine for all hadron-hadron Rparity violating processes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN C--SINGLE SPARTICLE VIA LQD CALL HWHRLS ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD CALL HWHRLL ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN C--SINGLE SPARTICLE VIA UDD CALL HWHRBS C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD ELSEIF(MOD(IPROC,10000).EQ.4160) THEN CALL HWHRBB ELSE C--UNKNOWN PROCESS CALL HWWARN('HWHRSP',500) ENDIF END CDECK ID>, HWHRSS. *CMZ :- -20/07/99 10:56:12 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM) C----------------------------------------------------------------------- C IDENTIDY HARD R-PARITY VIOLATING PROCESS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8), & NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12), & GAGID1(6),GAGID2(8) EXTERNAL HWUANT SAVE NEUTD1,NEUTD2,SLEPID,SQUID ,SQUID2,SLPID2,GAGID1,GAGID2 DATA NEUTD1 /450,451,452,453,454,455,456,457/ DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/ DATA SLEPID /432,434,436,435,431,433,435,447/ DATA SQUID /411,423,412,412,424,411/ DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/ DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/ DATA GAGID1 /199,199,200,198,198,200/ DATA GAGID2 /198,198,198,200,199,199,199,199/ IDCMF = 15 IF(IPERM.EQ.0) THEN ICO(1) = 2 ICO(2) = 1 ICO(3) = 3 ICO(4) = 4 ELSEIF(IPERM.EQ.1) THEN ICO(1) = 2 ICO(2) = 1 ICO(3) = 4 ICO(4) = 3 ELSEIF(IPERM.EQ.2) THEN ICO(1) = 3 ICO(2) = 4 ICO(3) = 1 ICO(4) = 2 ELSE CALL HWWARN('HWHRSS',100) GOTO 999 ENDIF IF(TYPE.LE.8) THEN IDN(1) = ID1+R4*6 IDN(2) = ID2+R4*6 ELSE SGN = 1 IF(MOD(TYPE,2).EQ.0) SGN = -1 IDN(1) = ID1+R4*6*SGN IDN(2) = ID2-R4*6*SGN ENDIF IF(TYPE.LE.2) THEN IDN(3) = ID3+6*R4 IDN(4) = ID4+6*R4 ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN IDN(3) = ID3-R4*6 IDN(4) = NEUTD2(ID4) ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN IDN(3) = GAGID1(ID3) IDN(4) = SQUID(ID4)-R4*6 IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3)) ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN IDN(3) =202+ID3 IDN(4) = SQUID2(ID4)-R4*6 ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN IDN(3) = ID3+6*R4 IDN(4) = ID4-6*R4 IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN SGN=IDN(3) IDN(3) = IDN(4) IDN(4) = SGN ENDIF ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN IDN(3) = 120+ID3-R4*6 IDN(4) = NEUTD1(ID4) IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4)) ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN IDN(3) = SLEPID(ID3)-R4*6 IDN(4) = GAGID2(ID4) IF(R4.NE.0) IDN(4) = HWUANT(IDN(4)) ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN IDN(3) = SLPID2(ID3)-R4*6 IDN(4) = 202+ID4 ENDIF IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH 999 RETURN END CDECK ID>, HWHSCT. *CMZ :- -18/03/04 18.42.43 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM) C----------------------------------------------------------------------- C RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING, C DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD C REPORT RETURNS THE OUTCOME: C 0 = SUCCESSFUL C 1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION C 2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING C 3 = FAILED DUE TO ERROR IN PARTON EVOLUTION C 4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION C 5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT) C FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL C OF THE EVENT C JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M C SCATTERS ABOVE PTMIN WITH PROBABILITY 1/(M+1) C PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3), $ WJMAX,PT,PTJIM,DUMMY,HWUPCM INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD, $ MYRN(2),TMPRN(2),JMUEO LOGICAL COL,FIRSTC,TMPFLG INTEGER IPRTMP EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM SAVE WJMAX,MYRN,NHARD DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/ COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120 REPORT=5 IF (IERROR.NE.0) RETURN C---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL IF (FIRSTC) NHARD=0 C---FIND BEAM AND TARGET REMNANTS CALL HWHREM(IBM,ITG) IF (IERROR.NE.0) RETURN C---RECALCULATE THEIR MASS CORRECTLY CALL HWUMAS(PHEP(1,IBM)) CALL HWUMAS(PHEP(1,ITG)) C---SET UP NEW ENTRIES IN THE EVENT RECORD NHEP=NHEP+1 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP)) ISTHEP(NHEP)=3 IBMN=NHEP IBMT=JDAHEP(1,1) IF (IBMT.EQ.0) THEN JMOHEP(1,NHEP)=1 IDHW(NHEP)=72 ELSE JMOHEP(1,NHEP)=IBMT IDHW(NHEP)=71 ENDIF JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHEP(NHEP)=IDPDG(IDHW(NHEP)) NHEP=NHEP+1 CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP)) ISTHEP(NHEP)=3 ITGN=NHEP ITGT=JDAHEP(1,2) IF (ITGT.EQ.0) THEN JMOHEP(1,NHEP)=2 IDHW(NHEP)=72 ELSE JMOHEP(1,NHEP)=ITGT IDHW(NHEP)=71 ENDIF JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHEP(NHEP)=IDPDG(IDHW(NHEP)) C---BOOST TO THEIR CENTRE-OF-MASS FRAME CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST) CALL HWUMAS(PBOOST) DO 100 IHEP=IBMN,NHEP CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) 100 CONTINUE CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST) DO 110 IHEP=IBMN,NHEP CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) 110 CONTINUE C---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND IF (WJMAX.EQ.0) THEN C---USING LOCAL RANDOM NUMBER SEEDS DUMMY=HWRGET(TMPRN) DUMMY=HWRSET(MYRN) GENEV=.FALSE. DO I=1,IBSH CALL HWHSCU(WGT,PTJIM) WJMAX=MAX(WJMAX,WGT) ENDDO WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX DUMMY=HWRGET(MYRN) DUMMY=HWRSET(TMPRN) C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN WJMAX=WJMAX*2 ENDIF C---GENERATE A NEW HARD SCATTERING 5 GENEV=.FALSE. 10 CALL HWHSCU(WGT,PTJIM) IF (WGT.GT.WJMAX) THEN WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)') $ ' Jimmy maximum weight exceeded! SQRT(S)=',PHEP(5,3), $ ' Increasing from ',WJMAX,' to ',WGT*2 WJMAX=WGT*2 ENDIF IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10 GENEV=.TRUE. CALL HWHSCU(WGT,PTJIM) C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON C SCATTERS THAT HAPPEN TO BE HIGH PT TMPFLG=.FALSE. IF (JMUEO.EQ.1) THEN C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)* $ SQRT(XX(1)*XX(2))*PHEP(5,3) $ /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP))) C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO IF (PT.GT.PTMIN) THEN IF ((NHARD+2)*HWRGEN(1).LT.1) THEN NHEP=IBMN-1 GOTO 5 ENDIF TMPFLG=.TRUE. ENDIF ENDIF C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS IF ( PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR. $ PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR. $ PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR. $ -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN IF (IERROR.GT.0) THEN WRITE (6,'(A/A)') $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS', $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL' REPORT=1 ELSE REPORT=2 ENDIF NHEP=IBMN-1 IERROR=0 RETURN ENDIF C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS JDAHEP(1,1)=IBMN JDAHEP(1,2)=ITGN C---EVOLVE THEM ISLENT=-1 C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO C QCD SCATTERING TO AVOID PROBLEMS WITH THE C PARTON SHOWER. IPRTMP=IPRO IPRO=15 CALL HWBGEN IPRO=IPRTMP ISLENT=1 C---PUT THE LABELS BACK JDAHEP(1,1)=IBMT JDAHEP(1,2)=ITGT C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS IF (IERROR.NE.0) THEN IF (IERROR.GT.0) THEN WRITE (6,'(A/A)') $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS', $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL' REPORT=3 ELSE REPORT=4 ENDIF NHEP=IBMN-1 IERROR=0 RETURN ENDIF C---UNDO THE LORENTZ BOOST DO 200 IHEP=IBMN,NHEP CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) 200 CONTINUE C---FIND THE NEW BEAM AND TARGET REMNANTS ISTHEP(IBM)=3 ISTHEP(ITG)=3 CALL HWHREM(IBMN,ITGN) IF (IERROR.NE.0) RETURN C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS IDHW(IBMN)=IDHW(IBM) IDHEP(IBMN)=IDHEP(IBM) IF (COL(IDHW(IBM))) THEN JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM) JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN) JDAHEP(2,IBMN)=JDAHEP(2,IBM) JMOHEP(2,JDAHEP(2,IBM))=IBMN ELSE JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM) JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN) JMOHEP(2,IBMN)=JMOHEP(2,IBM) JDAHEP(2,JMOHEP(2,IBM))=IBMN ENDIF JMOHEP(2,IBM)=0 JDAHEP(1,IBM)=IBMN JDAHEP(2,IBM)=0 IDHW(ITGN)=IDHW(ITG) IDHEP(ITGN)=IDHEP(ITG) IF (COL(IDHW(ITG))) THEN JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG) JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN) JDAHEP(2,ITGN)=JDAHEP(2,ITG) JMOHEP(2,JDAHEP(2,ITG))=ITGN ELSE JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG) JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN) JMOHEP(2,ITGN)=JMOHEP(2,ITG) JDAHEP(2,JMOHEP(2,ITG))=ITGN ENDIF JMOHEP(2,ITG)=0 JDAHEP(1,ITG)=ITGN JDAHEP(2,ITG)=0 C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE) DO 20 IHEP=1,NHEP IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP) THEN CALL HWWARN('HWHSCT',120) GOTO 999 ENDIF 20 CONTINUE REPORT=0 IF (TMPFLG) NHARD=NHARD+1 999 RETURN END CDECK ID>, HWHSCU *CMZ :- -17/03/04 14.37.43 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHSCU(WGT,PTJIM) C----------------------------------------------------------------------- C SWAP THE HARD PROCESS GENERATION PARAMETERS, C CALL HWHQCD, AND SWAP BACK C WGT IS THE OUTPUT EVENT WEIGHT C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW, $ TMPXMN,TMPXMX,TMPXPW,TMPWGT LOGICAL FIRST COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST C---STORE THE CURRENT VALUES TMPWGT=EVWGT TMPXMN=XMIN TMPXMX=XMAX TMPXPW=XPOW C---REPLACE BY NEW ONES XMIN=2*PTJIM XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2)) XPOW=-4D0 C---AND ENSURE THAT HWRPOW GETS REINITIALIZED FIRST=.TRUE. C---GENERATE A PHASE SPACE POINT CALL HWHQCD IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN IERROR=0 EVWGT=0 ENDIF WGT=EVWGT C---PUT THE OLD VALUES BACK EVWGT=TMPWGT XMIN=TMPXMN XMAX=TMPXMX XPOW=TMPXPW C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED FIRST=.TRUE. C---INCLUDE GAMWT HERE WGT=WGT*GAMWT END CDECK ID>, HWHSNG. *CMZ :- -20/09/95 14.59.15 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHSNG C PARTON-PARTON SCATTERING VIA COLOUR SINGLET C MEAN EVWGT = SIGMA IN NB C TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T) C PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID1,ID2 DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2, & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS SAVE HCS,FACT,S,T PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWRGEN(0) ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK=ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) ) YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) ) YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=0.5*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN COSTH=(Z1-Z2)/(Z1+Z2) S=XX(1)*XX(2)*PHEP(5,3)**2 T=-0.5*S*(1.-COSTH) U=-S-T C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET) EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U)) FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) $ /(16*PIFAC*S**2) CALL HWSGEN(.FALSE.) ENDIF C HCS=0. DO 20 ID1=1,13 IF (DISF(ID1,1).LT.EPS) GOTO 20 DO 10 ID2=1,13 IF (DISF(ID2,1).LT.EPS) GOTO 10 HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHQCP(ID1,ID2,3412,90) GOTO 30 ENDIF 10 CONTINUE 20 CONTINUE EVWGT=HCS RETURN C---GENERATE EVENT 30 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) END CDECK ID>, HWHSNM. *CMZ :- -20/09/95 15.28.53 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWHSNM(ID1,ID2,S,T) C MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING C INCLUDES SPIN AND COLOUR AVERAGES AND SUMS. C FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS C INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION C FOR IDENTICAL QUARK-ANTIQUARK PAIRS. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD, $ TOLD,QQ(13,13),ZETA3 INTEGER ID1,ID2 LOGICAL PHOTON C---ZETA3=RIEMANN ZETA FUNCTION(3) PARAMETER (ZETA3=1.202056903159594D0) SAVE ASQ,AINU,AINS,SOLD,TOLD,QQ DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/ C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG PHOTON=MOD(IPROC,100).GE.50 C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER C (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT) IF (QQ(ID1,ID2).LT.ZERO) THEN IF (PHOTON) THEN IF (ID1.EQ.13.OR.ID2.EQ.13) THEN QQ(ID1,ID2)=0 ELSE QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2 $ *(4*PIFAC)**2 ENDIF ELSE IF (ID1.EQ.13.AND.ID2.EQ.13) THEN QQ(ID1,ID2)=CAFAC**4 ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN QQ(ID1,ID2)=(CAFAC*CFFAC)**2 ELSE QQ(ID1,ID2)=CFFAC**4 ENDIF QQ(ID1,ID2)=QQ(ID1,ID2)* $ PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3) $ *(16*PIFAC) ENDIF ENDIF C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED IF (S.NE.SOLD.OR.T.NE.TOLD) THEN IF (PHOTON) THEN AINS=HWUAEM(T)**2 ASQ=2*(S**2+(S+T)**2)/T**2*AINS AINU=-4*S/T*AINS/NCOLO AINS=4*AINS/NCOLO-AINU ELSE Y=LOG(S/(-T))+ONE ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3 AINU=0 AINS=0 ENDIF ENDIF C---THE FINAL ANSWER IS JUST THEIR PRODUCT IF (ID1.EQ.ID2) THEN HWHSNM=QQ(ID1,ID2)*(ASQ+AINU) ELSEIF (ABS(ID1-ID2).EQ.6) THEN HWHSNM=QQ(ID1,ID2)*(ASQ+AINS) ELSE HWHSNM=QQ(ID1,ID2)*ASQ ENDIF END CDECK ID>, HWHSPN. *CMZ :- -01/10/01 19.41.18 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHSPN C----------------------------------------------------------------------- C Calculates the spin correlations for the hard process C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8), & F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8), & FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8) DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB, & PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE, & PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2), & MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J, & IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD), & ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4), & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4), & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2), & HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP, & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB LOGICAL SPIN,FIRST EXTERNAL HWUAEM PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) PARAMETER(EPS=1D-20) EXTERNAL HWULDO,HWVDOT,HWRGEN SAVE PREF,DIJ,O,FIRST DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/ DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/ DATA O/2,1/ DATA FIRST/.TRUE./ IF(IERROR.NE.0) RETURN IF(FIRST) THEN CALL HWISPC FIRST = .FALSE. ENDIF C--search the event record for the hard process DO 1 IHEP=1,NHEP IST = ISTHEP(IHEP) IF(IST.EQ.110.OR.IST.EQ.120) THEN ICM = IHEP GOTO 2 ENDIF 1 CONTINUE C--now decide whether or not to perform spin correlation 2 KHEP = JDAHEP(1,ICM) IK = IDHW(KHEP) JHEP = JDAHEP(2,ICM) IJ = IDHW(JHEP) IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500) SPIN = .FALSE. DO 3 IHEP=KHEP,JHEP ID = IDHW(IHEP) IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE. 3 CONTINUE IF(.NOT.SPIN) RETURN IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR. & (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN LHEP = JMOHEP(1,ICM) MHEP = JMOHEP(2,ICM) C--now identify the hard process C--SM processes first C--fermion-antifermion production in lepton-lepton collisions C--or via Z/gamma in hadron-hadron collisions IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN C--only need spin correlations for top and tau production IF((IK.EQ. 6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6 ).OR. & (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN C--check fermion first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--Id's of the incoming and outgoing fermions IL = IDHW(LHEP) ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120) ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120) C--couplings for the diagrams C--first the photon exchange A(1,1) = -QFCH(ID1) A(2,1) = -QFCH(ID1) B(1,1) = -QFCH(ID2) B(2,1) = -QFCH(ID2) IDP(5) = 59 DRTYPE(1) = 4 C--then the Z exchange A(1,2) = -RFCH(ID1) A(2,2) = -LFCH(ID1) B(1,2) = -RFCH(ID2) B(2,2) = -LFCH(ID2) IDP(6) = 200 DRTYPE(2) = 4 C--setup the colour flow NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 ELSE RETURN ENDIF C--fermion-antifermion via s-channel W in hadron-hadron ELSEIF(IPRO.EQ.14) THEN IF(IK.EQ. 6.OR.IK.EQ. 12.OR.IJ.EQ. 6.OR.IJ.EQ. 12.OR. & IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN C--check fermion first and reorder if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--couplings for the diagram A(1,1) = ZERO A(2,1) =-ORT/SW B(1,1) = ZERO B(2,1) =-ORT/SW IDP(5) = 198 DRTYPE(1) = 4 NDIA = 1 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 ELSE RETURN ENDIF C--top quark production via QCD ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN C--check if the outgoing fermion is first and change order if not IF(IDHEP(KHEP).LT.0) THEN ID = KHEP KHEP = JHEP JHEP = ID ENDIF C--quark-quark to t tbar IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN C--first check the incoming fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) C--couplings for the diagram A(1,1) =-ONE A(2,1) =-ONE B(1,1) =-ONE B(2,1) =-ONE IDP(5) = 13 DRTYPE(1) = 4 NDIA = 1 C--setup the colour flow NCFL(1) = 1 SPNCFC(1,1,1) = TWO/9.0D0 IFLOW(1) = 1 C--gluon-gluon to t tbar ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN C--setup the diagrams IDP(5) = 12 IDP(6) = 12 IDP(7) = 13 IDP(8) = 13 DRTYPE(1) = 5 DRTYPE(2) = 6 DRTYPE(3) = 7 DRTYPE(4) = 7 NDIA = 4 C--setup the colour flow NCFL(1) = 2 IFLOW(1) = 1 IFLOW(2) = 2 IFLOW(3) = 1 IFLOW(4) = 2 SPNCFC(1,1,1) = 0.25D0/THREE SPNCFC(2,2,1) = SPNCFC(1,1,1) SPNCFC(1,2,1) = ONE/THREE/32.0D0 SPNCFC(2,1,1) = ONE/THREE/32.0D0 C--incorrect initial state ELSE CALL HWWARN('HWHSPN',501) ENDIF C--don't need spin correlations haven't produced top ELSE RETURN ENDIF C--single top quark production in hadron collisions ELSEIF(IPRO.EQ.20) THEN C--change order if b quark not first and identify incoming particles IF(ABS(IDHEP(LHEP)).NE.5) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHEP(LHEP) IM = IDHEP(MHEP) C--change order if t quark not first IF(ABS(IDHEP(KHEP)).NE.6) THEN ID = KHEP KHEP = JHEP JHEP = ID ENDIF C--identify diagram type C--fermion fermion IF(IL.GT.0.AND.IM.GT.0) THEN DRTYPE(1) = 17 C--fermion antifermion ELSEIF(IL.GT.0.AND.IM.LT.0) THEN DRTYPE(1) = 18 C--antifermion fermion ELSEIF(IL.LT.0.AND.IM.GT.0) THEN DRTYPE(1) = 19 C--antifermion antifermion ELSEIF(IL.LT.0.AND.IM.LT.0) THEN DRTYPE(1) = 20 C--incorrect initial state ELSE CALL HWWARN('HWHSPN',502) ENDIF C--couplings A(1,1) = ZERO A(2,1) = -ORT/SW B(1,1) = ZERO B(2,1) = -ORT/SW C--virtual particle etc IDP(5) = 198 NDIA = 1 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 C--SUSY particle production ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN IF(MOD(IPROC,10000).GT.3030) RETURN C--fermion-antifermion to neutralino neutralino IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN C--first check the fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) IM = IDHW(MHEP) C--couplings of the various diagrams L1 = IK-449 L2 = IJ-449 ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120) C--couplings for the Z exchange diagram A(1,1) = -RFCH(ID) A(2,1) = -LFCH(ID) B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3) & +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW B(1,1) = -B(2,1) B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2) DRTYPE(1) = 1 IDP(5) = 200 C--couplings for the t-channel diagrams A(1,2) = ZERO A(2,2) =-RT*SLFCH(ID,L1) B(1,2) =-RT*SLFCH(ID,L2) B(2,2) = ZERO IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400 A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1) A(2,3) = ZERO B(1,3) = ZERO B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2) IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412 DRTYPE(2) = 2 DRTYPE(3) = 2 C--couplings for the u-channel diagrams A(1,4) = ZERO A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2) B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1) B(2,4) = ZERO IDP(8) = IDP(6) A(1,5) =-RT*SRFCH(ID,L2) A(2,5) = ZERO B(1,5) = ZERO B(2,5) =-RT*SRFCH(ID,L1) IDP(9) = IDP(7) DRTYPE(4) = 3 DRTYPE(5) = 3 NDIA=5 C--setup the colour flow NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 IFLOW(3) = 1 IFLOW(4) = 1 IFLOW(5) = 1 C--chargino pair production ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN C--first check the fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) IM = IDHW(MHEP) C--couplings of the various diagrams L1 = IK-453-2*INT((IK-454)/2) L2 = IJ-453-2*INT((IJ-454)/2) ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120) C--couplings for the s-channel photon exchange A(1,1) = -QFCH(ID) A(2,1) = -QFCH(ID) B(1,1) = -DIJ(L1,L2) B(2,1) = -DIJ(L1,L2) IDP(5) = 59 DRTYPE(1) = 1 C--couplings for the s-channel Z exchange A(1,2) = -RFCH(ID) A(2,2) = -LFCH(ID) B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1) & -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1) & -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW IDP(6) = 200 DRTYPE(2) = 1 C--couplings for the t-channel diagram IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN A(1,3) = ZERO A(2,3) =-WMXUSS(L1,1)/SW B(1,3) =-WMXUSS(L2,1)/SW B(2,3) = ZERO DRTYPE(3) = 2 ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN A(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW A(2,3) = ZERO B(1,3) = ZERO B(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW DRTYPE(3) = 2 ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN A(1,3) = ZERO A(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW B(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW B(2,3) = ZERO DRTYPE(3) = 3 ELSE A(1,3) =-WMXUSS(L2,1)/SW A(2,3) = ZERO B(1,3) = ZERO B(2,3) =-WMXUSS(L1,1)/SW DRTYPE(3) = 3 ENDIF IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400 & +2*MOD(IL,2)-1 NDIA = 3 C--setup the colour flow NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 IFLOW(3) = 1 C--chargino neutralino production ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR. & (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN C--first check the fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--chargino first IF(IK.GT.453) THEN C--change order of outgoing particles if negative chargino IF(IDHEP(KHEP).LT.0) THEN ID =KHEP KHEP=JHEP JHEP=ID ENDIF L1 = IK-453-2*INT((IK-454)/2) L2 = IJ-449 C--chargino second ELSE IF(IDHEP(JHEP).GT.0) THEN ID =KHEP KHEP=JHEP JHEP=ID ENDIF L1 = IJ-453-2*INT((IJ-454)/2) L2 = IK-449 ENDIF C--first the W exchange diagram A(1,1) = ZERO A(2,1) =-ORT/SW B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2) & +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2) & +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW IDP(5) = 198 DRTYPE(1) = 1 C--intermediate particles for the t and u channel diagrams IL = IDHW(LHEP) IM = IDHW(MHEP) IDP(6) = IM+394 IDP(7) = IL+406 IF(MOD(IL,2).EQ.0) THEN A(1,2) = ZERO A(2,2) =-WMXUSS(L1,1)/SW B(1,2) =-RT*SLFCH(IM-6,L2) B(2,2) = ZERO DRTYPE(2) = 2 A(1,3) = ZERO A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2) B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW B(2,3) = ZERO DRTYPE(3) = 3 ELSE A(1,2) = ZERO A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2) B(2,2) = ZERO DRTYPE(2) = 3 A(1,3) = ZERO A(2,3) =-RT*SLFCH(IL,L2) B(1,3) =-WMXUSS(L1,1)/SW B(2,3) = ZERO DRTYPE(3) = 2 ENDIF C--setup the colour flow NDIA = 3 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 IFLOW(3) = 1 C--neutralino gluino production ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR. & (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN C--first check the fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--check neutralino first and change order if not IF(IK.EQ.449) THEN L1 = IJ-449 ID = KHEP KHEP = JHEP JHEP = ID ELSE L1 = IK-449 ENDIF IL = IDHW(LHEP) C--coupling for the diagrams C--first t-channel squark exchange IDP(5) = 400+IL A(1,1) = ZERO A(2,1) =-RT*SLFCH(IL,L1) B(1,1) =-RT B(2,1) = ZERO DRTYPE(1) = 2 IDP(6) = 412+IL A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1) A(2,2) = ZERO B(1,2) = ZERO B(2,2) = RT DRTYPE(2) = 2 C--then u-channel s squark exchange IDP(7) = 400+IL A(1,3) = ZERO A(2,3) =-RT B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1) B(2,3) = ZERO DRTYPE(3) = 3 IDP(8) = 412+IL A(1,4) = RT A(2,4) = ZERO B(1,4) = ZERO B(2,4) =-RT*SRFCH(IL,L1) DRTYPE(4) = 3 C--colour flow information NDIA = 4 NCFL(1) = 1 IFLOW(1) = 1 IFLOW(2) = 1 IFLOW(3) = 1 IFLOW(4) = 1 SPNCFC(1,1,1) = ONE C--chargino gluino production ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR. & (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN C--first check the fermion is first and change order if not IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--check chargino first and change order if not IF(IK.EQ.449) THEN L1 = IJ-453-2*INT((IJ-454)/2) ID = KHEP KHEP = JHEP JHEP = ID ELSE L1 = IK-453-2*INT((IK-454)/2) ENDIF IL = IDHW(LHEP) IM = IDHW(MHEP) IDP(5) = IM+394 IDP(6) = IL+406 IF(MOD(IL,2).EQ.0) THEN A(1,1) = ZERO A(2,1) =-WMXUSS(L1,1)/SW B(1,1) =-RT B(2,1) = ZERO DRTYPE(1) = 2 A(1,2) = ZERO A(2,2) =-RT B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW B(2,2) = ZERO DRTYPE(2) = 3 ELSE A(1,1) = ZERO A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW B(1,1) =-RT B(2,1) = ZERO DRTYPE(1) = 2 A(1,2) = ZERO A(2,2) =-RT B(1,2) =-WMXUSS(L1,1)/SW B(2,2) = ZERO DRTYPE(2) = 3 ENDIF C--setup the colour flow NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 C--quark quark to gluino gluino ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND. & IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN C--change order if antiquark first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) C--couplings of the various diagrams A(1,1) = ZERO A(2,1) =-RT B(1,1) =-RT B(2,1) = ZERO A(1,2) = RT A(2,2) = ZERO B(1,2) = ZERO B(2,2) = RT DO 4 I=1,2 A(I,3) = A(I,1) B(I,3) = B(I,1) A(I,4) = A(I,2) 4 B(I,4) = B(I,2) A(1,5) = ONE A(2,5) = ONE B(1,5) = ONE B(2,5) = ONE A(1,6) =-ONE A(2,6) =-ONE B(1,6) = ONE B(2,6) = ONE C--intermediate particles IDP(5) = 400+IL IDP(6) = 412+IL IDP(7) = 400+IL IDP(8) = 412+IL IDP(9) = 13 IDP(10) = 13 C--types of diagram DRTYPE(1) = 2 DRTYPE(2) = 2 DRTYPE(3) = 3 DRTYPE(4) = 3 DRTYPE(5) = 1 DRTYPE(6) = 1 NDIA = 6 C--setup the colour flow NCFL(1) = 2 SPNCFC(1,1,1) = 8.0D0/27.0D0 SPNCFC(2,2,1) = 8.0D0/27.0D0 SPNCFC(1,2,1) =-ONE/27.0D0 SPNCFC(2,1,1) =-ONE/27.0D0 IFLOW(1) = 1 IFLOW(2) = 1 IFLOW(3) = 2 IFLOW(4) = 2 IFLOW(5) = 1 IFLOW(6) = 2 C--gluon gluon to gluino gluino ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449 & .AND.IK.EQ.449) THEN C--setup the diagrams IDP(5) = 449 IDP(6) = 449 IDP(7) = 13 IDP(8) = 13 DRTYPE(1) = 14 DRTYPE(2) = 15 DRTYPE(3) = 16 DRTYPE(4) = 16 NDIA = 4 C--setup the colour flow NCFL(1) = 2 IFLOW(1) = 1 IFLOW(2) = 2 IFLOW(3) = 1 IFLOW(4) = 2 SPNCFC(1,1,1) = 9.0D0/16.0D0 SPNCFC(2,2,1) = SPNCFC(1,1,1) SPNCFC(1,2,1) =-9.0D0/32.0D0 SPNCFC(2,1,1) =-9.0D0/32.0D0 C--neutralino squark production ELSEIF( (IK.GE.450.AND.IK.LE.453.AND. & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418))) & .OR.(IJ.GE.450.AND.IJ.LE.453.AND. & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418)))) & THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--change order in squark first IF(IJ.GE.450) THEN ID = KHEP KHEP = JHEP JHEP = ID IK = IDHW(KHEP) IJ = IDHW(JHEP) ENDIF IL = IDHW(LHEP) L1 = IK-449 C--left handed (lighter) squark IF(IJ.LT.412) THEN A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1) A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1) C--right handed (heavier) squark ELSEIF(IJ.GT.412) THEN A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2) A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2) ENDIF DO 5 I=1,2 5 A(I,2) = A(I,1) IDP(5) = IJ IDP(6) = IL C--colour flow info DRTYPE(1) = 8 DRTYPE(2) = 10 NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = HALF/THREE IFLOW(1) = 1 IFLOW(2) = 1 C--neutralino antisquark production ELSEIF( (IK.GE.450.AND.IK.LE.453.AND. & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424))) & .OR.(IJ.GE.450.AND.IJ.LE.453.AND. & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424)))) & THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--change order in squark first IF(IJ.GE.450) THEN ID = KHEP KHEP = JHEP JHEP = ID IK = IDHW(KHEP) IJ = IDHW(JHEP) ENDIF IL = IDHW(LHEP)-6 L1 = IK-449 C--left handed (lighter) squark IF(IJ.LE.412) THEN A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1) A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1) C--right handed (heavier) squark ELSEIF(IJ.GT.412) THEN A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2) A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2) ENDIF DO 6 I=1,2 6 A(I,2) = A(I,1) IDP(5) = IJ IDP(6) = IL C--colour flow info DRTYPE(1) = 9 DRTYPE(2) = 11 NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = HALF/THREE IFLOW(1) = 1 IFLOW(2) = 1 C--chargino squark ELSEIF((IK.GE.454.AND.IK.LE.457.AND. & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418))) & .OR.(IJ.GE.454.AND.IJ.LE.457.AND. & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418)))) & THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--change order if squark first IF(IJ.GE.454) THEN ID = KHEP KHEP = JHEP JHEP = ID IK = IDHW(KHEP) IJ = IDHW(JHEP) ENDIF IL = IDHW(LHEP) L1 = IK-453-2*INT((IK-454)/2) C--left handed (lighter) squark A(1,1) = ZERO IF(IJ.LE.412) THEN IF(MOD(IL,2).EQ.0) THEN A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW ELSE A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW ENDIF C--right handed (heavier) squark ELSEIF(IJ.GT.412) THEN IF(MOD(IL,2).EQ.0) THEN A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW ELSE A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW ENDIF ENDIF DO 7 I=1,2 7 A(I,2) = A(I,1) IDP(5) = IJ IDP(6) = IL C--colour flow info DRTYPE(1) = 8 DRTYPE(2) = 10 NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = HALF/THREE IFLOW(1) = 1 IFLOW(2) = 1 C--chargino antisquark ELSEIF((IK.GE.454.AND.IK.LE.457.AND. & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424))) & .OR.(IJ.GE.454.AND.IJ.LE.457.AND. & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424)))) & THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--change order in squark first IF(IJ.GE.454) THEN ID = KHEP KHEP = JHEP JHEP = ID IK = IDHW(KHEP) IJ = IDHW(JHEP) ENDIF IL = IDHW(LHEP)-6 L1 = IK-453-2*INT((IK-454)/2) C--left handed (lighter) squark A(2,1) = ZERO IF(IJ.LE.412) THEN IF(MOD(IL,2).EQ.0) THEN A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW ELSE A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW ENDIF C--right handed (heavier) squark ELSEIF(IJ.GT.412) THEN IF(MOD(IL,2).EQ.0) THEN A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW ELSE A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW ENDIF ENDIF DO 8 I=1,2 8 A(I,2) = A(I,1) IDP(5) = IJ IDP(6) = IL C--colour flow info DRTYPE(1) = 9 DRTYPE(2) = 11 NDIA = 2 NCFL(1) = 1 SPNCFC(1,1,1) = ONE IFLOW(1) = 1 IFLOW(2) = 1 C--squark gluino production ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406) & .OR.(IJ.GE.413.AND.IJ.LE.418))) & .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406) & .OR.(IK.GE.413.AND.IK.LE.418)))) THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) C--change order in squark first IF(IJ.EQ.449) THEN ID = KHEP KHEP = JHEP JHEP = ID IJ = IDHW(JHEP) ENDIF ID = INT((IJ-401)/12)+1 IF(ID.EQ.1) THEN A(1,1) = ZERO A(2,1) =-RT ELSE A(1,1) = RT A(2,1) = ZERO ENDIF DO 9 I=1,2 A(I,2) =-A(I,1) A(I,3) = A(I,1) 9 A(I,4) = A(I,1) DRTYPE(1) = 12 DRTYPE(2) = 12 DRTYPE(3) = 8 DRTYPE(4) = 10 IDP(5) = 449 IDP(6) = 449 IDP(7) = IJ IDP(8) = IL C--colour flows NDIA = 4 NCFL(1) = 2 IFLOW(1) = 1 IFLOW(2) = 2 IFLOW(3) = 1 IFLOW(4) = 2 SPNCFC(1,1,1) = 2.0D0/9.0D0 SPNCFC(2,2,1) = 2.0D0/9.0D0 SPNCFC(1,2,1) = -0.25D0/9.0D0 SPNCFC(2,1,1) = -0.25D0/9.0D0 C--antisquark gluino production ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412) & .OR.(IJ.GE.419.AND.IJ.LE.424))) & .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412) & .OR.(IK.GE.419.AND.IK.LE.424)))) THEN C--change order if gluon first IF(IDHW(LHEP).EQ.13) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF IL = IDHW(LHEP) C--change order in squark first IF(IJ.EQ.449) THEN ID = KHEP KHEP = JHEP JHEP = ID IJ = IDHW(JHEP) ENDIF ID = INT((IJ-401)/12)+1 IF(ID.EQ.1) THEN A(1,1) =-RT A(2,1) = ZERO ELSE A(1,1) = ZERO A(2,1) = RT ENDIF DO 10 I=1,2 A(I,2) =-A(I,1) A(I,3) = A(I,1) 10 A(I,4) = A(I,1) DRTYPE(1) = 13 DRTYPE(2) = 13 DRTYPE(3) = 9 DRTYPE(4) = 11 IDP(5) = 449 IDP(6) = 449 IDP(7) = IJ IDP(8) = IL C--colour flows NDIA = 4 NCFL(1) = 2 IFLOW(1) = 1 IFLOW(2) = 2 IFLOW(3) = 1 IFLOW(4) = 2 SPNCFC(1,1,1) = 2.0D0/9.0D0 SPNCFC(2,2,1) = 2.0D0/9.0D0 SPNCFC(1,2,1) = -0.25D0/9.0D0 SPNCFC(2,1,1) = -0.25D0/9.0D0 C--unrecognised SUSY process ELSE CALL HWWARN('HWHSPN',503) ENDIF C--LLE processes ELSEIF(IPRO.EQ.8) THEN C--neutralino antineutrino production IF(IK.GE.450.AND.IK.LE.453.AND. & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN C--ensure lepton first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IJ-126)/2 JJJ = (IDHW(LHEP)-119)/2 KKK = (IDHW(MHEP)-125)/2 L1 = IK-449 IDP(5) = 424+2*III DO 11 I=1,2 IDP(5+I) = 423+2*JJJ+(I-1)*12 11 IDP(7+I) = 423+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 21 DRTYPE(2) = 22 DRTYPE(3) = 22 DRTYPE(4) = 23 DRTYPE(5) = 23 C--RPV couplings A(1,1) = ZERO A(2,1) = -LAMDA1(III,JJJ,KKK) DO 12 I=1,2 B(1,I+1) = ZERO B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK) A(1,I+3) = ZERO 12 A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK) C--MSSM couplings DO 13 J=1,2 B(J,1) = AFN(O(J),2*III+6,1,L1) DO 13 I=1,2 A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1) 13 B(J,I+3) = AFN( J ,2*KKK+5,I,L1) C--colour flows NDIA = 5 NCFL(1) = 1 DO 14 I=1,5 14 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE C--neutralino neutrino production ELSEIF(IK.GE.450.AND.IK.LE.453.AND. & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN C--ensure lepton first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IJ-120)/2 JJJ = (IDHW(MHEP)-125)/2 KKK = (IDHW(LHEP)-119)/2 L1 = IK-449 IDP(5) = 424+2*III DO 15 I=1,2 IDP(5+I) = 423+2*JJJ+(I-1)*12 15 IDP(7+I) = 423+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 24 DRTYPE(2) = 25 DRTYPE(3) = 25 DRTYPE(4) = 26 DRTYPE(5) = 26 C--RPV couplings A(1,1) = -LAMDA1(III,JJJ,KKK) A(2,1) = ZERO DO 16 I=1,2 B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK) B(2,I+1) = ZERO A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK) 16 A(2,I+3) = ZERO C--MSSM couplings DO 17 J=1,2 B(J,1) = AFN( J ,2*III+6,1,L1) DO 17 I=1,2 A(J,I+1) = AFN( J ,2*JJJ+5,I,L1) 17 B(J,I+3) = AFN(O(J),2*KKK+5,I,L1) C--colour flows NDIA = 5 NCFL(1) = 1 DO 18 I=1,5 18 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE C--chargino antilepton ELSEIF(IK.GE.456.AND.IK.LE.457.AND. & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN C--ensure lepton first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IJ-125)/2 JJJ = (IDHW(LHEP)-119)/2 KKK = (IDHW(MHEP)-125)/2 L1 = IK-455 IDP(5) = 2*III+424 IDP(6) = 2*JJJ+424 C--RPV couplings A(1,1) = ZERO A(2,1) = LAMDA1(III,JJJ,KKK) B(1,2) = ZERO B(2,2) =-LAMDA1(III,JJJ,KKK) C--MSSM couplings DO 19 J=1,2 B(J,1) = AFC(O(J),2*III+6,1,L1) 19 A(J,2) = AFC(O(J),2*JJJ+6,1,L1) C--colour flows DRTYPE(1) = 21 DRTYPE(2) = 22 NDIA = 2 NCFL(1) = 1 DO 20 I=1,2 20 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE C--chargino lepton ELSEIF(IK.GE.454.AND.IK.LE.455.AND. & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN C--ensure lepton first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IJ-119)/2 JJJ = (IDHW(MHEP)-125)/2 KKK = (IDHW(LHEP)-119)/2 L1 = IK-453 IDP(5) = 2*III+424 IDP(6) = 2*JJJ+424 C--RPV couplings A(1,1) = LAMDA1(III,JJJ,KKK) A(2,1) = ZERO B(1,2) =-LAMDA1(III,JJJ,KKK) B(2,2) = ZERO C--MSSM couplings DO 21 J=1,2 B(J,1) = AFC(J,2*III+6,1,L1) 21 A(J,2) = AFC(J,2*JJJ+6,1,L1) C--colour flows DRTYPE(1) = 24 DRTYPE(2) = 25 NDIA = 2 NCFL(1) = 1 DO 22 I=1,2 22 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE C--e+e- production ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND. & IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN C--ensure incoming lepton first IF(IDHEP(LHEP).LT.0) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--ensure outgoing lepton first IF(IDHEP(KHEP).LT.0) THEN ID = IK IK = IJ IJ = ID ID = KHEP KHEP = JHEP JHEP = ID ENDIF C--only need the correlations for tau production IF(IK.NE.125.AND.IJ.NE.131) RETURN C--find the RPV indices III = (IDHW(LHEP)-119)/2 KKK = (IK-119)/2 LLL = (IJ-125)/2 NDIA = 0 EE = SQRT(HWUAEM(SH)*FOUR*PIFAC) C--s-channel photon and Z exchange if needed IF(KKK.EQ.LLL) THEN NDIA = 2 ID1 = 9+2*III ID2 = 9+2*KKK C--photon first A(1,1) = -EE*QFCH(ID1) A(2,1) = -EE*QFCH(ID1) B(1,1) = -EE*QFCH(ID2) B(2,1) = -EE*QFCH(ID2) IDP(5) = 59 DRTYPE(1) = 4 C--then the Z exchange A(1,2) = -EE*RFCH(ID1) A(2,2) = -EE*LFCH(ID1) B(1,2) = -EE*RFCH(ID2) B(2,2) = -EE*LFCH(ID2) IDP(6) = 200 DRTYPE(2) = 4 ENDIF DO 23 JJJ=1,3 C--s-channel sneutrino exchange IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN NDIA = NDIA+1 DRTYPE(NDIA) = 21 IDP(NDIA+4) = 424+2*JJJ A(1,NDIA) = LAMDA1(III,JJJ,III) A(2,NDIA) = ZERO B(1,NDIA) = ZERO B(2,NDIA) = LAMDA1(LLL,JJJ,KKK) ENDIF C--s-channel antisneutrino exchange IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN NDIA = NDIA+1 DRTYPE(NDIA) = 21 IDP(NDIA+4) = 424+2*JJJ A(1,NDIA) = ZERO A(2,NDIA) = LAMDA1(III,JJJ,III) B(1,NDIA) = LAMDA1(KKK,JJJ,LLL) B(2,NDIA) = ZERO ENDIF C--t-channel sneutrino exchange IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN NDIA = NDIA+1 DRTYPE(NDIA) = 22 IDP(NDIA+4) = 424+2*JJJ A(1,NDIA) = LAMDA1(KKK,JJJ,III) A(2,NDIA) = ZERO B(1,NDIA) = ZERO B(2,NDIA) = LAMDA1(LLL,JJJ,III) ENDIF C--t-channel antisneutrino exchange IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN NDIA = NDIA+1 DRTYPE(NDIA) = 22 IDP(NDIA+4) = 424+2*JJJ A(1,NDIA) = ZERO A(2,NDIA) = LAMDA1(III,JJJ,KKK) B(1,NDIA) = LAMDA1(III,JJJ,LLL) B(2,NDIA) = ZERO ENDIF 23 CONTINUE C--setup the colour flow NCFL(1) = 1 SPNCFC(1,1,1) = ONE DO 24 I=1,NDIA 24 IFLOW(I) = 1 C--d dbar production ELSEIF(IK.LE.12.AND.IK.LE.12.AND. & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN C--can't produce quark which decays before hadronization RETURN C--unrecognised process ELSE CALL HWWARN('HWHSPN',504) ENDIF C--LQD processes ELSEIF(IPRO.EQ.40) THEN C--change outgoing order ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID C--neutrino neutralino production IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND. & IDPDG(IJ).GT.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV coupling III = (IJ-120)/2 JJJ = (IDHW(MHEP)-5)/2 KKK = (IDHW(LHEP)+1)/2 L1 = IK - 449 IDP(5) = 424+2*III DO 25 I=1,2 IDP(5+I) = 399+2*JJJ+(I-1)*12 25 IDP(7+I) = 399+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 24 DRTYPE(2) = 25 DRTYPE(3) = 25 DRTYPE(4) = 26 DRTYPE(5) = 26 C--RPV couplings A(1,1) = -LAMDA2(III,JJJ,KKK) A(2,1) = ZERO DO 26 I=1,2 B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK) B(2,I+1) = ZERO A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK) 26 A(2,I+3) = ZERO C--MSSM couplings DO 27 J=1,2 B(J,1) = AFN( J ,2*III+6,1,L1) DO 27 I=1,2 A(J,I+1) = AFN( J ,2*JJJ-1,I,L1) 27 B(J,I+3) = AFN(O(J),2*KKK-1,I,L1) C--colour flows NDIA = 5 NCFL(1) = 1 DO 28 I=1,5 28 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C--antineutrino neutralino production ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND. & IDPDG(IJ).LT.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV coupling III = (IJ-126)/2 JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK - 449 IDP(5) = 424+2*III DO 29 I=1,2 IDP(5+I) = 399+2*JJJ+(I-1)*12 29 IDP(7+I) = 399+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 21 DRTYPE(2) = 22 DRTYPE(3) = 22 DRTYPE(4) = 23 DRTYPE(5) = 23 C--RPV couplings A(1,1) = ZERO A(2,1) = -LAMDA2(III,JJJ,KKK) DO 30 I=1,2 B(1,I+1) = ZERO B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK) A(1,I+3) = ZERO 30 A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK) C--MSSM couplings DO 31 J=1,2 B(J,1) = AFN(O(J),2*III+6,1,L1) DO 31 I=1,2 A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1) 31 B(J,I+3) = AFN( J ,2*KKK-1,I,L1) C--colour flows NDIA = 5 NCFL(1) = 1 DO 32 I=1,5 32 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C--lepton neutralino production ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND. & IDPDG(IJ).GT.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV coupling III = (IJ-119)/2 JJJ = (IDHW(MHEP)-6)/2 KKK = (IDHW(LHEP)+1)/2 L1 = IK - 449 DO 33 I=1,2 IDP(4+I) = 423+2*III+(I-1)*12 IDP(6+I) = 400+2*JJJ+(I-1)*12 33 IDP(8+I) = 399+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 24 DRTYPE(2) = 24 DRTYPE(3) = 25 DRTYPE(4) = 25 DRTYPE(5) = 26 DRTYPE(6) = 26 C--RPV couplings DO 34 I=1,2 A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK) A(2,I ) = 0.0D0 B(1,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK) B(2,I+2) = 0.0D0 A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK) A(2,I+4) = 0.0D0 C--MSSM couplings DO 34 J=1,2 B(J,I ) = AFN( J ,2*III+5,I,L1) A(J,I+2) = AFN( J ,2*JJJ ,I,L1) 34 B(J,I+4) = AFN(O(J),2*KKK-1,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 35 I=1,6 35 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C--antilepton neutralino production ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND. & IDPDG(IJ).LT.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV coupling III = (IJ-125)/2 JJJ = IDHW(LHEP)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK - 449 DO 36 I=1,2 IDP(4+I) = 423+2*III+(I-1)*12 IDP(6+I) = 400+2*JJJ+(I-1)*12 36 IDP(8+I) = 399+2*KKK+(I-1)*12 C--types of diagram DRTYPE(1) = 21 DRTYPE(2) = 21 DRTYPE(3) = 22 DRTYPE(4) = 22 DRTYPE(5) = 23 DRTYPE(6) = 23 C--RPV couplings DO 37 I=1,2 A(1,I ) = 0.0D0 A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK) B(1,I+2) = 0.0D0 B(2,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK) A(1,I+4) = 0.0D0 A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK) C--MSSM couplings DO 37 J=1,2 B(J,I ) = AFN(O(J),2*III+5,I,L1) A(J,I+2) = AFN(O(J),2*JJJ ,I,L1) 37 B(J,I+4) = AFN( J ,2*KKK-1,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 39 I=1,6 39 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C-- +ve chargino antineutrino ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV III = (IJ-126)/2 JJJ = IDHW(LHEP)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK-453 DO 40 I=1,2 IDP(4+I) = 423+2*III+(I-1)*12 40 IDP(6+I) = 399+2*JJJ+(I-1)*12 C--types of diagram DRTYPE(1) = 21 DRTYPE(2) = 21 DRTYPE(3) = 22 DRTYPE(4) = 22 DO 41 I=1,2 C--RPV couplings A(1,I ) = ZERO A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK) B(1,I+2) = ZERO B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK) C--MSSM couplings DO 41 J=1,2 B(J,I ) = AFC(O(J),2*III+5,I,L1) 41 A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1) C--colour flows NDIA = 4 NCFL(1) = 1 DO 42 I=1,4 42 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C-- -ve chargino neutrino ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV III = (IJ-120)/2 JJJ = (IDHW(MHEP)-6)/2 KKK = (IDHW(LHEP)+1)/2 L1 = IK-455 DO 43 I=1,2 IDP(4+I) = 423+2*III+(I-1)*12 43 IDP(6+I) = 399+2*JJJ+(I-1)*12 C--types of diagram DRTYPE(1) = 24 DRTYPE(2) = 24 DRTYPE(3) = 25 DRTYPE(4) = 25 DO 44 I=1,2 C--RPV couplings A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK) A(2,I ) = ZERO B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK) B(2,I+2) = ZERO C--MSSM couplings DO 44 J=1,2 B(J,I ) = AFC(J,2*III+5,I,L1) 44 A(J,I+2) = AFC(J,2*JJJ-1,I,L1) C--colour flows NDIA = 4 NCFL(1) = 1 DO 45 I=1,4 45 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C-- -ve chargino antilepton ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV III = (IJ-125)/2 JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK-455 IDP(5) = 424+2*III DO 46 I=1,2 46 IDP(5+I) = 400+2*JJJ+(I-1)*12 C--types of diagram DRTYPE(1) = 21 DRTYPE(2) = 22 DRTYPE(3) = 22 C--RPV couplings A(1,1) = 0.0D0 A(2,1) =-LAMDA2(III,JJJ,KKK) DO 47 I=1,2 B(1,I+1) = 0.0D0 47 B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK) C--MSSM couplings DO 48 J=1,2 B(J,1) = AFC(O(J),2*III+6,1,L1) DO 48 I=1,2 48 A(J,I+1) = AFC(O(J),2*JJJ,I,L1) C--colour flows NDIA = 3 NCFL(1) = 1 DO 49 I=1,3 49 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C-- +ve chargino lepton ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN C--change order if antiparticle first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--indices for RPV III = (IJ-119)/2 JJJ = (IDHW(MHEP)-5)/2 KKK = (IDHW(LHEP)+1)/2 L1 = IK-453 IDP(5) = 424+2*III DO 50 I=1,2 50 IDP(5+I) = 400+2*JJJ+(I-1)*12 C--types of diagram DRTYPE(1) = 24 DRTYPE(2) = 25 DRTYPE(3) = 25 C--RPV couplings A(1,1) =-LAMDA2(III,JJJ,KKK) A(2,1) = 0.0D0 DO 51 I=1,2 B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK) 51 B(2,I+1) = 0.0D0 C--MSSM couplings DO 52 J=1,2 B(J,1) = AFC(J,2*III+6,1,L1) DO 52 I=1,2 52 A(J,I+1) = AFC(J,2*JJJ,I,L1) C--colour flows NDIA = 3 NCFL(1) = 1 DO 53 I=1,3 53 IFLOW(I) = 1 SPNCFC(1,1,1) = ONE/THREE C--d dbar d dbar ELSEIF(IK.LE.12.AND.IJ.LE.12.AND. & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN C--can't produce unstable quark (on hadronization timescale) RETURN C--u dbar --> u dbar ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND. & IK.LE.12.AND.MOD(IK,2).EQ.1).OR. & (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND. & IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN C--ensure u first (incoming) IF(MOD(IDHW(LHEP),2).EQ.1) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--ensure u first (outgoing) IF(MOD(IK,2).EQ.1) THEN ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--can't produce unstable quark (on hadronization timescale) IF(IK.NE.6) RETURN C--RPV indices JJJ = IDHW(LHEP)/2 KKK = (IDHW(MHEP)-5)/2 LLL = IK/2 MMM = (IJ-5)/2 NDIA = 0 DO 54 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS) & GOTO 54 DO 55 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 423+2*III+12*(J-1) A(1,NDIA+J) = ZERO A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J) B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J) B(2,NDIA+J) = ZERO 55 DRTYPE(NDIA+J) = 21 NDIA = NDIA+2 54 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE C--ubar d --> ubar d ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND. & IK.LE. 6.AND.MOD(IK,2).EQ.1).OR. & (IK.LE.12.AND.MOD(IK,2).EQ.0.AND. & IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN C--ensure d first (incoming) IF(MOD(IDHW(LHEP),2).EQ.0) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--ensure d first (outgoing) IF(MOD(IK,2).EQ.0) THEN ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--can't produce unstable quark (on hadronization timescale) IF(IJ.NE.12) RETURN C--RPV indices JJJ = (IDHW(MHEP)-6)/2 KKK = (IDHW(LHEP)+1)/2 LLL = (IJ-6)/2 MMM = (IK+1)/2 NDIA = 0 DO 56 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS) & GOTO 56 DO 57 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 423+2*III+12*(J-1) A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J) A(2,NDIA+J) = ZERO B(1,NDIA+J) = ZERO B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J) 57 DRTYPE(NDIA+J) = 21 NDIA = NDIA+2 56 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE C--d dbar --> ell- ell+ ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND. & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND. & IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND. & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN C--change outgoing order ID = IK IK = IJ IJ = ID ID = JHEP JHEP = KHEP KHEP = ID C--change order if dbar first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--don't do correlations if no taus IF(IK.NE.125.AND.IJ.NE.131) RETURN C--RPV couplings JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)-5)/2 LLL = (IK-119)/2 MMM = (IJ-125)/2 NDIA = 0 DO 58 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS) & GOTO 58 NDIA = NDIA+1 IFLOW(NDIA) = 1 IDP(4+NDIA) = 424+2*III A(1,NDIA) = ZERO A(2,NDIA) = LAMDA2(III,JJJ,KKK) B(1,NDIA) = LAMDA1(III,LLL,MMM) B(2,NDIA) = ZERO DRTYPE(NDIA) = 21 58 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--dbar d --> ell+ ell- ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND. & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND. & IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND. & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN C--change order if dbar first IF(IDHEP(LHEP).LT.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--don't do correlations if no taus IF(IK.NE.125.AND.IJ.NE.131) RETURN C--RPV couplings JJJ = (IDHW(MHEP)-5)/2 KKK = (IDHW(LHEP)+1)/2 LLL = (IJ-125)/2 MMM = (IK-119)/2 NDIA = 0 DO 59 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS) & GOTO 59 NDIA = NDIA+1 IFLOW(NDIA) = 1 IDP(4+NDIA) = 424+2*III A(1,NDIA) = LAMDA2(III,JJJ,KKK) A(2,NDIA) = ZERO B(1,NDIA) = ZERO B(2,NDIA) = LAMDA1(III,LLL,MMM) DRTYPE(NDIA) = 21 59 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--u dbar --> nu ell+ ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND. & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR. & (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND. & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN C--ensure u first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--ensure nu first IF(MOD(IK,2).NE.0) THEN ID = IK IK = IJ IJ = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--only need correlations if tau IF(IJ.NE.131) RETURN C--RPV couplings JJJ = IDHW(LHEP)/2 KKK = (IDHW(MHEP)-5)/2 LLL = (IK-120)/2 MMM = (IJ-125)/2 NDIA = 0 DO 60 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS) & GOTO 60 DO 61 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 423+2*III+12*(J-1) A(1,NDIA+J) = ZERO A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J) B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J) B(2,NDIA+J) = ZERO 61 DRTYPE(NDIA+J) = 21 NDIA = NDIA+2 60 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--ubar d --> ell nubar ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND. & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR. & (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND. & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN C--ensure u second IF(MOD(IDHW(MHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C-- ensure nu second IF(MOD(IJ,2).NE.0) THEN ID = IK IK = IJ IJ = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--only need correlations if tau IF(IK.NE.125) RETURN C--RPV couplings JJJ = (IDHW(MHEP)-6)/2 KKK = (IDHW(LHEP)+1)/2 LLL = (IJ-126)/2 MMM = (IK-119)/2 NDIA = 0 DO 62 III=1,3 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS) & GOTO 62 DO 63 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 423+2*III+12*(J-1) A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J) A(2,NDIA+J) = ZERO B(1,NDIA+J) = ZERO B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J) 63 DRTYPE(NDIA+J) = 21 NDIA = NDIA+2 62 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--unrecognized process ELSE CALL HWWARN('HWHSPN',505) ENDIF C--UDD processes ELSEIF(IPRO.EQ.41) THEN C--change outgoing order ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID C--ubar neutralino IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND. & IDPDG(IJ).LT.0) THEN C--indices for RPV III = (IJ-6)/2 JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)+1)/2 L1 = IK - 449 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 DRTYPE(5) = 29 DRTYPE(6) = 29 C--RPV couplings DO 64 J=1,2 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK) A(2,J ) = ZERO B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK) B(2,J+2) = ZERO A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK) A(2,J+4) = ZERO C--particles IDP(4+J) = 400+2*III+12*(J-1) IDP(6+J) = 399+2*JJJ+12*(J-1) IDP(8+J) = 399+2*KKK+12*(J-1) C--MSSM couplings DO 64 I=1,2 B(I,J) = AFN(O(I),2*III,J,L1) A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1) 64 B(I,J+4) = AFN(O(I),2*KKK-1,J,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 65 I=1,6 65 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--u neutralino ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND. & IDPDG(IJ).GT.0) THEN C--indices for RPV III = IJ/2 JJJ = (IDHW(LHEP)-5)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK - 449 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 DRTYPE(5) = 32 DRTYPE(6) = 32 C--RPV couplings DO 66 J=1,2 A(1,J ) = ZERO A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK) B(1,J+2) = ZERO B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK) A(1,J+4) = ZERO A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK) C--particles IDP(4+J) = 400+2*III+12*(J-1) IDP(6+J) = 399+2*JJJ+12*(J-1) IDP(8+J) = 399+2*KKK+12*(J-1) C--MSSM couplings DO 66 I=1,2 B(I,J) = AFN(I,2*III,J,L1) A(I,J+2) = AFN(I,2*JJJ-1,J,L1) 66 B(I,J+4) = AFN(I,2*KKK-1,J,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 67 I=1,6 67 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--dbar neutralino ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND. & IDPDG(IJ).LT.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = IDHW(LHEP)/2 JJJ = (IDHW(MHEP)+1)/2 KKK = (IJ-5)/2 L1 = IK - 449 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 DRTYPE(5) = 29 DRTYPE(6) = 29 C--RPV couplings DO 68 I=1,2 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) A(2,I ) = ZERO B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) B(2,I+2) = ZERO A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK) A(2,I+4) = ZERO C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 400+2*III+12*(I-1) IDP(8+I) = 399+2*JJJ+12*(I-1) C--MSSM couplings DO 68 J=1,2 B(J,I ) = AFN(O(J),2*KKK-1,I,L1) A(J,I+2) = AFN(O(J),2*III ,I,L1) 68 B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 69 I=1,6 69 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--d neutralino ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND. & IDPDG(IJ).GT.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IDHW(LHEP)-6)/2 JJJ = (IDHW(MHEP)-5)/2 KKK = (IJ+1)/2 L1 = IK - 449 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 DRTYPE(5) = 32 DRTYPE(6) = 32 C--RPV couplings DO 70 I=1,2 A(1,I ) = ZERO A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) B(1,I+2) = ZERO B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) A(1,I+4) = ZERO A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK) C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 400+2*III+12*(I-1) IDP(8+I) = 399+2*JJJ+12*(I-1) C--MSSM couplings DO 70 J=1,2 B(J,I ) = AFN(J,2*KKK-1,I,L1) A(J,I+2) = AFN(J,2*III ,I,L1) 70 B(J,I+4) = AFN(J,2*JJJ-1,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 71 I=1,6 71 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--ubar gluino ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN C--indices for RPV III = (IJ-6)/2 JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)+1)/2 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 DRTYPE(5) = 29 DRTYPE(6) = 29 C--RPV couplings DO 72 J=1,2 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK) A(2,J ) = ZERO B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK) B(2,J+2) = ZERO A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK) A(2,J+4) = ZERO C--particles IDP(4+J) = 400+2*III+12*(J-1) IDP(6+J) = 399+2*JJJ+12*(J-1) IDP(8+J) = 399+2*KKK+12*(J-1) C--MSSM couplings DO 72 I=1,2 B(I,J) = AFG(O(I),2*III,J) A(I,J+2) = AFG(O(I),2*JJJ-1,J) 72 B(I,J+4) = AFG(O(I),2*KKK-1,J) C--colour flows NDIA = 6 NCFL(1) = 3 DO 73 I=1,2 IFLOW(I ) = 1 IFLOW(I+2) = 2 73 IFLOW(I+4) = 3 DO 74 I=1,3 DO 74 J=1,3 IF(I.EQ.J) THEN SPNCFC(I,J,1) = 8.0D0/9.0D0 ELSE SPNCFC(I,J,1) =-4.0D0/9.0D0 ENDIF 74 CONTINUE C--u gluino ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN C--indices for RPV III = IJ/2 JJJ = (IDHW(LHEP)-5)/2 KKK = (IDHW(MHEP)-5)/2 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 DRTYPE(5) = 32 DRTYPE(6) = 32 C--RPV couplings DO 75 J=1,2 A(1,J ) = ZERO A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK) B(1,J+2) = ZERO B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK) A(1,J+4) = ZERO A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK) C--particles IDP(4+J) = 400+2*III+12*(J-1) IDP(6+J) = 399+2*JJJ+12*(J-1) IDP(8+J) = 399+2*KKK+12*(J-1) C--MSSM couplings DO 75 I=1,2 B(I,J) = AFG(I,2*III,J) A(I,J+2) = AFG(I,2*JJJ-1,J) 75 B(I,J+4) = AFG(I,2*KKK-1,J) C--colour flows NDIA = 6 NCFL(1) = 3 DO 76 I=1,2 IFLOW(I ) = 1 IFLOW(I+2) = 2 76 IFLOW(I+4) = 3 DO 77 I=1,3 DO 77 J=1,3 IF(I.EQ.J) THEN SPNCFC(I,J,1) = 8.0D0/9.0D0 ELSE SPNCFC(I,J,1) =-4.0D0/9.0D0 ENDIF 77 CONTINUE C--dbar gluino ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = IDHW(LHEP)/2 JJJ = (IDHW(MHEP)+1)/2 KKK = (IJ-5)/2 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 DRTYPE(5) = 29 DRTYPE(6) = 29 C--RPV couplings DO 78 I=1,2 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) A(2,I ) = ZERO B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) B(2,I+2) = ZERO A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK) A(2,I+4) = ZERO C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 400+2*III+12*(I-1) IDP(8+I) = 399+2*JJJ+12*(I-1) C--MSSM couplings DO 78 J=1,2 B(J,I ) = AFG(O(J),2*KKK-1,I) A(J,I+2) = AFG(O(J),2*III ,I) 78 B(J,I+4) = AFG(O(J),2*JJJ-1,I) C--colour flows NDIA = 6 NCFL(1) = 3 DO 79 I=1,2 IFLOW(I ) = 1 IFLOW(I+2) = 2 79 IFLOW(I+4) = 3 DO 80 I=1,3 DO 80 J=1,3 IF(I.EQ.J) THEN SPNCFC(I,J,1) = 8.0D0/9.0D0 ELSE SPNCFC(I,J,1) =-4.0D0/9.0D0 ENDIF 80 CONTINUE C--d gluino ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IDHW(LHEP)-6)/2 JJJ = (IDHW(MHEP)-5)/2 KKK = (IJ+1)/2 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 DRTYPE(5) = 32 DRTYPE(6) = 32 C--RPV couplings DO 81 I=1,2 A(1,I ) = ZERO A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) B(1,I+2) = ZERO B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) A(1,I+4) = ZERO A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK) C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 400+2*III+12*(I-1) IDP(8+I) = 399+2*JJJ+12*(I-1) C--MSSM couplings DO 81 J=1,2 B(J,I ) = AFG(J,2*KKK-1,I) A(J,I+2) = AFG(J,2*III ,I) 81 B(J,I+4) = AFG(J,2*JJJ-1,I) C--colour flows NDIA = 6 NCFL(1) = 3 DO 82 I=1,2 IFLOW(I ) = 1 IFLOW(I+2) = 2 82 IFLOW(I+4) = 3 DO 83 I=1,3 DO 83 J=1,3 IF(I.EQ.J) THEN SPNCFC(I,J,1) = 8.0D0/9.0D0 ELSE SPNCFC(I,J,1) =-4.0D0/9.0D0 ENDIF 83 CONTINUE C--dbar -ve chargino ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN C--change order so highest generation first IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--RPV indices III = (IJ-5)/2 JJJ = (IDHW(LHEP)+1)/2 KKK = (IDHW(MHEP)+1)/2 L1 = IK-455 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 DRTYPE(5) = 29 DRTYPE(6) = 29 C--RPV couplings DO 84 I=1,2 A(1,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) A(2,I ) = ZERO B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III) B(2,I+2) = ZERO A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ) A(2,I+4) = ZERO C--particles IDP(4+I) = 400+2*III+12*(I-1) IDP(6+I) = 400+2*JJJ+12*(I-1) IDP(8+I) = 400+2*KKK+12*(I-1) C--MSSM couplings DO 84 J=1,2 B(J,I ) = AFC(O(J),2*III,I,L1) A(J,I+2) = AFC(O(J),2*JJJ,I,L1) 84 B(J,I+4) = AFC(O(J),2*KKK,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 85 I=1,6 85 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--d +ve chargino ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN C--change order so highest generation first IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--RPV indices III = (IJ+1)/2 JJJ = (IDHW(LHEP)-5)/2 KKK = (IDHW(MHEP)-5)/2 L1 = IK-453 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 DRTYPE(5) = 32 DRTYPE(6) = 32 C--RPV couplings DO 86 I=1,2 A(1,I ) = ZERO A(2,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK) B(1,I+2) = ZERO B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III) A(1,I+4) = ZERO A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ) C--particles IDP(4+I) = 400+2*III+12*(I-1) IDP(6+I) = 400+2*JJJ+12*(I-1) IDP(8+I) = 400+2*KKK+12*(I-1) C--MSSM couplings DO 86 J=1,2 B(J,I ) = AFC(J,2*III,I,L1) A(J,I+2) = AFC(J,2*JJJ,I,L1) 86 B(J,I+4) = AFC(J,2*KKK,I,L1) C--colour flows NDIA = 6 NCFL(1) = 1 DO 87 I=1,6 87 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--ubar +ve chargino ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = IDHW(LHEP)/2 JJJ = (IDHW(MHEP)+1)/2 KKK = (IJ-6)/2 L1 = IK-453 C--types of diagram DRTYPE(1) = 27 DRTYPE(2) = 27 DRTYPE(3) = 28 DRTYPE(4) = 28 C--RPV couplings DO 88 I=1,2 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) A(2,I ) = ZERO B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ) B(2,I+2) = ZERO C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 399+2*III+12*(I-1) C--MSSM couplings DO 88 J=1,2 B(J,I ) = AFC(O(J),2*KKK-1,I,L1) 88 A(J,I+2) = AFC(O(J),2*III-1,I,L1) C--colour flows NDIA = 4 NCFL(1) = 1 DO 89 I=1,4 89 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--u -ve chargino ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN C--ensure u type first IF(MOD(IDHW(LHEP),2).NE.0) THEN ID = LHEP LHEP = MHEP MHEP = ID ENDIF C--RPV indices III = (IDHW(LHEP)-6)/2 JJJ = (IDHW(MHEP)-5)/2 KKK = IJ/2 L1 = IK-455 C--types of diagram DRTYPE(1) = 30 DRTYPE(2) = 30 DRTYPE(3) = 31 DRTYPE(4) = 31 C--RPV couplings DO 90 I=1,2 A(1,I ) = ZERO A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK) B(1,I+2) = ZERO B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ) C--particles IDP(4+I) = 399+2*KKK+12*(I-1) IDP(6+I) = 399+2*III+12*(I-1) C--MSSM couplings DO 90 J=1,2 B(J,I ) = AFC(J,2*KKK-1,I,L1) 90 A(J,I+2) = AFC(J,2*III-1,I,L1) C--colour flows NDIA = 4 NCFL(1) = 1 DO 91 I=1,4 91 IFLOW(I) = 1 SPNCFC(1,1,1) = TWO/THREE C--d d --> d d ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND. & MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN C--can't produce unstable quark on hadronisation timescale RETURN C--dbar dbar --> dbar dbar ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND. & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN C--can't produce unstable quark on hadronisation timescale RETURN C--u d --> u d ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND. & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR. & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN C--ensure u first (incoming) IF(MOD(IDHW(LHEP),2).EQ.1) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--ensure u first (outgoing) IF(MOD(IK,2).EQ.1) THEN ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--can't produce unstable quark on hadronisation timescale IF(IK.NE.6) RETURN C--RPV indices III = IDHW(LHEP)/2 KKK = (IDHW(MHEP)+1)/2 LLL = IK/2 MMM = (IJ+1)/2 NDIA = 0 DO 92 JJJ=1,3 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS) & GOTO 92 DO 93 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1) A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J) A(2,NDIA+J) = ZERO B(1,NDIA+J) = ZERO B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J) 93 DRTYPE(NDIA+J) = 33 NDIA = NDIA+2 92 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--ubar dbar --> ubar dbar ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND. & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR. & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN C--ensure u first (incoming) IF(MOD(IDHW(LHEP),2).EQ.1) THEN ID = MHEP MHEP = LHEP LHEP = ID ENDIF C--ensure u first (outgoing) IF(MOD(IK,2).EQ.1) THEN ID = IJ IJ = IK IK = ID ID = JHEP JHEP = KHEP KHEP = ID ENDIF C--can't produce unstable quark on hadronisation timescale IF(IK.NE.6) RETURN C--RPV indices III = (IDHW(LHEP)-6)/2 KKK = (IDHW(MHEP)-5)/2 LLL = (IK-6)/2 MMM = (IJ-5)/2 NDIA = 0 DO 94 JJJ=1,3 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS) & GOTO 94 DO 95 J=1,2 IFLOW(NDIA+J) = 1 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1) A(1,NDIA+J) = ZERO A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J) B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J) B(2,NDIA+J) = ZERO 95 DRTYPE(NDIA+J) = 34 NDIA = NDIA+2 94 CONTINUE NCFL(1) = 1 SPNCFC(1,1,1) = ONE/THREE C--unrecognized process ELSE CALL HWWARN('HWHSPN',506) ENDIF C--unrecognized process ELSE CALL HWWARN('HWHSPN',507) ENDIF C--copy the momenta into the internal array CALL HWVEQU(5,PHEP(1,LHEP),P(1,1)) CALL HWVEQU(5,PHEP(1,MHEP),P(1,2)) CALL HWVEQU(5,PHEP(1,KHEP),P(1,3)) CALL HWVEQU(5,PHEP(1,JHEP),P(1,4)) C--now compute the masses etc for the diagrams IDP(1) = IDHW(LHEP) IDP(2) = IDHW(MHEP) IDP(3) = IDHW(KHEP) IDP(4) = IDHW(JHEP) DO 104 I=1,4 MA (I) = P(5,I) 104 MA2(I) = SIGN(MA(I)**2,MA(I)) DO 105 I=1,NDIA MR(I) = RMASS(IDP(4+I)) MS(I) = MR(I)**2 IF(IDP(I+4).EQ.200) THEN MWD(I) = RMASS(200)*GAMZ ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN MWD(I) = RMASS(198)*GAMW ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR. & IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN MR(I) = ZERO MS(I) = ZERO MWD(I) = ZERO ELSE MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4)) ENDIF 105 CONTINUE C--set up the mandelstam variables SH = TWO*HWULDO(P(1,1),P(1,2)) CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2)) CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1)) TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3)) UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4)) C--copy the momenta into the common block for spinor computation DO 106 I=1,4 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN CALL HWVEQU(5,PREF,PLAB(1,I+4)) C--all other particles ELSE PP = SQRT(HWVDOT(3,P(1,I),P(1,I))) CALL HWVSCA(3,ONE/PP,P(1,I),N) PLAB(4,I+4) = HALF*(P(4,I)-PP) PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I))) CALL HWVSCA(3,PP,N,PLAB(1,I+4)) CALL HWUMAS(PLAB(1,I+4)) PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4)) C--fix to avoid problems if approx massless due to energy IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4)) ENDIF C--now the massless vectors PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I)) DO 107 J=1,4 107 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4) 106 CALL HWUMAS(PLAB(1,I)) C--change order of momenta for call to HE code DO 108 I=1,4 PM(1,I) = P(3,I) PM(2,I) = P(1,I) PM(3,I) = P(2,I) PM(4,I) = P(4,I) 108 PM(5,I) = P(5,I) DO 109 I=1,8 PCM(1,I)=PLAB(3,I) PCM(2,I)=PLAB(1,I) PCM(3,I)=PLAB(2,I) PCM(4,I)=PLAB(4,I) 109 PCM(5,I)=PLAB(5,I) C--compute the S functions CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D) DO 110 I=1,8 DO 110 J=1,8 S(I,J,2) = -S(I,J,2) 110 D(I,J) = TWO*D(I,J) C--compute the F functions CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3)) CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4)) CALL HWH2F1(8,F4M,8,PM(1,4), MA(4)) CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3)) C--t and u channel functions C--first the t channel ones CALL HWVSCA(4,-ONE,PM(1,4),PTMP) CALL HWVSUM(4,PM(1,2),PTMP,PTMP) CALL HWUMAS(PTMP) CALL HWH2F3(8,FTP,PTMP, MR(1)) CALL HWH2F3(8,FTM,PTMP,-MR(1)) C--then the u-channel ones CALL HWVSCA(4,-ONE,PM(1,4),PTMP) CALL HWVSUM(4,PM(1,1),PTMP,PTMP) CALL HWUMAS(PTMP) CALL HWH2F3(8,FUP,PTMP, MR(1)) CALL HWH2F3(8,FUM,PTMP,-MR(1)) C--function for t-channel scalar exchange CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP) CALL HWUMAS(PTMP) CALL HWH2F1(8,FST,2,PTMP,ZERO) C--compute the prefactor for all diagrams PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4)) PRE = ONE/SQRT(PRE) C--zero the matrix element DO 200 P1=1,2 DO 200 P2=1,2 DO 200 P3=1,2 DO 200 P4=1,2 DO 200 I=1,NCFL(1) 200 ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0) C--now call the subroutines to compute the individual diagrams DO 210 I=1,NDIA C--s-channel vector boson exchange diagram (f fbar to fermion fermion) IF(DRTYPE(I).EQ.1) THEN CALL HWHS01(I,MED) C--t-channel sfermion exchange diagram (f fbar to fermion fermion) ELSEIF(DRTYPE(I).EQ.2) THEN CALL HWHS02(I,MED) C--u-channel sfermion exchange diagram(f fbar to fermion fermion) ELSEIF(DRTYPE(I).EQ.3) THEN CALL HWHS03(I,MED) C--s-channel vector boson (f fbar to fermion antifermion) ELSEIF(DRTYPE(I).EQ.4) THEN CALL HWHS04(I,MED) C--t-channel fermion exchange (g g to fermion antifermion) ELSEIF(DRTYPE(I).EQ.5) THEN CALL HWHS05(I,MED) C--u-channel fermion exchange (g g to fermion antifermion) ELSEIF(DRTYPE(I).EQ.6) THEN CALL HWHS06(I,MED) C--s-channel gluon exchange (g g to fermion antifermion) ELSEIF(DRTYPE(I).EQ.7) THEN CALL HWHS07(I,MED) C--t-channel sfermion exchange (g q to fermion sfermion) ELSEIF(DRTYPE(I).EQ.8) THEN CALL HWHS08(I,MED) C--t-channel sfermion exchange (g qbar to fermion antisfermion) ELSEIF(DRTYPE(I).EQ.9) THEN CALL HWHS09(I,MED) C--s-channel quark exchange (g q to fermion antisfermion) ELSEIF(DRTYPE(I).EQ.10) THEN CALL HWHS10(I,MED) C--s-channel antiquark exchange (g qbar to fermion antisfermion) ELSEIF(DRTYPE(I).EQ.11) THEN CALL HWHS11(I,MED) C--u-channel gluino exchange (g q to fermion antisfermion) ELSEIF(DRTYPE(I).EQ.12) THEN CALL HWHS12(I,MED) C--u-channel gluino exchange (g qbar to fermion antisfermion) ELSEIF(DRTYPE(I).EQ.13) THEN CALL HWHS13(I,MED) C--t-channel fermion exchange (g g to fermion fermion) ELSEIF(DRTYPE(I).EQ.14) THEN CALL HWHS14(I,MED) C--u-channel fermion exchange (g g to fermion fermion) ELSEIF(DRTYPE(I).EQ.15) THEN CALL HWHS15(I,MED) C--s-channel gluon exchange (g g to fermion fermion) ELSEIF(DRTYPE(I).EQ.16) THEN CALL HWHS16(I,MED) C--t-channel gauge boson exchange (fermion fermion) ELSEIF(DRTYPE(I).EQ.17) THEN CALL HWHS17(I,MED) C--t-channel gauge boson exchange (fermion antifermion) ELSEIF(DRTYPE(I).EQ.18) THEN CALL HWHS18(I,MED) C--t-channel gauge boson exchange (antifermion fermion) ELSEIF(DRTYPE(I).EQ.19) THEN CALL HWHS19(I,MED) C--t-channel gauge boson exchange (antifermion antifermion) ELSEIF(DRTYPE(I).EQ.20) THEN CALL HWHS20(I,MED) C--s-channel scalar exchange (f fbar --> f fbar) ELSEIF(DRTYPE(I).EQ.21) THEN CALL HWHS21(I,MED) C--t-channel scalar exchange (f fbar --> f fbar) ELSEIF(DRTYPE(I).EQ.22) THEN CALL HWHS22(I,MED) C--u-channel scalar exchange (f fbar --> f fbar) ELSEIF(DRTYPE(I).EQ.23) THEN CALL HWHS23(I,MED) C--s-channel scalar exchange (fbar f --> f f) ELSEIF(DRTYPE(I).EQ.24) THEN CALL HWHS24(I,MED) C--t-channel scalar exchange (fbar f --> f f) ELSEIF(DRTYPE(I).EQ.25) THEN CALL HWHS25(I,MED) C--u-channel scalar exchange (fbar f --> f f) ELSEIF(DRTYPE(I).EQ.26) THEN CALL HWHS26(I,MED) C--s-channel scalar exchange (f f --> f fbar) ELSEIF(DRTYPE(I).EQ.27) THEN CALL HWHS27(I,MED) C--t-channel scalar exchange (f f --> f fbar) ELSEIF(DRTYPE(I).EQ.28) THEN CALL HWHS28(I,MED) C--u-channel scalar exchange (f f --> f fbar) ELSEIF(DRTYPE(I).EQ.29) THEN CALL HWHS29(I,MED) C--s-channel scalar exchange (fbar fbar --> f f) ELSEIF(DRTYPE(I).EQ.30) THEN CALL HWHS30(I,MED) C--t-channel scalar exchange (fbar fbar --> f f) ELSEIF(DRTYPE(I).EQ.31) THEN CALL HWHS31(I,MED) C--u-channel scalar exchange (fbar fbar --> f f) ELSEIF(DRTYPE(I).EQ.32) THEN CALL HWHS32(I,MED) C--s-channel scalar exchange (f f --> f f) ELSEIF(DRTYPE(I).EQ.33) THEN CALL HWHS33(I,MED) C--s-channel scalar exchange (fbar fbar --> fbar fbar) ELSEIF(DRTYPE(I).EQ.34) THEN CALL HWHS34(I,MED) C--error not known ELSE CALL HWWARN('HWHSPN',508) ENDIF C--add up the matrix elements DO 210 P1=1,2 DO 210 P2=1,2 DO 210 P3=1,2 DO 210 P4=1,2 210 ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I)) & +MED(P1,P2,P3,P4) C--preform the final normalisation DO 215 P1=1,2 DO 215 P2=1,2 DO 215 P3=1,2 DO 215 P4=1,2 DO 215 I=1,NCFL(1) 215 ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I) C--now enter the matrix element in the spin common block NSPN = 1 IDSPN(1) = ICM ISNHEP(ICM) = 1 JMOSPN(1) = 0 JDASPN(1,1) = 2 JDASPN(2,1) = 3 DECSPN(1) = .FALSE. DO 225 P1=1,2 DO 225 P2=1,2 DO 225 P3=1,2 DO 225 P4=1,2 DO 225 I=1,NCFL(1) 225 MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I) C--now enter the daughter particles NSPN = NSPN+2 IDSPN(2) = KHEP ISNHEP(KHEP) = 2 IDSPN(3) = JHEP ISNHEP(JHEP) = 3 JMOSPN(2) = 1 JMOSPN(3) = 1 C--spin density matrices for daughter particles DO 230 P1=1,2 DO 230 P2=1,2 DO 230 I=1,3 RHOSPN(1,1,I) = HALF RHOSPN(1,2,I) = ZERO RHOSPN(2,1,I) = ZERO 230 RHOSPN(2,2,I) = HALF DECSPN(2) = .FALSE. DECSPN(3) = .FALSE. C--select the colour flow if needed IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN WGT = ZERO C--assume no incoming polarization, no processes with more than one C--colour flow in e+e- DO 335 I =1,NCFL(1) WGTB(I) = ZERO DO 335 P1=1,2 DO 335 P2=1,2 DO 335 P3=1,2 DO 335 P4=1,2 WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*DREAL( & MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,I,1))) DO 335 J =1,NCFL(1) 335 WGT = WGT+SPNCFC(I,J,1)*DREAL( & MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,J,1))) WGTC = ZERO DO 340 I=1,NCFL(1) 340 WGTC = WGTC+WGTB(I) WGTC = WGT/WGTC DO 345 I=1,NCFL(1) 345 WGTB(I) = WGTB(I)*WGTC WGTC = WGT*HWRGEN(0) DO 350 I=1,NCFL(1) IF(WGTB(I).GE.WGTC) THEN NCFL(1) = I RETURN ENDIF 350 WGTC =WGTC-WGTB(I) ENDIF END CDECK ID>, HWHS01. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS01(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar --> gauge boson --> fermion fermion C This diagram 1 from DAMTP-2001-83 with opposite sign of P4 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P1.EQ.P2) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*( & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,P4,2) & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1)) ELSE ME(P1,P2,P3,P4) = ZERO ENDIF 10 CONTINUE END CDECK ID>, HWHS02. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS02(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> fermion fermion via t-channel scalar exchange C This diagram 2 from DAMTP-2001-83 with opposite sign of P4 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -HALF/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)* & F3(O(P3),P1,1)*F4(P2,P4,2) END CDECK ID>, HWHS03. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS03(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> fermion fermion via u-channel scalar exchange C This diagram 3 from DAMTP-2001-83 with opposite sign of P4 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)* & F4M(O(P4),P1,1)*F3M(P2,P3,2) END CDECK ID>, HWHS04. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS04(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar --> gauge boson --> fermion antifermion C This diagram 1 from DAMTP-2001-83 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P1.EQ.P2) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*( & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,O(P4),2) & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1)) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS05. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS05(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (1st colour flow) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =+ONE/SH/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*( & F3(O(P3), P1 ,2)*( FTP( P1 , P2 ,1,1)*F4( P2 ,O(P4),2) & +FTP( P1 ,O(P2),1,2)*F4(O(P2),O(P4),1)) & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,O(P4),2) & +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1))) END CDECK ID>, HWHS06. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS06(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (2st colour flow) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-ONE/SH/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*( & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,O(P4),1) & +FUP( P2 ,O(P1),2,1)*F4(O(P1),O(P4),2)) & +F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,O(P4),1) & +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2))) END CDECK ID>, HWHS07. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS07(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (triple gluon piece) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/SH**2 DO 10 P3=1,2 DO 10 P4=1,2 MET = (0.0D0,0.0D0) DO 5 I=1,2 5 MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2) DO 10 P1=1,2 DO 10 P2=1,2 IF(P1.EQ.P2) THEN ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS08. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS08(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section quark gluon --> fermion sfermion C This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/ & (TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 ME(P1,P2,P3,2) = ZERO 10 ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3), P1,1) END CDECK ID>, HWHS09. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS09(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section antiquark gluon --> fermion antisfermion C This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/ & (TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 ME(P1,P2,P3,2) = ZERO 10 ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1) END CDECK ID>, HWHS10. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS10(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section quark gluon --> fermion antisfermion (s-channel quark) C This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 IF(P1.EQ.P2) THEN ME(p1,p2,p3,1) = PRE*A( P2 ,ID)*F3(O(P3), P2 ,1)*S(1,2,P2)* & S(1,1,O(P2)) ELSE ME(P1,P2,P3,1) = PRE* & A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2)) & +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2) ENDIF 10 ME(P1,P2,P3,2) = ZERO END CDECK ID>, HWHS11. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS11(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section quark gluon --> fermion antisfermion (s-channel quark) C This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 IF(P1.EQ.P2) THEN ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)* & (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2)) ELSE ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1) ENDIF 10 ME(P1,P2,P3,2) = ZERO END CDECK ID>, HWHS12. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS12(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section quark gluon --> fermion antisfermion (s-channel quark) C This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 ME(P1,P2,P3,1) = PRE*A(P1,ID)*( & F3(O(P3), P2 ,1)*FUP( P2 ,P1, 2,1) & +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1)) 10 ME(P1,P2,P3,2) = ZERO END CDECK ID>, HWHS13. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS13(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section quark gluon --> fermion antisfermion (s-channel quark) C This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/ & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*( & FUM(P1, P2 ,1,1)*F3M( P2 ,P3, 2) & +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1)) 10 ME(P1,P2,P3,2) = ZERO END CDECK ID>, HWHS14. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS14(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (1st colour flow) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 4 from DAMTP-2001-83 with opposite helicity for 4 C and gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8), & FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =+ONE/(TH-MS(ID))/SH C--matrix element DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*( & F3(O(P3), P1 ,2)*( FTP( P1 , P2 , 1,1)*F4( P2 ,P4,2) & +FTP( P1 ,O(P2), 1,2)*F4(O(P2),P4,1)) & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,P4,2) & +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1))) END CDECK ID>, HWHS15. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS15(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (2st colour flow) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 5 from DAMTP-2001-83 with opposite helicity for 4 C and gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8), & FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-ONE/(UH-MS(ID))/SH C--matrix element DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*( & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,P4,1) & +FUP( P2 ,O(P1),2,1)*F4(O(P1),P4,2)) &+F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,P4,1) & +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2))) END CDECK ID>, HWHS16. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS16(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section gluon gluon --> fermion antifermion (triple gluon piece) C N.B. a gauge choice has been made to simplify the triple gluon vertex C This diagram 6 from DAMTP-2001-83 with opposite helicity for 4 C and gauge choice L1=2 L2=1 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/SH**2 C--matrix element DO 10 P3=1,2 DO 10 P4=1,2 MET = (0.0D0,0.0D0) DO 5 I=1,2 5 MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2) DO 10 P1=1,2 DO 10 P2=1,2 IF(P1.EQ.P2) THEN ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1)) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS17. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS17(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fermion fermion --> fermion fermion (t-channel boson) C This diagram 13 from DAMTP-2001-83 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O,DL DATA O/2,1/ DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/ C--compute the propagator factor PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P2.EQ.P4) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)* & ( DL(P1,O(P2))*F3(O(P3), P2 ,2)*S(4,1, P2 ) & +DL(P1, P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2))) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS18. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS18(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fermion antifermion --> fermion antifermion (t-channel boson) C This diagram 14 from DAMTP-2001-83 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O,DL DATA O/2,1/ DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/ C--compute the propagator factor PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P2.EQ.P4) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)* & ( DL(P1,O(P2))*F3(O(P3), P2 ,4)*S(2,1, P2 ) & +DL(P1, P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2))) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS19. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS19(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section antifermion fermion --> antifermion fermion (t-channel boson) C This diagram 15 from DAMTP-2001-83 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O,DL DATA O/2,1/ DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/ C--compute the propagator factor PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P2.EQ.P4) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)* & ( DL(P1,O(P2))*S(1,2, P1 )*F3M( P2 ,O(P3),4) & +DL(P1, P2 )*S(1,4, P1 )*F3M(O(P2),O(P3),2)) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS20. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS20(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section antifermion fermion --> antifermion fermion (t-channel boson) C This diagram 16 from DAMTP-2001-83 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI, & F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE PARAMETER(ZI=(0.0D0,1.0D0)) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) EXTERNAL HWULDO SAVE O,DL DATA O/2,1/ DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/ C--compute the propagator factor PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 IF(P2.EQ.P4) THEN ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)* & ( DL(P1,O(P2))*S(1,4, P1 )*F3M( P2 ,O(P3),2) & +DL(P1, P2 )*S(1,2, P1 )*F3M(O(P2),O(P3),4)) ELSE ME(P1,P2,P3,P4) = (0.0D0,0.0D0) ENDIF 10 CONTINUE END CDECK ID>, HWHS21. *CMZ :- -02/10/01 10:17:10 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS21(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> f fbar via s-channel scalar exchange C This is diagram 1 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0) 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))* & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4) & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4)) END CDECK ID>, HWHS22. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS22(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> f fbar via t-channel scalar exchange C This is diagram 2 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -HALF/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)* & F4(P2,O(P4),2)*F3(O(P3),P1,1) END CDECK ID>, HWHS23. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS23(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> fermion fermion via t-channel scalar exchange C This is diagram 3 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)* & F4M(P4,P1,1)*F3M(P2,P3,2) END CDECK ID>, HWHS24. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS24(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> f f via s-channel scalar exchange C This is diagram 4 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0) 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))* & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3)) & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3)) END CDECK ID>, HWHS25. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS25(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> f f via u-channel scalar exchange C This is diagram 5 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -HALF/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)* & F4M(O(P4),P1,1)*F3M(P2,P3,2) END CDECK ID>, HWHS26. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS26(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f fbar ---> f f via t-channel scalar exchange C This is diagram 6 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8), & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)* & F4(P2,P4,2)*F3(O(P3),P1,1) END CDECK ID>, HWHS27. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS27(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f f ---> f fbar via s-channel scalar exchange C This is diagram 7 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0) 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))* & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4) & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4)) END CDECK ID>, HWHS28. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS28(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f f ---> f fbar via t-channel scalar exchange C This is diagram 8 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = -HALF/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A( P1 ,ID)* & F4(O(P2),O(P4),2)*F3(O(P3),P1,1) END CDECK ID>, HWHS29. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS29(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f f ---> f fbar via u-channel scalar exchange C This is diagram 9 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)* & F3(O(P3),P2,2)*F4(O(P1),O(P4),1) END CDECK ID>, HWHS30. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS30(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fbar fbar ---> f f via s-channel scalar exchange C This is diagram 10 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0) 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)* & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3)) & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3)) END CDECK ID>, HWHS31. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS31(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fbar fbar ---> f f via t-channel scalar exchange C This is diagram 11 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(TH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)* & F4M(O(P4),O(P2),2)*F3M(P1,P3,1) END CDECK ID>, HWHS32. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS32(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fbar fbar ---> f f via u-channel scalar exchange C This is diagram 12 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE =-HALF/(UH-MS(ID)) DO 10 P1=1,2 DO 10 P2=1,2 DO 10 P3=1,2 DO 10 P4=1,2 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)* & F4M(O(P4),O(P1),1)*F3M(P2,P3,2) END CDECK ID>, HWHS33. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS33(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section f f ---> f f via s-channel scalar exchange C This is diagram 13 from RPV C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0) 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))* & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3)) & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3)) END CDECK ID>, HWHS34. *CMZ :- -08/04/02 11:54:39 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHS34(ID,ME) C----------------------------------------------------------------------- C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross C section fbar fbar ---> fbar fbar via t-channel scalar exchange C This is diagram 14 from RPV notes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER NDIAHD PARAMETER(NDIAHD=10) DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI, & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8) DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD), & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD) COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA, & MA2,SH,TH,UH,IDP,DRTYPE COMMON/HWHEWS/S(8,8,2),D(8,8) PARAMETER(ZI=(0.0D0,1.0D0)) SAVE O DATA O/2,1/ C--compute the propagator factor PRE = HALF/(SH-MS(ID)+ZI*MWD(ID)) DO 10 P1=1,2 DO 10 P3=1,2 DO 10 P4=1,2 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0) 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)* & ( B( P4 ,ID)*F3(P3, P4 ,4)*S(4,8,P4) & -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4)) END CDECK ID>, HWHSS1. *CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR) C----------------------------------------------------------------------- C QQ(BAR) -> GAUGINOS C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN DOUBLE COMPLEX CLL, CLR, CRL, CRR HWHSS1 = DREAL( & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+ & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+ & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S ) END CDECK ID>, HWHSS2. *CMZ :- -10/10/01 10:38:15 by Peter Richardson *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR) C----------------------------------------------------------------------- C LL(BAR) -> GAUGINOS (including beam polarization) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN DOUBLE COMPLEX CLL, CLR, CRL, CRR HWHSS2 = C--first the incoming left electron & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL( & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+ & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+ & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S ) C--then the incoming right electron &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL( & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+ & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+ & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S ) END CDECK ID>, HWHSSG. *CMZ :- -31/03/00 17:54:05 by Peter Richardson *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWHSSG C----------------------------------------------------------------------- C SUSY 2 PARTON -> 2 GAUGINOS PROCESSES (1 - 3) C -> GAUGINO + SPARTON PROCESSES (4 - 7) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST, & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4), & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2, & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6), & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6), & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4, & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB DOUBLE PRECISION DQD(6), DQU(6), HWHSS1 EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1 SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7 PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449) PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53) DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0)) EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU)) EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1)) EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1)) EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2)) EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2)) EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3)) EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3)) EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4)) EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4)) SAVE IWD,DQD,DQU DATA IWD/2,1,4,3,6,5/ DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/ DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/ C CALL HWSGEN(.FALSE.) IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE SN2TH = 0.25D0 - 0.25D0*COSTH**2 S=XX(1)*XX(2)*PHEP(5,3)**2 EMSC2 = EMSCA**2 FAC0 = FACTSS*HWUAEM(EMSC2) c prefactor for pair production, includes 1/Nc colour factor FACA = FAC0*HWUAEM(EMSC2) / CAFAC c prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor FACB = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC c prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor FACC = FACB / CFFAC / TWO MG2 = MG**2 GZ = S-MZ**2+Z*S/MZ*GAMZ GW = S-MW**2+Z*S/MW*GAMW DO IQ = 1,6 IQ1 = SSL + IQ IQ2 = SSR + IQ ML(IQ) = RMASS(IQ1) ML2(IQ) = ML(IQ)**2 MR(IQ) = RMASS(IQ2) MR2(IQ) = MR(IQ)**2 END DO XW = TWO * SWEIN SQXW = SQRT(XW) S22W = XW * (TWO - XW) S2W = SQRT(S22W) DO IG1 = 1,4 MNU(IG1) = RMASS(IG1+SSNU) MNU2(IG1) = MNU(IG1)**2 END DO DO IG1 = 1,2 MCH(IG1) = RMASS(IG1+SSCH) MCH2(IG1) = MCH(IG1)**2 END DO c _ ~+ ~- c (1) q q -> X X c a b DO IG1 = 1,2 DO IG2 = 1,2 SM = MCH(IG1) + MCH(IG2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MCH(IG1) - MCH(IG2) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO U = - T - S + MCH2(IG1) + MCH2(IG2) DAB = ABS(FLOAT(IG1+IG2-3)) C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ SGN = WSGNSS(IG1)*WSGNSS(IG2) C--PR bug fix 31/03/00 DO IQ = 1,6 C3 = -DAB*QFCH(IQ)/S CLL = C3 - LFCH(IQ)*C1 + & DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW) CLR = C3 - LFCH(IQ)*C2 - & DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW) CRL = C3 - RFCH(IQ)*C1 CRR = C3 - RFCH(IQ)*C2 M1(IG1,IG2,IQ)=FACA*PF* & HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR) END DO C--End of Fix ELSE DO IQ = 1,6 M1(IG1,IG2,IQ) = ZERO END DO END IF END DO END DO c _ ~o ~o c (2) q q -> X X c i j DO IG1 = 1,4 DO IG2 = 1,4 SM = MNU(IG1) + MNU(IG2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MNU(IG1) - MNU(IG2) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO U = - T - S + MNU2(IG1) + MNU2(IG2) C1 = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ C2 = - C1 SGN = ZSGNSS(IG1)*ZSGNSS(IG2) DO IQ = 1,6 CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ)) CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ)) CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ)) CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ)) M2(IG1,IG2,IQ) = FACA*PF*HALF* & HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR) END DO ELSE DO IQ = 1,6 M2(IG1,IG2,IQ) = ZERO END DO END IF END DO END DO c _ ~+ ~o c (3) U D -> X X c a i DO IG1 = 1,2 DO IG2 = 1,4 SM = MCH(IG1) + MNU(IG2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MCH(IG1) - MNU(IG2) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO U = - T - S + MCH2(IG1) + MNU2(IG2) C1 = XA(IG2)+S2W/XW*XB(IG2) c note the new s-channel signs below. (PR BUG FIX 3/9/01) C2 = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW C3 = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW SGN = WSGNSS(IG1)*ZSGNSS(IG2) DO IQ1 = 1,3 IQ3 = IQ1*2 DO IQ2 = 1,3 IQ4 = IQ2*2-1 CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3)) CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4)) M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW* & HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0) END DO END DO ELSE DO IQ1 = 1,3 DO IQ2 = 1,3 M3(IG1,IG2,IQ1,IQ2) = ZERO END DO END DO END IF END DO END DO c _ ~o ~ c (4) q q -> X g c i DO IG1 = 1,4 SM = MNU(IG1) + MG QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MNU(IG1) - MG SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO U = - T - S + MG2 + MNU2(IG1) DO IQ = 1,6 CLL = SLFCH(IQ,IG1)/(U-ML2(IQ)) CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ)) CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ)) CRR = SRFCH(IQ,IG1)/(U-MR2(IQ)) M4(IG1,IQ) = FACB*PF* & HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR) END DO ELSE DO IQ = 1,6 M4(IG1,IQ) = ZERO END DO END IF END DO c _ ~+ ~ c (5) U D -> X g c a DO IG1 = 1,2 SM = MCH(IG1) + MG QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MCH(IG1) - MG SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO U = - T - S + MCH2(IG1) + MG2 DO IQ1 = 1,3 IQ3 = IQ1*2 DO IQ2 = 1,3 IQ4 = IQ2*2-1 CLL = WMXVSS(IG1,1)/(U-ML2(IQ3)) CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4)) M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW* & HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0) END DO END DO ELSE DO IQ1 = 1,3 DO IQ2 = 1,3 M5(IG1,IQ1,IQ2) = ZERO END DO END DO END IF END DO c ~o ~ c (6) g q -> X q c i LR DO IG1 = 1,4 DO IQ = 1,6 c left squarks SM = MNU(IG1)+ML(IQ) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MNU(IG1)-ML(IQ) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T3 = (SQPE*COSTH - S - SM*DM) / TWO U4 = - T3 - S C--KO bug fix 06/10/00 M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2 & +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)* & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH) ELSE M6L(IG1,IQ) = ZERO END IF c right squarks SM = MNU(IG1)+MR(IQ) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = MNU(IG1)-MR(IQ) SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T3 = (SQPE*COSTH - S - SM*DM) / TWO U4 = - T3 - S C--PR bug fix 28/08/01 M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2 & +(QMIXSS(IQ,2,2)*SRFCH(IQ,IG1))**2)* & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH) ELSE M6R(IG1,IQ) = ZERO END IF END DO END DO c ~+-~ c (7) g q -> X q' c a L DO IG1 = 1,2 DO IQ1 = 1,3 IQ3 = IQ1*2 DO IQ2 = 1,3 IQ4 = IQ2*2-1 DO I = 1,2 c U initiated processes IF (I.EQ.1) THEN MSQK = ML(IQ4) ELSE MSQK = MR(IQ4) END IF SM = MCH(IG1) + MSQK QPE = S - SM**2 IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN DM = MCH(IG1) - MSQK SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T3 = (SQPE*COSTH - S - SM*DM) / TWO U4 = - T3 - S M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2) & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)* & QMIXSS(IQ4,1,I)**2 ELSE M7(I,IG1,IQ3,IQ4) = ZERO END IF c D initiated processes IF (I.EQ.1) THEN MSQK = ML(IQ3) ELSE MSQK = MR(IQ3) END IF SM = MCH(IG1) + MSQK QPE = S - SM**2 IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN DM = MCH(IG1) - MSQK SQPE = SQRT(QPE*(S-DM**2)) PF = SQPE/S T3 = (SQPE*COSTH - S - SM*DM) / TWO U4 = - T3 - S M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2) & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)* & QMIXSS(IQ3,1,I)**2 ELSE M7(I,IG1,IQ4,IQ3) = ZERO END IF END DO END DO END DO END DO END IF HCS = 0. c _ _ ~+ ~- ~o ~o ~o ~ c q q , q q -> X X , X X , X g c a b i j i DO 1 ID1 = 1,12 IF (DISF(ID1,1).LT.EPS) GOTO 1 IF (ID1.GT.6) THEN ID2 = ID1 - 6 IQ = ID2 IPB = 4132 ELSE ID2 = ID1 + 6 IQ = ID1 IPB = 2431 END IF IF (DISF(ID2,2).LT.EPS) GOTO 1 DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,2 IG3 = ICH+IG1 DO IG2 = 1,2 IG4 = ICH+IG2+2 HCS = HCS + DIST*M1(IG1,IG2,IQ) C--PR bug fix 10/10/01 IF (GENEV.AND.HCS.GT.RCS) THEN IF(ID2.LT.ID1) COSTH=-COSTH CALL HWHSSS(IG3,0,IG4,0,2134,21) GOTO 9 ENDIF END DO END DO DO IG1 = 1,4 IG3 = INU+IG1 DO IG2 = 1,4 IG4 = INU+IG2 IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ) C--PR bug fix 10/10/01 IF (GENEV.AND.HCS.GT.RCS) THEN IF(ID2.LT.ID1) COSTH=-COSTH CALL HWHSSS(IG3,0,IG4,0,2134,22) GOTO 9 ENDIF END DO HCS = HCS + DIST*M4(IG1,IQ) C--PR bug fix 10/10/01 IF (GENEV.AND.HCS.GT.RCS) THEN IF(ID2.LT.ID1) COSTH=-COSTH CALL HWHSSS(IG3,0,IGL,0, IPB,24) GOTO 9 ENDIF END DO 1 CONTINUE c _ _ ~+-~o ~+-~ c q q', q q' -> X X , X g c a i a c c _ _ _ _ c ud(+), ud(-), du(-), du(+) DO 2 IQ1 = 1, 3 DO IQ2 = 1, 3 IF(VCKM(IQ1,IQ2).GT.EPS) THEN c _ c ud (+) ID1 = IQ1 * 2 ID2 = IQ2 * 2 + 5 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,2 IG3 = ICH+IG1 DO IG2 = 1,4 IG4 = INU+IG2 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IG4,0,2134,23) GOTO 9 ENDIF END DO HCS = HCS + DIST*M5(IG1,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IGL,0,2431,25) GOTO 9 ENDIF END DO END IF c _ c du (+) ID1 = IQ2 * 2 + 5 ID2 = IQ1 * 2 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,2 IG3 = ICH+IG1 DO IG2 = 1,4 IG4 = INU+IG2 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IG3,0,2134,23) GOTO 9 ENDIF END DO HCS = HCS + DIST*M5(IG1,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IGL,0,IG3,0,3124,25) GOTO 9 ENDIF END DO END IF c _ c du (-) ID1 = IQ2 * 2 - 1 ID2 = IQ1 * 2 + 6 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,2 IG3 = ICH+IG1+2 DO IG2 = 1,4 IG4 = INU+IG2 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IG3,0,2134,23) GOTO 9 ENDIF END DO HCS = HCS + DIST*M5(IG1,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IGL,0,IG3,0,2314,25) GOTO 9 ENDIF END DO END IF c _ c ud (-) ID1 = IQ1 * 2 + 6 ID2 = IQ2 * 2 - 1 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,2 IG3 = ICH+IG1+2 DO IG2 = 1,4 IG4 = INU+IG2 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IG4,0,2134,23) GOTO 9 ENDIF END DO HCS = HCS + DIST*M5(IG1,IQ1,IQ2) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IGL,0,4132,25) GOTO 9 ENDIF END DO END IF END IF END DO 2 CONTINUE c _ _ ~o ~ ~+-~ c g q , g q , q g , q g -> X q , X q' c i LR a L c neutralino DO IQ1 = 1,6 c c gq ID1 = 13 ID2 = IQ1 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,4 IG3 = INU+IG1 HCS = HCS + DIST*M6L(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,ID2,0,2431,26) GOTO 9 ENDIF HCS = HCS + DIST*M6R(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,ID2,2,2431,26) GOTO 9 ENDIF END DO END IF c _ c gq ID1 = 13 ID2 = IQ1 + 6 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,4 IG3 = INU+IG1 HCS = HCS + DIST*M6L(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,ID2,0,4132,26) GOTO 9 ENDIF HCS = HCS + DIST*M6R(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,ID2,2,4132,26) GOTO 9 ENDIF END DO END IF c c qg ID1 = IQ1 ID2 = 13 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,4 IG3 = INU+IG1 HCS = HCS + DIST*M6L(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(ID1,0,IG3,0,3124,26) GOTO 9 ENDIF HCS = HCS + DIST*M6R(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(ID1,2,IG3,0,3124,26) GOTO 9 ENDIF END DO END IF c _ c qg ID1 = IQ1 + 6 ID2 = 13 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = DISF(ID1,1)*DISF(ID2,2) DO IG1 = 1,4 IG3 = INU+IG1 HCS = HCS + DIST*M6L(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(ID1,0,IG3,0,2314,26) GOTO 9 ENDIF HCS = HCS + DIST*M6R(IG1,IQ1) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(ID1,2,IG3,0,2314,26) GOTO 9 ENDIF END DO END IF END DO c chargino DO IQ1 = 1,3 IQ3 = IQ1*2 DO 3 IQ2 = 1,3 IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3 IQ4 = IQ2*2-1 DO IG1 = 1,2 IG3 = ICH+IG1 IG4 = ICH+IG1+2 c c gq & qg ID1 = 13 ID2 = IQ3 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IQ4,0,2431,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IQ4,2,2431,27) GOTO 9 ENDIF ID2 = IQ4 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IQ3,0,2431,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IQ3,2,2431,27) GOTO 9 ENDIF ID1 = IQ3 ID2 = 13 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ4,0,IG3,0,3124,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ4,2,IG3,0,3124,27) GOTO 9 ENDIF ID1 = IQ4 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ3,0,IG4,0,3124,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ3,2,IG4,0,3124,27) GOTO 9 ENDIF c _ _ c gq & qg ID1 = 13 ID2 = IQ3 + 6 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IQ4,1,4132,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG4,0,IQ4,3,4132,27) GOTO 9 ENDIF ID2 = IQ4 + 6 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IQ3,1,4132,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IG3,0,IQ3,3,4132,27) GOTO 9 ENDIF ID1 = IQ3 + 6 ID2 = 13 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ4,1,IG4,0,2314,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ4,3,IG4,0,2314,27) GOTO 9 ENDIF ID1 = IQ4 + 6 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ3,1,IG3,0,2314,27) GOTO 9 ENDIF HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ3,3,IG3,0,2314,27) GOTO 9 ENDIF END DO 3 CONTINUE END DO EVWGT = HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices C Set to zero for now CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHSSL. *CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWHSSL C----------------------------------------------------------------------- C SUSY 2 PARTON -> 2 SLEPTON PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE, & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2 INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J EXTERNAL HWRGEN, HWUAEM SAVE HCS, ME2, ME2W PARAMETER (EPS = 1.D-9) DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E PARAMETER (Z = (0.D0,1.D0)) EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)) C S = XX(1)*XX(2)*PHEP(5,3)**2 EMSC2 = S EMSCA = SQRT(EMSC2) CALL HWSGEN(.FALSE.) IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE SN2TH = 0.25D0 - 0.25D0*COSTH**2 FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S GW2 = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2 c _ ~ ~* c q q -> l l c DO IL = 1,6 DO I = 1,2 DO J = 1,2 IF (((I.NE.J).AND.(IL.NE.5)).OR. & ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN QPE = -1. ELSE ID1 = 412 + I*12 + IL ID2 = 412 + J*12 + IL IL1 = IL + 10 QPE = S-(RMASS(ID1)+RMASS(ID2))**2 END IF IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S DO IQ = 1,2 A = QFCH(IL1)*QFCH(IQ) BL = LFCH(IL1)/GZ BR = RFCH(IL1)/GZ CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J) CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J) D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR ME2(I,J,IL,IQ)=FACTR*PF**3 $ *DREAL(DCONJG(D)*D+DCONJG(E)*E) END DO ELSE ME2(I,J,IL,1)=ZERO ME2(I,J,IL,2)=ZERO END IF END DO END DO END DO c _ ~ ~* c q q' -> l v c DO IL = 1,3 DO I = 1,2 IF ((IL.NE.3).AND.(I.EQ.2)) THEN QPE = -1. ELSE ID1 = 411 + IL*2 + I*12 ID2 = 424 + IL*2 QPE = S-(RMASS(ID1)+RMASS(ID2))**2 END IF IF (QPE.GT.ZERO) THEN PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S ME2W(I,IL)=FACTR*PF**3/GW2 IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2 ELSE ME2W(I,IL)=ZERO END IF END DO END DO END IF HCS = 0. C DO 1 ID1 = 1, 12 IF (DISF(ID1,1).LT.EPS) GOTO 1 IF (ID1.GT.6) THEN ID2 = ID1 - 6 ELSE ID2 = ID1 + 6 END IF IQ = ID1 - ((ID1-1)/2)*2 IF (DISF(ID2,2).LT.EPS) GOTO 1 DIST = DISF(ID1,1)*DISF(ID2,2) DO IL = 1,6 DO I = 1,2 DO J = 1,2 IL1 = IL+I*12 IL2 = IL+J*12 HCS = HCS + DIST*ME2(I,J,IL,IQ) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IL1,2,IL2,3,2134,30) GOTO 9 ENDIF END DO END DO END DO 1 CONTINUE c _ _ _ _ c ud(+), ud(-), du(-), du(+) DO 2 IQ1 = 1, 3 DO IQ2 = 1, 3 IF(VCKM(IQ1,IQ2).GT.EPS) THEN c _ c ud (+) ID1 = IQ1 * 2 ID2 = IQ2 * 2 + 5 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2) DO IL = 1,3 IL1 = IL*2-1 IL2 = IL1+1 HCS = HCS + DIST*ME2W(1,IL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IL1,5,IL2,4,2134,30) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2W(2,3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(5,7,6,4,2134,30) GOTO 9 ENDIF END IF c _ c du (+) ID1 = IQ2 * 2 + 5 ID2 = IQ1 * 2 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2) DO IL = 1,3 IL1 = IL*2-1 IL2 = IL1+1 HCS = HCS + DIST*ME2W(1,IL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IL1,5,IL2,4,2134,30) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2W(2,3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(5,7,6,4,2134,30) GOTO 9 ENDIF END IF c _ c du (-) ID1 = IQ2 * 2 - 1 ID2 = IQ1 * 2 + 6 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2) DO IL = 1,3 IL1 = IL*2-1 IL2 = IL1+1 HCS = HCS + DIST*ME2W(1,IL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IL1,4,IL2,5,2134,30) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2W(2,3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(5,6,6,5,2134,30) GOTO 9 ENDIF END IF c _ c ud (-) ID1 = IQ1 * 2 + 6 ID2 = IQ2 * 2 - 1 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2) DO IL = 1,3 IL1 = IL*2-1 IL2 = IL1+1 HCS = HCS + DIST*ME2W(1,IL) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IL1,4,IL2,5,2134,30) GOTO 9 ENDIF END DO HCS = HCS + DIST*ME2W(2,3) IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(5,6,6,5,2134,30) GOTO 9 ENDIF END IF END IF END DO 2 CONTINUE EVWGT = HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices C Set to zero for now CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHSSQ. *CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWHSSQ C----------------------------------------------------------------------- C SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2, & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE, & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE, & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S, & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2, & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH DOUBLE PRECISION & AUSTLL(6), AUSTRR(6), & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6), & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6), & BSTULL(6), BSTURR(6), BSTULR(6), BSTURL(6), & BSUTLL(6), BSUTRR(6), BSUTLR(6), BSUTRL(6), & BUTSLL(6), BUTSRR(6), BUTSLR(6), BUTSRL(6), & BUSTLL(6), BUSTRR(6), BUSTLR(6), BUSTRL(6), & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6), & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU EXTERNAL HWRGEN, HWUALF SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL, & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR, & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR, & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR, & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449) CALL HWSGEN(.FALSE.) IF (GENEV) THEN RCS = HCS*HWRGEN(0) ELSE SN2TH = 0.25D0 - 0.25D0*COSTH**2 S = XX(1)*XX(2)*PHEP(5,3)**2 FACTR = FACTSS*HWUALF(1,EMSCA)**2 NC = CAFAC NC2 = NC**2 NC2C = ONE - ONE/NC2 AFAC = FACTR*NC2C/FOUR CFAC = FACTR*CFFAC/FOUR CFC2 = FACTR/CFFAC/FOUR CFC3 = FACTR/FOUR DFAC = FACTR/NC2C S2 = S**2 MG2 = RMASS(GLU)**2 DO 10 IQ = 1, 6 IQ1 = SSL + IQ IQ2 = SSR + IQ ML2(IQ) = RMASS(IQ1)**2 ML4(IQ) = ML2(IQ)**2 MR2(IQ) = RMASS(IQ2)**2 MR4(IQ) = MR2(IQ)**2 10 CONTINUE c gluino pair production QPE = S - FOUR*MG2 IF (QPE.GE.ZERO) THEN SQPE = SQRT(S*QPE) PF = SQPE/S TT = (SQPE*COSTH - S) / TWO TT2 = TT**2 UU = - S - TT UU2 = UU**2 c ~ ~ c g g -> g g c DONE = & DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU DUTS = DONE*UU2 DTSU = DONE*TT2 DSTU = DONE*S2 c _ ~ ~ c q q -> g g c DO 21 IQ = 1, 6 L = ML2(IQ)-MG2 L2 = L**2 TTML = TT-L UUML = UU-L R = MR2(IQ)-MG2 R2 = R**2 TTMR = TT-R UUMR = UU-R CONE = TWO*PF**2*SN2TH CONL = CONE/UUML/TTML CONR = CONE/UUMR/TTMR CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2 CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2 CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+ & L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 )) CSTU(IQ) = CONT*CONN CSUT(IQ) = CONU*CONN 21 CONTINUE ELSE DUTS = ZERO DTSU = ZERO DSTU = ZERO DO 23 IQ = 1, 6 CSTU(IQ) = ZERO CSUT(IQ) = ZERO 23 CONTINUE END IF c left handed squark (identical flavour) pair production DO 22 IQ = 1, 6 QPE = S - FOUR*ML2(IQ) IF (QPE.GE.ZERO) THEN SQPE = SQRT(S*QPE) PF = SQPE/S TT = (SQPE*COSTH - S) / TWO TT2 = TT**2 UU = - S - TT UU2 = UU**2 c ~ ~* c g g -> q q c L L CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2 CONN = CONE-CONE*S2/(TT2+UU2)/NC2 CSTUL(IQ) = CONN*UU2 CSUTL(IQ) = CONN*TT2 c ~ ~ c q q -> q q c L L TMG = TT+ML2(IQ)-MG2 TMG2 = TMG**2 UMG = UU+ML2(IQ)-MG2 UMG2 = UMG**2 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC) BSTULL(IQ) = BONE/TMG2 BSUTLL(IQ) = BONE/UMG2 c _ ~ ~* c q q -> q q c L L AF = AFAC*PF*PF**2*SN2TH BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC BUTSLL(IQ) = BONE*S2 BUSTLL(IQ) = BONE*TWO*TMG2 c _ ~ ~* c q q -> q'q' q =/= q' c L L AUSTLL(IQ) = TWO*AF ELSE CSTUL(IQ) = ZERO CSUTL(IQ) = ZERO BSTULL(IQ) = ZERO BSUTLL(IQ) = ZERO BUTSLL(IQ) = ZERO BUSTLL(IQ) = ZERO AUSTLL(IQ) = ZERO END IF c right handed squark (identical flavour) pair production QPE = S - FOUR*MR2(IQ) IF (QPE.GE.ZERO) THEN SQPE = SQRT(S*QPE) PF = SQPE/S TT = (SQPE*COSTH - S) / TWO TT2 = TT**2 UU = - S - TT UU2 = UU**2 c ~ ~* c g g -> q q c R R CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2 CONN = CONE-CONE*S2/(TT2+UU2)/NC2 CSTUR(IQ) = CONN*UU2 CSUTR(IQ) = CONN*TT2 c ~ ~ c q q -> q q c R R TMG = TT+MR2(IQ)-MG2 TMG2 = TMG**2 UMG = UU+MR2(IQ)-MG2 UMG2 = UMG**2 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC) BSTURR(IQ) = BONE/TMG2 BSUTRR(IQ) = BONE/UMG2 c _ ~ ~* c q q -> q q c R R AF = AFAC*PF*PF**2*SN2TH BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC BUTSRR(IQ) = BONE*S2 BUSTRR(IQ) = BONE*TWO*TMG2 c _ ~ ~* c q q -> q'q' q =/= q' c R R AUSTRR(IQ) = TWO*AF ELSE CSTUR(IQ) = ZERO CSUTR(IQ) = ZERO BSTURR(IQ) = ZERO BSUTRR(IQ) = ZERO BUTSRR(IQ) = ZERO BUSTRR(IQ) = ZERO AUSTRR(IQ) = ZERO END IF c left and right handed squark (identical flavour) pair production IQ1 = SSL + IQ IQ2 = SSR + IQ SM = RMASS(IQ1)+RMASS(IQ2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(IQ1)-RMASS(IQ2) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S AF = AFAC*PF TT = (SQPE*COSTH - S - SM*DM) / TWO UU = - S - TT TMG = TT + ML2(IQ) - MG2 TMG2 = TMG**2 UMG = UU + MR2(IQ) - MG2 UMG2 = UMG**2 c ~ ~ c q q -> q q c L R BONE = AFAC*PF*SQPE**2*SN2TH BSTULR(IQ) = BONE/TMG2 BSUTLR(IQ) = BONE/UMG2 c _ ~ ~* c q q -> q q c L R BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2 BUSTLR(IQ) = ZERO TT = (SQPE*COSTH - S + SM*DM) / TWO UU = - S - TT TMG = TT + MR2(IQ) - MG2 TMG2 = TMG**2 UMG = UU + ML2(IQ) - MG2 UMG2 = UMG**2 c ~ ~ c q q -> q q c R L c BONE = AFAC*PF*SQPE**2*SN2TH c BSTURL(IQ) = BONE/TMG2 c BSUTRL(IQ) = BONE/UMG2 BSTURL(IQ) = ZERO BSUTRL(IQ) = ZERO c _ ~ ~* c q q -> q q c R L BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2 BUSTRL(IQ) = ZERO ELSE BSTULR(IQ) = ZERO BSUTLR(IQ) = ZERO BUTSLR(IQ) = ZERO BUSTLR(IQ) = ZERO BSTURL(IQ) = ZERO BSUTRL(IQ) = ZERO BUTSRL(IQ) = ZERO BUSTRL(IQ) = ZERO END IF 22 CONTINUE c distinct flavours - gq, qq' DO 11 ID1 = 1, 6 IQ1 = SSL + ID1 SM = RMASS(GLU)+RMASS(IQ1) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(GLU)-RMASS(IQ1) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S TT = (SQPE*COSTH - S - SM*DM) / TWO TT2 = TT**2 UU = - S - TT UU2 = UU**2 c ~ ~ c g q -> g q c L CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2) CTSUL(ID1) = CONN*UU2 CTUSL(ID1) = CONN*S2 ELSE CTSUL(ID1) = ZERO CTUSL(ID1) = ZERO END IF IQ2 = SSR + ID1 SM = RMASS(GLU)+RMASS(IQ2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(GLU)-RMASS(IQ2) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S TT = (SQPE*COSTH - S - SM*DM) / TWO TT2 = TT**2 UU = - S - TT UU2 = UU**2 c ~ ~ c g q -> g q c R CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2) CTSUR(ID1) = CONN*UU2 CTUSR(ID1) = CONN*S2 ELSE CTSUR(ID1) = ZERO CTUSR(ID1) = ZERO END IF IF(ID1.EQ.6) GOTO 11 ID2MIN = ID1+1 DO 12 ID2 = ID2MIN, 6 IQ1 = SSL + ID1 IQ2 = SSL + ID2 SM = RMASS(IQ1)+RMASS(IQ2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(IQ1)-RMASS(IQ2) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S TT = (SQPE*COSTH - S - SM*DM) / TWO UU = - S - TT TMG = TT+ML2(ID1)-MG2 AF = AFAC*PF/TMG/TMG c ~ ~ c q q' -> q q' c L L ASTULL(ID1,ID2) = AF*MG2*S ASTULL(ID2,ID1) = ASTULL(ID1,ID2) c _ ~ ~* c q q' -> q q' c L L AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2) ELSE ASTULL(ID1,ID2) = ZERO ASTULL(ID2,ID1) = ZERO AUTSLL(ID1,ID2) = ZERO AUTSLL(ID2,ID1) = ZERO END IF IQ1 = SSR + ID1 IQ2 = SSR + ID2 SM = RMASS(IQ1)+RMASS(IQ2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(IQ1)-RMASS(IQ2) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S TT = (SQPE*COSTH - S - SM*DM) / TWO UU = - S - TT TMG = TT+MR2(ID1)-MG2 AF = AFAC*PF/TMG/TMG c ~ ~ c q q' -> q q' c R R ASTURR(ID1,ID2) = AF*MG2*S ASTURR(ID2,ID1) = ASTURR(ID1,ID2) c _ ~ ~* c q q' -> q q' c R R AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2) ELSE ASTURR(ID1,ID2) = ZERO ASTURR(ID2,ID1) = ZERO AUTSRR(ID1,ID2) = ZERO AUTSRR(ID2,ID1) = ZERO END IF IQ1 = SSL + ID1 IQ2 = SSR + ID2 SM = RMASS(IQ1)+RMASS(IQ2) QPE = S - SM**2 IF (QPE.GE.ZERO) THEN DM = RMASS(IQ1)-RMASS(IQ2) SQPE = SQRT( QPE*(S-DM**2) ) PF = SQPE/S TT = (SQPE*COSTH - S - SM*DM) / TWO UU = - S - TT TMG = TT+ML2(ID1)-MG2 AF = AFAC*PF/TMG/TMG c ~ ~ c q q' -> q q' c L R ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH ASTULR(ID2,ID1) = ASTULR(ID1,ID2) c _ ~ ~* c q q' -> q q' c L R AUTSLR(ID1,ID2) = AF*MG2*S AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2) TT = (SQPE*COSTH - S + SM*DM) / TWO UU = - S - TT TMG = TT+MR2(ID1)-MG2 AF = AFAC*PF/TMG/TMG c ~ ~ c q q' -> q q' c R L ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH ASTURL(ID2,ID1) = ASTULR(ID1,ID2) c _ ~ ~* c q q' -> q q' c R L AUTSRL(ID1,ID2) = AF*MG2*S AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2) ELSE ASTULR(ID1,ID2) = ZERO ASTULR(ID2,ID1) = ZERO AUTSLR(ID1,ID2) = ZERO AUTSLR(ID2,ID1) = ZERO ASTURL(ID1,ID2) = ZERO ASTURL(ID2,ID1) = ZERO AUTSRL(ID1,ID2) = ZERO AUTSRL(ID2,ID1) = ZERO END IF 12 CONTINUE 11 CONTINUE END IF HCS = ZERO DO 6 ID1 = 1, 13 IF (DISF(ID1,1).LT.EPS) GOTO 6 DO 5 ID2 = 1, 13 IF (DISF(ID2,2).LT.EPS) GOTO 5 DIST = DISF(ID1,1)*DISF(ID2,2) IF (ID1.LT.7) THEN IQ1 = ID1 IF (ID2.LT.7) THEN IQ2 = ID2 IF (IQ1.NE.IQ2) THEN c ~ ~ c qq' -> q q' HCS = HCS + ASTULL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + ASTURR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,2,3421,10) GOTO 9 ENDIF HCS = HCS + ASTULR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,2,3421,10) GOTO 9 ENDIF HCS = HCS + ASTURL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,0,3421,10) GOTO 9 ENDIF ELSE c ~ ~ c qq -> q q HCS = HCS + BSTULL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + BSTURR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,2,3421,10) GOTO 9 ENDIF HCS = HCS + BSTULR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,2,3421,10) GOTO 9 ENDIF HCS = HCS + BSTURL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + BSUTLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,4312,10) GOTO 9 ENDIF HCS = HCS + BSUTRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,2,4312,10) GOTO 9 ENDIF HCS = HCS + BSUTLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,2,4312,10) GOTO 9 ENDIF HCS = HCS + BSUTRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,0,4312,10) GOTO 9 ENDIF END IF ELSEIF (ID2.NE.13) THEN IQ2 = ID2-6 IF (IQ1.NE.IQ2) THEN c _ ~ ~* c qq' -> q q' HCS = HCS + AUTSLL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,1,3142,10) GOTO 9 ENDIF HCS = HCS + AUTSRR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,3,3142,10) GOTO 9 ENDIF HCS = HCS + AUTSLR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,3,3142,10) GOTO 9 ENDIF HCS = HCS + AUTSRL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,1,3142,10) GOTO 9 ENDIF ELSE c _ ~ ~* c qq -> q'q' (q =/= q') DO 30 IQ = 1, 6 IF (IQ .EQ.IQ1) GOTO 30 HCS = HCS + AUSTLL(IQ )*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,0,IQ ,1,2413,10) GOTO 9 ENDIF HCS = HCS + AUSTRR(IQ )*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,2,IQ ,3,2413,10) GOTO 9 ENDIF 30 CONTINUE c _ ~ ~* c qq -> q q HCS = HCS + BUTSLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,1,3142,10) GOTO 9 ENDIF HCS = HCS + BUTSRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,3,3142,10) GOTO 9 ENDIF HCS = HCS + BUTSLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,3,3142,10) GOTO 9 ENDIF HCS = HCS + BUTSRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,1,3142,10) GOTO 9 ENDIF HCS = HCS + BUSTLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,1,2413,10) GOTO 9 ENDIF HCS = HCS + BUSTRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,3,2413,10) GOTO 9 ENDIF HCS = HCS + BUSTLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,3,2413,10) GOTO 9 ENDIF HCS = HCS + BUSTRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,1,2413,10) GOTO 9 ENDIF IQ = IGL c _ ~ ~ c qq -> g g HCS = HCS + CSTU(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,0,IQ ,0,2413,10) GOTO 9 ENDIF HCS = HCS + CSUT(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,0,IQ ,0,2341,10) GOTO 9 ENDIF END IF ELSE IQ2 = IGL c ~ ~ c qg -> q g HCS = HCS + CTSUL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3142,10) GOTO 9 ENDIF HCS = HCS + CTSUR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,0,3142,10) GOTO 9 ENDIF HCS = HCS + CTUSL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + CTUSR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,2,IQ2,0,3421,10) GOTO 9 ENDIF END IF ELSEIF (ID1.NE.13) THEN IQ1 = ID1 - 6 IF (ID2.LT.7) THEN IQ2 = ID2 IF (IQ1.NE.IQ2) THEN c _ ~*~ c qq' -> q q' HCS = HCS + AUTSLL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + AUTSRR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,2,2413,10) GOTO 9 ENDIF HCS = HCS + AUTSLR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,2,2413,10) GOTO 9 ENDIF HCS = HCS + AUTSRL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,0,2413,10) GOTO 9 ENDIF ELSE c _ ~*~ c qq -> q'q' (q =/= q') DO 31 IQ = 1, 6 IF (IQ .EQ.IQ1) GOTO 31 HCS = HCS + AUSTLL(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,1,IQ ,0,3142,10) GOTO 9 ENDIF HCS = HCS + AUSTRR(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,3,IQ ,2,3142,10) GOTO 9 ENDIF 31 CONTINUE c _ ~*~ c qq -> q q HCS = HCS + BUTSLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + BUTSRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,2,2413,10) GOTO 9 ENDIF HCS = HCS + BUTSLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,2,2413,10) GOTO 9 ENDIF HCS = HCS + BUTSRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + BUSTLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,0,3142,10) GOTO 9 ENDIF HCS = HCS + BUSTRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,2,3142,10) GOTO 9 ENDIF HCS = HCS + BUSTLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,2,3142,10) GOTO 9 ENDIF HCS = HCS + BUSTRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,0,3142,10) GOTO 9 ENDIF c _ ~ ~ c qq -> g g HCS = HCS + CSTU(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IGL,0,IGL,0,3142,10) GOTO 9 ENDIF HCS = HCS + CSUT(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IGL,0,IGL,0,4123,10) GOTO 9 ENDIF END IF ELSEIF (ID2.NE.13) THEN IQ2 = ID2 - 6 IF (IQ1.NE.IQ2) THEN c __ ~*~* c qq' -> q q' HCS = HCS + ASTULL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,1,4312,10) GOTO 9 ENDIF HCS = HCS + ASTURR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,3,4312,10) GOTO 9 ENDIF HCS = HCS + ASTULR(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,3,4312,10) GOTO 9 ENDIF HCS = HCS + ASTURL(IQ1,IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,1,4312,10) GOTO 9 ENDIF ELSE c __ ~*~* c qq -> q q HCS = HCS + BSTULL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,1,4312,10) GOTO 9 ENDIF HCS = HCS + BSTURR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,3,4312,10) GOTO 9 ENDIF HCS = HCS + BSTULR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,3,4312,10) GOTO 9 ENDIF HCS = HCS + BSTURL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,1,4312,10) GOTO 9 ENDIF HCS = HCS + BSUTLL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,1,3421,10) GOTO 9 ENDIF HCS = HCS + BSUTRR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,3,3421,10) GOTO 9 ENDIF HCS = HCS + BSUTLR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,3,3421,10) GOTO 9 ENDIF HCS = HCS + BSUTRL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,1,3421,10) GOTO 9 ENDIF END IF ELSE IQ2 = IGL c _ ~*~ c qg -> q g HCS = HCS + CTSUL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + CTSUR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + CTUSL(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,1,IQ2,0,4312,10) GOTO 9 ENDIF HCS = HCS + CTUSR(IQ1)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,3,IQ2,0,4312,10) GOTO 9 ENDIF END IF ELSE IQ1 = IGL IF (ID2.LT.7) THEN IQ2 = ID2 c ~ ~ c gq -> g q HCS = HCS + CTSUL(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,2413,10) GOTO 9 ENDIF HCS = HCS + CTSUR(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,2,2413,10) GOTO 9 ENDIF HCS = HCS + CTUSL(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + CTUSR(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,2,3421,10) GOTO 9 ENDIF ELSEIF (ID2.LT.13) THEN IQ2 = ID2 - 6 c _ ~ ~* c gq -> g q HCS = HCS + CTSUL(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,1,3142,10) GOTO 9 ENDIF HCS = HCS + CTSUR(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,3,3142,10) GOTO 9 ENDIF HCS = HCS + CTUSL(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,1,4312,10) GOTO 9 ENDIF HCS = HCS + CTUSR(IQ2)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,3,4312,10) GOTO 9 ENDIF ELSE IQ2 = IGL c ~ ~* c gg -> q q DO 32 IQ = 1, 6 HCS = HCS + CSTUL(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,0,IQ ,1,2413,10) GOTO 9 ENDIF HCS = HCS + CSTUR(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,2,IQ ,3,2413,10) GOTO 9 ENDIF HCS = HCS + CSUTL(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,0,IQ ,1,4123,10) GOTO 9 ENDIF HCS = HCS + CSUTR(IQ)*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ ,2,IQ ,3,4123,10) GOTO 9 ENDIF 32 CONTINUE c ~ ~ c gg -> g g HCS = HCS + DTSU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,2341,10) GOTO 9 ENDIF HCS = HCS + DSTU*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,3421,10) GOTO 9 ENDIF HCS = HCS + DUTS*DIST IF (GENEV.AND.HCS.GT.RCS) THEN CALL HWHSSS(IQ1,0,IQ2,0,2413,10) GOTO 9 ENDIF END IF END IF 5 CONTINUE 6 CONTINUE EVWGT = HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices C Set to zero for now CALL HWVZRO(7,GCOEF) END IF END CDECK ID>, HWHSSP. *CMZ :- -25/06/99 20.33.45 by Kosuke Odagiri *-- Author : Kosuke Odagiri & Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHSSP C----------------------------------------------------------------------- C SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ, & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC INTEGER ISP EXTERNAL HWRGEN,HWRUNI SAVE SAVWT,SVEMSC IF (.NOT.GENEV) THEN EVWGT=ZERO CALL HWRPOW(ET,EJ) KK = ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) ) YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) ) YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=HALF*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN S=XX(1)*XX(2)*PHEP(5,3)**2 QPE=S-(TWO*RMMNSS)**2 IF (QPE.LE.ZERO) RETURN COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE) IF (ABS(COSTH).GT.ONE) RETURN T=-(ONE+Z2/Z1)*(HALF*ET)**2 U=-S-T C---SET EMSCA TO HEAVY HARD PROCESS SCALE SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U)) FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) & * SQRT(S/QPE) ENDIF EMSCA=SVEMSC ISP=MOD(IPROC,100) IF (ISP.EQ.0) THEN IF (GENEV) THEN RANWT=SAVWT(3)*HWRGEN(0) IF (RANWT.LT.SAVWT(1)) THEN CALL HWHSSQ ELSEIF (RANWT.LT.SAVWT(2)) THEN CALL HWHSSG ELSE CALL HWHSSL ENDIF ELSE CALL HWHSSQ SAVWT(1)=EVWGT CALL HWHSSG SAVWT(2)=SAVWT(1)+EVWGT CALL HWHSSL SAVWT(3)=SAVWT(2)+EVWGT EVWGT=SAVWT(3) ENDIF ELSEIF (ISP.EQ.10) THEN CALL HWHSSQ ELSEIF (ISP.EQ.20) THEN CALL HWHSSG ELSEIF (ISP.EQ.30) THEN CALL HWHSSL ELSE C---UNRECOGNIZED PROCESS CALL HWWARN('HWHSSP',500) ENDIF END CDECK ID>, HWHSSS. *CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR) C----------------------------------------------------------------------- C IDENTIFIES HARD SUSY SUBPROCESS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL PARAMETER (SSL = 400) IHPRO = 3000 + IHPR IDN(3) = SSL + ID3 + R3*6 IDN(4) = SSL + ID4 + R4*6 ICO(1) = IPERM/1000 ICO(2) = IPERM/100 - 10*ICO(1) ICO(3) = IPERM/10 - 10*(IPERM/100) ICO(4) = IPERM - 10*(IPERM/10) END CDECK ID>, HWHV1J. *CMZ :- -18/05/99 14.37.45 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHV1J C----------------------------------------------------------------------- C V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5). C USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING C IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U, & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET, & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV,HWUAEM,TMIN,TMAX INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2, $ IDV,IDI,IDM EXTERNAL HWRINT SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI SAVE IDINIT,ICOFLO C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES DATA IDINIT/1,8,2,7,3,10,4,9,5,12,6,11,1,10,2,9,3,8,4,7,5,12,6,11, $ 1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/ C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH C POSSIBLE SUB-PROCESS. C INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ), C 2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR), C 3=PROCESS (1=ANNIHILATION, 2=COMPTON) DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0.D0/ IF (GENEV) THEN DISMAX=0 DO 110 I=1,2 DO 110 J=1,12 DO 110 K=1,2 110 DISMAX=MAX(DISFAC(K,J,I),DISMAX) 120 I=HWRINT(1,2) J=HWRINT(1,12) K=HWRINT(1,2) IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120 IF (I.EQ.1) THEN C---ANNIHILATION IDN(1)=IDINIT(K,J,IDI) IDN(2)=IDINIT(3-K,J,IDI) IDN(4)=13 ELSE C---COMPTON SCATTERING IDN(1)=J IDN(2)=13 IF (IDV.EQ.200) THEN IDN(4)=J ELSE IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...) IDN(4)=4*INT((J-1)/2)-J+3 ELSE C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...) IDN(4)=12*INT((J-1)/6)-J+5 ENDIF ENDIF IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120 IF (K.EQ.2) THEN C---SWAP INITIAL STATES IDN(3)=IDN(1) IDN(1)=IDN(2) IDN(2)=IDN(3) ENDIF ENDIF IF (IDV.EQ.200) THEN IDN(3)=200 ELSE C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2)))) ENDIF M=K IF (I.EQ.2.AND.J.LE.6) M=3-K DO 130 L=1,4 130 ICO(L)=ICOFLO(L,M) IDCMF=15 COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2) C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS RMASS(IDN(3))=SQRT(EMV2) C-- BRW fix 27/8/04: avoid double smearing of V mass CALL HWETWO(.FALSE.,.TRUE.) RMASS(IDN(3))=EMV RHOHEP(1,NHEP-1)=0.5 RHOHEP(2,NHEP-1)=0.0 RHOHEP(3,NHEP-1)=0.5 ELSE EVWGT=0. IHPRO=MOD(IPROC,100)/10 IF (IHPRO.LT.5) THEN IDV=198 IDI=1 IDM=10 GAMV=GAMW ELSE IDV=200 IDI=2 IDM=6 GAMV=GAMZ IHPRO=IHPRO-5 ENDIF EMV=RMASS(IDV) c---mhs---implement cut on number of widths from nominal mass TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV) TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV) EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX))) IF (EMV2.LE.ZERO) RETURN CALL HWRPOW(ET,EJ) PT=0.5*ET EMT=SQRT(PT**2+EMV2) EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3)) IF (EMAX.LE.EMT) RETURN VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2)) & /(EMAX-SQRT(EMAX**2-EMT**2))) VYMIN=-VYMAX IF (VYMAX.LE.VYMIN) RETURN Z=EXP(HWRUNI(0,VYMIN,VYMAX)) S= PHEP(5,3)**2 T=-PHEP(5,3)*EMT/Z+EMV2 U=-PHEP(5,3)*EMT*Z+EMV2 XXMIN=-U/(S+T-EMV2) IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN) YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX) IF (YMAX.LE.YMIN) RETURN XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3) IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN THAT =XX(1)*T+(1.-XX(1))*EMV2 XX(2)=-THAT / (XX(1)*S+U-EMV2) IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN UHAT =XX(2)*U+(1.-XX(2))*EMV2 SHAT =XX(1)*XX(2)*S EMSCA=EMT CALL HWSGEN(.FALSE.) c---mhs minor improvement: replace thomson coupling by running coupling c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN) $ *EMV2/EMV**2 SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2) & /(SHAT**2*THAT*UHAT) SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT) & /(-UHAT*SHAT**3) SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT) & /(-THAT*SHAT**3) C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER IF (IHPRO.EQ.1) THEN SIGCOM(1)=0. SIGCOM(2)=0. ENDIF IF (IHPRO.EQ.2) SIGANN=0. DO 210 I=1,IDM IF (IDV.EQ.200) THEN J=I IF(I.GT.6) J=I-6 DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2) ELSE IF (I.LE.4) THEN DISFAC(1,I,1)=1-SCABI ELSEIF (I.GE.7) THEN DISFAC(1,I,1)=SCABI ELSE DISFAC(1,I,1)=1. ENDIF ENDIF DISFAC(2,I,1)=DISFAC(1,I,1) * & SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1) DISFAC(1,I,1)=DISFAC(1,I,1) * & SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2) 210 CONTINUE DO 211 I=IDM+1,12 DISFAC(1,I,1)=0 DISFAC(2,I,1)=0 211 CONTINUE DO 220 I=1,12 IF (IDV.EQ.200) THEN J=I IF(I.GT.6) J=I-6 DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2) ELSE DISFAC(1,I,2)=1. c---mhs fix: switch off bg->Wt process since we neglect quark masses! IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0 ENDIF DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1) DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2) 220 CONTINUE DO 230 I=1,2 DO 230 J=1,12 DO 230 K=1,2 230 EVWGT=EVWGT+DISFAC(K,J,I) CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*(TMAX-TMIN)/PIFAC C---INCLUDE BRANCHING RATIO OF V CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0) EVWGT=EVWGT*CSFAC*BR ENDIF END CDECK ID>, HWHV2J. *CMZ :- -14/03/01 09:03:25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWHV2J C----------------------------------------------------------------------- C Vector Boson production with two hard jets C Master subroutine for all vector boson + 2 jet processes C Currently implemented qqbar Z only C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD, & ICOL(5),IDZ,IQ DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX, & MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4, & MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2, & AMP,WI(IMAXCH) DOUBLE COMPLEX S,D,F LOGICAL FSTCLL,MASS,GEN EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWHEWS/S(8,8,2),D(8,8) COMMON/HWHZBB/F(8,8) COMMON /HWPSOM/ WI SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4, & IQ,MASS SAVE B,BRZED DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/ DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0, & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/ C--generate the event IF(GENEV) THEN C--find the particles produced IF(IPRC.EQ.0) THEN WRITE(*,1000) STOP ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS) ELSE CALL HWWARN('HWHV2J',502) ENDIF IF(ORD.EQ.2) THEN IB = IDP(1) IDP(1) = IDP(2) IDP(2) = IB PRW(3,1) = -PRW(3,1) DO I=3,6 PLAB(3,I)=-PLAB(3,I) ENDDO ENDIF C--enter the incoming particles ICMF = NHEP+3 DO I=1,2 IHEP = NHEP+I CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP)) IDHW(IHEP) = IDP(I) IDHEP(IHEP)= IDPDG(IDP(I)) ISTHEP(IHEP)=110+I JMOHEP(1,IHEP)=ICMF JMOHEP(I,ICMF)=IHEP JDAHEP(1,IHEP)=ICMF ENDDO IDHW(ICMF)=15 IDHEP(ICMF)=IDPDG(15) ISTHEP(ICMF)=110 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF)) CALL HWUMAS(PHEP(1,ICMF)) JDAHEP(1,ICMF) = ICMF+1 JDAHEP(2,ICMF) = ICMF+3 NHEP = NHEP+3 C--Now the outgoing jets DO 10 I=1,2 CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I)) C--Set the status and pointers ISTHEP(NHEP+I)=113 IDHW(NHEP+I)=IDP(2+I) IDHEP(NHEP+I)=IDPDG(IDP(2+I)) JMOHEP(1,NHEP+I)=NHEP 10 CONTINUE NHEP=NHEP+2 C--Now sort out the colour connections ICOL(1)=IFLOW/1000 ICOL(2)=IFLOW/100-10*ICOL(1) ICOL(3)=IFLOW/10 -10*(IFLOW/100) ICOL(4)=IFLOW -10*(IFLOW/10) DO 30 I=1,4 J=I IF (J.GT.2) J=J+1 K=ICOL(I) IF (K.GT.2) K=K+1 JMOHEP(2,NHEP-5+J)=NHEP+K-5 30 JDAHEP(2,NHEP-5+K)=NHEP+J-5 C--Now add the Z to the event record CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1)) CALL HWVZRO(4,VHEP(1,NHEP+1)) CALL HWUDKL(200,PHEP(1,NHEP+1),DT) CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT) IDHW(NHEP+1)=IDBS IDHEP(NHEP+1)=IDPDG(IDBS) JMOHEP(1,NHEP+1)=ICMF JMOHEP(2,NHEP+1)=ICMF ISTHEP(NHEP+1)=114 NHEP = NHEP+1 IBRAD = NHEP C--generate the inital-state shower CALL HWBGEN C--now add the decay products of the Z IZ = JDAHEP(1,IBRAD) ISTHEP(IZ) = 195 JDAHEP(1,IZ) = NHEP+1 JDAHEP(2,IZ) = NHEP+2 IDHW(NHEP+1) = IDP(5) IDHW(NHEP+2) = IDP(6) ISTHEP(NHEP+1) = 113 ISTHEP(NHEP+2) = 114 IDHEP(NHEP+1) = IDPDG(IDP(5)) IDHEP(NHEP+2) = IDPDG(IDP(6)) JMOHEP(1,NHEP+1) = IZ JMOHEP(1,NHEP+2) = IZ JMOHEP(2,NHEP+1) = NHEP+2 JDAHEP(2,NHEP+1) = NHEP+2 JMOHEP(2,NHEP+2) = NHEP+1 JDAHEP(2,NHEP+2) = NHEP+1 CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1)) CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2)) DO IHEP=NHEP+1,NHEP+2 CALL HWVEQU(4,DT,VHEP(1,IHEP)) C--Boost the fermion momenta to the rest frame of the original Z CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP)) C--Now boost back to the lab from rest frame of the Z after radiation CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP)) ENDDO NHEP = NHEP+2 ELSE C--initialisation IF(FSTWGT) THEN C--for second option minimum invariant mass of the jet pair C--set the type of events to be generated TWOPI2= FOUR*PIFAC**2 FPI4 = (FOUR*PIFAC)**4 IPRC = MOD(IPROC,100) IF(IPRC.GE.0.AND.IPRC.LE.16) THEN C--Z + 2 jets MBOS = RMASS(200) MBOS2 = MBOS**2 GMBS = MBOS2*GAMZ**2 IDBS = 200 MQ(1) = ZERO MQ(2) = ZERO IF(IPRC.EQ.0) THEN IQ = 0 ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN IQ = IPRC IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ) ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN MASS = .TRUE. IQ = IPRC-10 MQ(1) = RMASS(IQ) MQ(2) = RMASS(IQ) IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2) ELSE CALL HWWARN('HWHV2J',500) ENDIF DO I=1,2 MQ2(I) = MQ(I)**2 ENDDO ELSE CALL HWWARN('HWHV2J',503) ENDIF FSTCLL = .TRUE. ENDIF C--generate the weight EVWGT = ZERO C--find the mass of the gauge boson CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2, & EMMIN**2) MQ(3) = SQRT(MQ2(3)) MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS) C--do the phase space CALL HWH2PS(FLUX,GEN,MQ,MQ2) AMP = ONE IF(.NOT.GEN) RETURN C--copy the gauge boson momentum CALL HWVEQU(5,PLAB(1,5),PRW(1,1)) C--select the decay mode of the boson CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0) IDZ = IDP(5) IF(IDZ.GT.6) IDZ = IDZ-114 BR = BR/BRZED(IDZ) IF(IDZ.LE.6) AMP = AMP*THREE C--Finds the momenta of the boson decay products PST=HWUPCM(PRW(5,1),ZERO,ZERO) PLAB(5,5)=ZERO PLAB(5,6)=ZERO IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.) MJAC = HALF*PST*MJAC/TWOPI2/MQ(3) C--copy the momenta, change order and boost to CMF PTP(1,1) = ZERO PTP(2,1) = ZERO PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3) PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3) PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2)) DO I=1,6 CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2)) PCM(1,I)=PTP(3,2) PCM(2,I)=PTP(1,2) PCM(3,I)=PTP(2,2) PCM(4,I)=PTP(4,2) ENDDO IF(MASS) THEN C--Massive momentum case C--reorder the products C--move b and bbar to 9 and 10 DO I=3,4 DO J=1,5 PCM(J,I+6) = PCM(J,I) ENDDO ENDDO C--select the reference momenta for the b and bbar and put in 3,4 C--the results is independent of this choice CALL HWVEQU(5,PCM(1,1),PCM(1,3)) CALL HWVEQU(5,PCM(1,1),PCM(1,4)) C--find the massless vectors for the b and bbar PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9)) PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10)) DO I=1,4 PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3) PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4) ENDDO PCM(5,7) = ZERO PCM(5,8) = ZERO C--use e+e- code to calculate the spinor products CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D) DO I=1,8 DO J=1,8 S(I,J,2) = -S(I,J,2) D(I,J) = TWO*D(I,J) ENDDO ENDDO ELSE C--Massless case, use the e+e- code to calculate the spinor products CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D) DO I=1,6 DO J=1,6 D(I,J) = TWO*D(I,J) F(I,J) = B(I)*B(J)*D(I,J) S(I,J,2) = -S(I,J,2) ENDDO ENDDO ENDIF C--now call the code to calculate the matrix element*PDF IF(IPRC.EQ.0) THEN WRITE(*,1000) STOP ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS) ELSE CALL HWWARN('HWHV2J',501) GOTO 999 ENDIF AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2 EVWGT = FLUX*ME*AMP IF(OPTM) THEN DO I=1,IMAXCH IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2 ENDDO ENDIF ENDIF RETURN 1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED') 999 RETURN END CDECK ID>, HWHVVJ. *CMZ :- -11/05/01 09.19.45 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHVVJ C----------------------------------------------------------------------- C VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870 C----------------------------------------------------------------------- IMPLICIT NONE PRINT *,' VV + 1 JET CALLED BUT NOT YET IMPLEMENTED' CALL HWWARN('HWHVVJ',500) END CDECK ID>, HWHWEX. *CMZ :- -26/04/91 14.55.45 by Federico Carminati *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWHWEX C----------------------------------------------------------------------- C TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB C C-S IS SUM OF: C UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB C UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE C (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW, & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX INTEGER HWRINT,IDHWEX(2,16),I EXTERNAL HWRGEN,HWRUNI,HWRINT SAVE DSDCOS,DSMAX EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6)) C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS SAVE IDHWEX DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4, & 8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/ EMT2=EMT**2 EMW2=EMW**2 IF (GENEV) THEN 300 IHPRO=HWRINT(1,16) IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300 DO 10 I=1,2 IDN(I)=IDHWEX(I,IHPRO) IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN C---CHANGE B QUARK INTO T QUARK IDN(I+2)=IDN(I)+1 ELSEIF (HWRGEN(0).GT.SCABI) THEN C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...) IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3 ELSE C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...) IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5 ENDIF ICO(I)=I+2 ICO(I+2)=I 10 CONTINUE IDCMF=15 CALL HWETWO(.TRUE.,.TRUE.) ELSE EVWGT=0. CMFMIN=EMT TAUMIN=(CMFMIN/PHEP(5,3))**2 TAUMLN=LOG(TAUMIN) ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN))) XXMIN=(ROOTS/PHEP(5,3))**2 XLMIN=LOG(XXMIN) COSTH=HWRUNI(0,-ONE, ONE) S=ROOTS**2 T=-0.5*S*(1-COSTH) U=-0.5*S*(1+COSTH) EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U)) DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2 & *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2 DSDCOS(2)=DSDCOS(1) / 4 & * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2) DSDCOS(3)=DSDCOS(2) DSDCOS(4)=DSDCOS(1) C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS IHPRO=MOD(IPROC,100) IF (IHPRO.GT.8) THEN CALL HWWARN('HWHWEX',1) IHPRO=0 ENDIF DO 100 I=1,8 IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I) IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0 DSDCOS(I+8)=DSDCOS(I) 100 CONTINUE CALL HWSGEN(.TRUE.) DSMAX=0 DO 200 I=1,16 DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2) EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I) IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I) 200 CONTINUE ENDIF END CDECK ID>, HWHWPR. *CMZ :- -18/05/99 14.22.13 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHWPR C----------------------------------------------------------------------- C W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS C MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW, & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16) LOGICAL HWRLOG EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB SAVE IWP DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3, & 2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/ IF (GENEV) THEN C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND) PRAN=PROB*HWRGEN(0) C---LOOP OVER PARTON FLAVOURS PROB=0. COEF=1.-SCABI DO 10 IC=1,16 IF (IC.EQ.9) COEF=SCABI PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF IF (PROB.GE.PRAN) GOTO 20 10 CONTINUE C---STORE INCOMING PARTONS 20 IDN(1)=IWP(1,IC) IDN(2)=IWP(2,IC) ICO(1)=2 ICO(2)=1 C---ICH=1/2 FOR W+/- ICH=2-MOD(IC,2) IF ((IDEC.GT.49.AND.IDEC.LT.54).OR. & (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN C---LEPTONIC DECAY IL=IDEC-50 IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3) IDN(3)=2*IL+121-ICH IDN(4)=2*IL+124+ICH C---W DECAY ANGLE (1+COSTH)**2 COSTH=2.*HWRGEN(1)**0.3333-1. ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR. & ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN C---W -> TOP + BOTTOM DECAY IDN(3)=7-ICH IDN(4)=10+ICH 21 COSTH=HWRUNI(1,-ONE, ONE) IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT. & PMAX*HWRGEN(1)) GOTO 21 ELSE C---OTHER HADRONIC DECAY 25 PROB=0. PRAN=2.*HWRGEN(2) COEF=1.-SCABI DO 30 ID=ICH,16,4 IF (ID.GT.8) COEF=SCABI PROB=PROB+COEF IF (PROB.GE.PRAN) THEN IDN(3)=IWP(1,ID) IDN(4)=IWP(2,ID) GOTO 40 ENDIF 30 CONTINUE 40 CONTINUE IF (IDEC.GT.0.AND.IDEC.LT.5) THEN JDEC=IDEC+6 IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC & .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25 ENDIF COSTH=2.*HWRGEN(1)**0.3333-1. ENDIF IDCMF=197+ICH IF (IDN(1).GT.6) COSTH=-COSTH ICO(3)=4 ICO(4)=3 CALL HWETWO(.TRUE.,.TRUE.) ELSE IDEC=MOD(IPROC,100) IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199))) ELSE TMIN=-ATAN(RMASS(199)/GAMW) ENDIF EVWGT=0. c---mhs---implement cut on number of widths from nominal mass C--BRW fix 4/12/07: allow GAMMAX>Mass/Gamma IF (GAMW*GAMMAX.LT.RMASS(199)) & TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199))) C--End BRW fix 4/12/07 TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199)) EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+RMASS(199) IF (EMW.LE.ZERO) RETURN EMW=SQRT(EMW*RMASS(199)) IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN EMSCA=EMW IF (EMLST.NE.EMW) THEN EMLST=EMW XXMIN=(EMW/PHEP(5,3))**2 XLMIN=LOG(XXMIN) CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2) & /(3.*SWEIN*RMASS(199)**2)*XLMIN C---COMPUTE TOP AND LEPTONIC FRACTIONS FTQK=0. IF (NFLAV.GT.5) THEN PTOP=HWUPCM(EMW,RMASS(5),RMASS(6)) IF (PTOP.GT.ZERO) THEN ETOP=SQRT(PTOP**2+RMASS(6)**2) EBOT=EMW-ETOP FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3 PMAX=(ETOP+PTOP)*(EBOT+PTOP) ENDIF ENDIF FHAD=FTQK+2. FTOT=FTQK+3. C---MULTIPLY WEIGHT BY BRANCHING FRACTION IF (IDEC.EQ.0) THEN BRAF=FHAD ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN BRAF=1. ELSEIF (IDEC.LT.7) THEN BRAF=FTQK ELSEIF (IDEC.EQ.99) THEN BRAF=FTOT ELSE BRAF=1/THREE ENDIF c---mhs fix: normalization should be to on-shell total width c (only different if chosen mass is above top threshold) CSFAC=CSFAC*BRAF/THREE*(TMAX-TMIN)/PIFAC FTQK=FTQK/FHAD FLEP=1./FTOT ENDIF CALL HWSGEN(.TRUE.) C---LOOP OVER PARTON FLAVOURS PROB=0. COEF=1.-SCABI DO 100 IC=1,16 IF (IC.EQ.9) COEF=SCABI PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF 100 CONTINUE EVWGT=PROB*CSFAC ENDIF END CDECK ID>, HWICHK. *-- Author : M. Kirsanov C----------------------------------------------------------------------- SUBROUTINE HWICHK C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' IF(RMASS(1).LT.0.1.OR.RMASS(1).GT.1.0.OR. & FMRS(1,1,20,1).LT.0.1.OR.FMRS(1,1,20,1).GT.1.0) THEN STOP 'Block data hwudat not loaded, stop execution' ENDIF END CDECK ID>, HWIODK. *CMZ :- -27/07/99 13.33.03 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWIODK(IUNIT,IOPT,IME) C----------------------------------------------------------------------- C If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT C < 0 reads in decay tables from unit IUNIT C The format used during the read/write is specified by IOPT C =1 PDG; =2 HERWIG numeric; =3 HERWIG character name. C When reading in if IME =1 matrix element codes >= 100 are accepted C 0 are set zero. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM JUNIT=ABS(IUNIT) OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN') IF (IUNIT.GT.0) THEN C Write out the decay table WRITE(JUNIT,100) NDKYS IF (IOPT.EQ.1) THEN DO 20 I=1,NRES IF (NMODES(I).EQ.0) GOTO 20 K=LSTRT(I) DO 10 J=1,NMODES(I) WRITE(JUNIT,110) IDPDG(I),BRFRAC(K),NME(K), & (IDPDG(IDKPRD(L,K)),L=1,5) 10 K=LNEXT(K) 20 CONTINUE ELSEIF (IOPT.EQ.2) THEN DO 40 I=1,NRES IF (NMODES(I).EQ.0) GOTO 40 K=LSTRT(I) DO 30 J=1,NMODES(I) WRITE(JUNIT,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5) 30 K=LNEXT(K) 40 CONTINUE ELSEIF (IOPT.EQ.3) THEN DO 60 I=1,NRES IF (NMODES(I).EQ.0) GOTO 60 K=LSTRT(I) DO 50 J=1,NMODES(I) WRITE(JUNIT,130) RNAME(I),BRFRAC(K),NME(K), & (RNAME(IDKPRD(L,K)),L=1,5) 50 K=LNEXT(K) 60 CONTINUE ENDIF ELSEIF (IUNIT.LT.0) THEN C Read in the decay table and convert to HERWIG numeric format READ(JUNIT,100) NDKYS IF (NDKYS.GT.NMXDKS) THEN CALL HWWARN('HWIODK',100) GOTO 999 ENDIF IF (IOPT.EQ.1) THEN DO 70 I=1,NDKYS READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0 CALL HWUIDT(1,IDKY,IDK(I),CDUM) DO 70 J=1,5 70 CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM) ELSEIF (IOPT.EQ.2) THEN DO 80 I=1,NDKYS READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5) IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20 80 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0 ELSEIF (IOPT.EQ.3) THEN DO 90 I=1,NDKYS READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5) IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0 CALL HWUIDT(3,IDUM,IDK(I),CDK(I)) DO 90 J=1,5 90 CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I)) ELSE CALL HWWARN('HWIODK',101) GOTO 999 ENDIF ENDIF CLOSE(UNIT=JUNIT) 100 FORMAT(1X,I4) 110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7)) 120 FORMAT(1X,I3,1X,F7.5,6(1X,I3)) 130 FORMAT(1X,A8,1X,F7.5,1X,I3,5(1X,A8)) 999 RETURN END CDECK ID>, HWIGIN. *CMZ :- -12/10/01 09.50.50 by Peter Richardson *-- Author : Bryan Webber C---------------------------------------------------------------------- SUBROUTINE HWIGIN C----------------------------------------------------------------------- C SETS INPUT PARAMETERS C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION FAC,ANGLE INTEGER I,J,N,L CHARACTER*28 TITLE SAVE TITLE DATA TITLE/'HERWIG 6.520 16th Aug. 2010'/ WRITE (6,10) TITLE 10 FORMAT(//10X,A28//, & 10X,'Please reference: G. Marchesini, B.R. Webber,',/, & 10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/, & 10X,'Computer Physics Communications 67 (1992) 465',/, & 10X,' and',/, & 10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,' & ,/, 10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,' & ,/, 10X,'JHEP 0101 (2001) 010') CALL HWICHK C---PRINT OPTIONS: C IPRINT=0 NO PRINTOUT C 1 PRINT SELECTED INPUT PARAMETERS C 2 1 + TABLE OF PARTICLE CODES AND PROPERTIES C 3 2 + TABLES OF SUDAKOV FORM FACTORS IPRINT=1 C Format for track numbers in event listing C PRNDEC=.TRUE. use decimal C .FALSE. use hexadecimal PRNDEC=(NMXHEP.LE.9999) C Number of significant figures to print out in event listing C NPRFMT (< 2) compact 80 character stout and A4-long tex output, C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout NPRFMT=1 C Print out vertex information PRVTX=.TRUE. C Print out particle properties/event record to stout, tex or web PRNDEF=.TRUE. PRNTEX=.FALSE. PRNWEB=.FALSE. C---MAX NO OF EVENTS TO PRINT MAXPR=1 C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM) LRSUD=0 C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN) LWSUD=77 C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN) LWEVT=0 C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN) NRN(1)= 17673 NRN(2)= 63565 C---ALLOW NEGATIVE WEIGHTS? NEGWTS=.FALSE. C---AZIMUTHAL CORRELATIONS? C THESE INCLUDE SOFT GLUON (INSIDE CONE) AZSOFT=.TRUE. C AND NEAREST-NEIGHBOUR SPIN CORRELATIONS AZSPIN=.TRUE. C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY C---HARD EMISSION HARDME=.TRUE. C---SOFT EMISSION SOFTME=.TRUE. C---GLUON ENERGY CUT FOR TOP DECAY CASE GCUTME=2 C Electromagnetic fine structure constant: Thomson limit ALPHEM=.0072993 C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY QCDLAM=0.18 C---NUMBER OF COLOURS NCOLO=3 C---NUMBER OF FLAVOURS NFLAV=6 C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN C PARTON SHOWER (ADDED TO MASSES GIVEN BELOW) VQCUT=0.48 VGCUT=0.10 VPCUT=0.40 ALPFAC=1 C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER) RMASS(1)=0.32 RMASS(2)=0.32 RMASS(3)=0.5 RMASS(4)=1.55 RMASS(5)=4.95 RMASS(6)=174.3 RMASS(13)=0.75 C---W+/- AND Z0 MASSES RMASS(198)=80.42 RMASS(199)=80.42 RMASS(200)=91.188 C---HIGGS BOSON MASS RMASS(201)=115. C---WIDTHS OF W, Z, HIGGS GAMW=2.12 GAMZ=2.495 C SM Higgs width is actually recomputed by HWDHIG C but this value corresponds to RMASS(201)=115. GAMH=0.0037 C Include additional neutral, massive vector boson (Z') ZPRIME=.FALSE. C Z' mass and width RMASS(202)=500. GAMZP=5. C Graviton properties C Graviton mass and width (default mass 1 TeV and calculated width) EMGRV = 1000.0D0 GAMGRV = ZERO C Graviton coupling (this has dimensions of mass) GRVLAM = 10000.0D0 C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in: C e+e- --> ffbar/qqbar g; and l/lbar N DIS. C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation. C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1. DO 20 I=1,3 EPOLN(I)=0. 20 PPOLN(I)=0. C----------------------------------------------------------------------- C Specify couplings of weak vector bosons to fermions: C C electric current: QFCH(I)*e*G_mu (electric charge, e>0) C weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu C weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu C C I= 1- 6: d,u,s,c,b,t (quarks) C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110') C J=1 for minimal SM: C =2 for Z' couplings (ZPRIME=.TRUE.) C K=1,2,3 for u,c,t; L=1,2,3 for d,s,b C----------------------------------------------------------------------- C Minimal standard model neutral vector boson couplings C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W); AFCH(I,1)=T3/(2*C_W*S_W) C sin**2 Weinberg angle (PDG '94) SWEIN=.2319 FAC=1./SQRT(SWEIN*(1.-SWEIN)) DO 30 I=1,3 C Down-type quarks J=2*I-1 QFCH(J)=-1./3. VFCH(J,1)=(-0.25+SWEIN/3.)*FAC AFCH(J,1)= -0.25*FAC C Up-type quarks J=2*I QFCH(J)=+2./3. VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC AFCH(J,1)= +0.25*FAC C Charged leptons J=2*I+9 QFCH(J)=-1. VFCH(J,1)=(-0.25+SWEIN)*FAC AFCH(J,1)= -0.25*FAC C Neutrinos J=2*I+10 QFCH(J)=0. VFCH(J,1)=+0.25*FAC AFCH(J,1)=+0.25*FAC 30 CONTINUE C Additional Z' couplings (To be set by the user) IF (.NOT.ZPRIME) THEN DO 40 I=1,6 AFCH(I,2)=0. AFCH(10+I,2)=0. VFCH(I,2)=0. VFCH(10+I,2)=0. 40 CONTINUE ENDIF C--calculate left and right couplings of bosons for axial and vector ones DO 45 J=1,16 IF(J.LE.6.OR.J.GE.11) THEN LFCH(J)=VFCH(J,1)+AFCH(J,1) RFCH(J)=VFCH(J,1)-AFCH(J,1) ENDIF 45 CONTINUE C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92): C sin**2 of Cabibbo angle SCABI=.0488 C u ---> d,s,b VCKM(1,1)=1.-SCABI VCKM(1,2)=SCABI VCKM(1,3)=0.0 C c ---> d,s,b VCKM(2,1)=SCABI VCKM(2,2)=1.-SCABI-.002 VCKM(2,3)=0.002 C t ---> d,b,s VCKM(3,1)=0.0 VCKM(3,2)=0.002 VCKM(3,3)=0.998 C---GAUGE BOSON DECAYS DO 50 I=1,12 BRHIG(I)=1.D0/12 ENHANC(I)=1.D0 50 CONTINUE DO 55 I=1,MODMAX MODBOS(I)=0 55 CONTINUE C C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS C MODBOS(i) W DECAY Z DECAY C 0 all all C 1 qqbar qqbar C 2 enu e+e- C 3 munu mu+mu- C 4 taunu tau+tau- C 5 enu & munu ee & mumu C 6 all nunu C 7 all bbbar C >7 all all C BOSON PAIRS (eg FROM HIGGS DECAY)ARE CHOSEN FROM MODBOS(i),MODBOS(i+1) C C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS) IOPHIG=3 GAMMAX=10. C Specify approximation used in HWHIGA IAPHIG=1 C---MASSES OF HYPOTHETICAL NEW QUARKS GO C INTO 209-214 (ANTIQUARKS IN 215-220) C ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C C 211,212 ARE B',T' WITH DECAYS T'->B'->T C 215-218 ARE THEIR ANTIQUARKS RMASS(209)=200. RMASS(215)=200. C---MAXIMUM CLUSTER MASS PARAMETERS C N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS C IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW) CLMAX=3.35 CLPOW=2.0 C For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster C =2 heavy b cluster C---MASS SPECTRUM OF PRODUCTS IN CLUSTER C SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*) PSPLT(1)=1.0 PSPLT(2)=PSPLT(1) C---KINEMATIC TREATMENT OF CLUSTER DECAY C 0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS CLDIR(1)=1 CLDIR(2)=CLDIR(1) C IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION: C ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*) CLSMR(1)=0.0 CLSMR(2)=CLSMR(1) C---OPTION FOR TREATMENT OF REMNANT CLUSTERS: C 0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS) C 1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL IOPREM=1 C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION C 0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT C SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER) C 1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC C 2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC ISPAC=0 C---LOWER LIMIT FOR SPACELIKE EVOLUTION QSPAC=2.5 C---SWITCH OFF SPACE-LIKE SHOWERS NOSPAC=.FALSE. C---INTRINSIC PT OF SPACELIKE PARTONS (RMS) PTRMS=0.0 C---MASS PARAMETER IN REMNANT FRAGMENTATION BTCLM=1.0 C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS PDFX0=0 PDFPOW=0 C---STRUCTURE FUNCTION SET: C SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY C PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I MODPDF(1)=-1 MODPDF(2)=-1 AUTPDF(1)='MRS' AUTPDF(2)='MRS' C OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET: C 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE) C 3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY) C 5 FOR OWENS SET 1.1 (SOFT GLUE ONLY) C 6 FOR MRST98LO central alpha_s/gluon C 7 FOR MRST98LO higher gluon C 8 FOR MRST98LO average of central and higher gluon (default) NSTRU=8 C PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS C AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS C 1 IF MCL(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION, B1LIM=0.0 C--EXTRA MASS FOR DIQUARKS IN B & C BARYON PARTONIC DECAYS DQXTRA=0.2D0 C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO) BDECAY='HERW' C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA) TAUDEC='HERWIG' C--default options for TAUOLA (if used) C JAK=0 ALL MODES C JAK=1 ELECTRON MODE C JAK=2 MUON MODE C JAK=3 PION MODE C JAK=4 RHO MODE C JAK=5 A1 MODE C JAK=6 K MODE C JAK=7 K* MODE C JAK=8 nPI MODE C--tau decay modes (1 is tau+ and 2 is tau-) JAK1 = 0 JAK2 = 0 C--radiative corrections in tau decay (1 on/ 0 off) ITDKRC=1 C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS) IFPHOT=1 C--use PHOTOS in ttbar production and decay ITOPRD=0 C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION C IF (FIX4JT) THEN SCALE=C.M. ENERGY C ELSE SCALE=2.*MIN(PI.PJ) FIX4JT=.FALSE. C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION C IF (BGSHAT) THEN SCALE=SHAT C ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2) BGSHAT=.FALSE. C---RECONSTRUCT DIS EVENTS IN BREIT FRAME BREIT=.TRUE. C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME) USECMF=.TRUE. C---TREAT W/Z DECAY IN ITS REST FRAME WZRFR=.TRUE. C---PROBABILITY OF UNDERLYING SOFT EVENT: PRSOF=ONE C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS C DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445 C NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3 PMBN1= 9.11 PMBN2= 0.115 PMBN3=-9.50 C 1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2 PMBK1= 0.029 PMBK2=-0.104 C SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M) PMBM1= 0.4 PMBM2= 2.0 C SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2)) C B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS PMBP1= 5.2 PMBP2= 3.0 PMBP3= 5.2 C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT: C NCH = NCH_PPBAR(ENSOF*SQRT(S)) ENSOF=1. C PARAMETERS FOR MUELLER TANG FORMULA: IPROC=2400 C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR ASFIXD=0.25 C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S OMEGA0=0.3 C---MIN AND MAX JET RAPIDITIES IN QCD 2->2, C HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES YJMAX=8. YJMIN=-YJMAX C---MIN AND MAX PARTON TRANSVERSE MOMENTUM C IN ELEMENTARY 2 -> 2 SUBPROCESSES PTMIN=1D1 PTMAX=1D8 C---UPPER LIMIT ON HARD PROCESS SCALE QLIM=1D8 C---MAX PARTON THRUST IN 2->3 HARD PROCESSES THMAX=0.9 C Set parameters for 2->4 hard process C Choose inter-jet metric (else JADE) and minimum y-cut DURHAM=.TRUE. Y4JT=0.01 C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS: C qqbar-gg case: C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421 C qqbar-qqbar (identical quark flavour) case: C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143 IOP4JT(1)=0 IOP4JT(2)=0 C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS EMMIN=0D0 EMMAX=1D8 C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING Q2MIN=0D0 Q2MAX=1D10 C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION Q2WWMN=0. Q2WWMX=4. C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION YWWMIN=0. YWWMAX=1. C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS) WHMIN=0. C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL C PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS PHOMAS=0. C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130 IFLMIN=1 IFLMAX=5 C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION ZJMAX=0.9 C---MIN AND MAX BJORKEN-Y YBMIN=0. YBMAX=1. C---MIN jet-jet mass in Drell-Yan+2 jets MJJMIN = 10.0D0 C---MAX COS(THETA) FOR W'S IN E+E- -> W+W- CTMAX=0.9999 C Minimum virtuality^2 of partons to use in calculating distances VMIN2=0.1 C Exageration factor for lifetimes of weakly decaying heavy particles EXAG=1. C Include colour rearrangement in cluster formation CLRECO=.FALSE. C Probability for colour rearrangement to occur PRECO=1./9. C Minimum lifetime for particle to be considered stable PLTCUT=1.D-8 C Incude neutral B-meson mixing MIXING=.TRUE. C Set B_s and B_d mixing parameters: X=Delta m/Gamma XMIX(1)=10.0 XMIX(2)=0.70 C Y=Delta Gamma/2*Gamma YMIX(1)=0.2 YMIX(2)=0.0 C Include a cut on particle decay lengths MAXDKL=.FALSE. C Set option for decay length cut (see HWDXLM) IOPDKL=1 C Radius for cylindrical option (mm) (IOPDKL=1) DXRCYL=20.0D0 C Length for cylindrical option(IOPDKL=1) DXZMAX=500.0D0 C Radius for spherical option(IOPDKL=2) DXRSPH=100.0D0 C Smear the primary interaction vertex: see HWRPIP for details PIPSMR=.FALSE. C Widths of Gaussian smearing in x,y,z (mm) VIPWID(1)=0.25D0 VIPWID(2)=0.015D0 VIPWID(3)=1.8D0 DO 60 I=0,NMXRES C Veto cluster decays into particle type I VTOCDK(I)=.FALSE. C Veto unstable particle decays into modes involving particle type I 60 VTORDK(I)=.FALSE. C Veto f_0(980) and a_0(980) production in cluster decays VTOCDK(290)=.TRUE. VTOCDK(291)=.TRUE. VTOCDK(292)=.TRUE. VTOCDK(293)=.TRUE. C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR TMNISR=1D-4 ZMXISR=1-1D-6 C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS COLISR=.FALSE. C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states: C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0) DO 70 N=0,4 DO 70 J=0,4 DO 70 L=0,3 70 REPWT(L,J,N)=1. C and singlet (Lambda-like) and decuplet barons SNGWT=1. DECWT=1. C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER) PWT(1)=1. PWT(2)=1. PWT(3)=1. PWT(4)=1. PWT(5)=1. PWT(6)=1. PWT(7)=1. C Octet-Singlet isoscalar mixing angles in degrees C (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX) ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE) C eta - eta' ETAMIX=-23. C phi - omega PHIMIX=+36. C h_1(1380) - h_1(1170) H1MIX=ANGLE C MISSING - f_0(1370) F0MIX=ANGLE C f_1(1420) - f_1(1285) F1MIX=ANGLE C f'_2 - f_2 F2MIX=+26. C MISSING - omega(1600) OMHMIX=ANGLE C eta_2(1645) - eta_2(1870) ET2MIX=ANGLE C phi_3 - omega_3 PH3MIX=+28. C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO C DIQUARK-ANTIDIQUARK PAIRS: C SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS C (0.0 FOR NO SPLITTING) QDIQK=0.0 C PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING PDIQK=5.0 C---PARAMETERS FOR IMPORTANCE SAMPLING C ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW) C WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS PTPOW=4. C DEFAULT PTPOW=2 FOR SUSY PROCESSES IF (MOD(IPROC/100,100).EQ.30) PTPOW=2. C ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW) EMPOW=4. C ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW) Q2POW=2.5 C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)? NOWGT=.TRUE. C---DEFAULT MEAN EVENT WEIGHT AVWGT=1. C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE) WGTMAX=0. C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY EFFMIN=1D-3 C---MAX NO OF (CODE.GE.100) ERRORS MAXER=MAX(10,MAXEV/100) C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY TLOUT=5. C---CURRENT NO OF EVENTS NEVHEP=0 C---CURRENT NO OF ENTRIES IN /HEPEVT/ NHEP=0 C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING) ISTAT=0 C---IERROR IS ERROR CODE IERROR=0 C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT C---PI PIFAC=ACOS(-1.D0) C Speed of light (mm/s) CSPEED=2.99792D11 C Cross-section conversion factor (hbar.c/e)**2 GEV2NB=389379.D0 C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH IBSH=10000 C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH IBRN(1)=1246579 IBRN(2)=8447766 C--Number of shots and steps for the optimisation procedure IOPSH = 1000 IOPSTP = 10 C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS NQEV=1024 C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING ZBINM=0.05 C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING NZBIN=100 C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS) NBTRY=200 C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY NCTRY=200 C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED NETRY=200 C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS NSTRY=200 C---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS NSNTRY=500 C---MAXIMUM NUMBER OF TRIES TO GENERATE FOUR/FIVE BODY DECAYS NDETRY=20000 C---PRECISION FOR GAUSSIAN INTEGRATION ACCUR=1.D-6 C---ORDER OF INTERPOLATION IN SUDAKOV TABLES INTER=3 C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES SUDORD=1 C---DEFAULT UNIT FOR THE SUSY DATA FILE LRSUSY = 66 C---CONSERVATION OF RPARITY RPARTY = .TRUE. C---CHECK WHETHER SUSY DATA INPUTTED SUSYIN = .FALSE. C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS SYSPIN = .TRUE. C---THREE BODY SUSY MATRIX ELEMENTS THREEB = .TRUE. C---FOUR BODY SUSY MATRIX ELEMENTS FOURB = .FALSE. C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION C---(1 is first option in DAMTP-2001-83 only for SM/MSSM) C---(2 is second option in DAMTP-2001-83 needed for RPV) SPCOPT = 1 C---number of weights for maximum search for 3/4 body MEs NSEARCH = 500 C--unit to read three/four body decays from (if 0 computed) LRDEC = 0 C--unit to write three/four body decays to (if 0 not written) LWDEC = 88 C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES OPTM = .FALSE. C--initializes the multichannel integrals CALL HWIPHS(1) C CIRCE INTERFACE C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES: C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG C 1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS C 2=BEAMSTRAHLUNG FROM CIRCE C 3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG C THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON. THE OTHERS ARE C MAINLY THERE FOR CROSS-CHECKING PURPOSES CIRCOP=0 C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT C EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND CIRCAC=2 CIRCVR=7 CIRCRV=9999 12 31 CIRCCH=0 C---END OF CIRCE VARIABLES C--options for Les Houches Accord C--allow self connected gluons (.TRUE.) or forbid (.FALSE.) LHGLSF = .FALSE. C--generate the soft event (.TRUE.) or don't (.FALSE.) LHSOFT = .TRUE. C--conserve longitudinal momentum (.true.) or rapidity of hard process PRESPL = .TRUE. C--BRW mod 21/11/06 to allow for truncated shower and pt-veto TRUNSH = .FALSE. PTVETO = .FALSE. END CDECK ID>, HWIGUP. *CMZ :- -15/07/02 16.42.23 by Peter Richardson *-- Author : Peter Richardson C---------------------------------------------------------------------- SUBROUTINE HWIGUP C---------------------------------------------------------------------- C Use the GUPI (Generic User Process Interface) run common block C to initialise HERWIG C---------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER MAXPUP PARAMETER(MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP), & XMAXUP(MAXPUP),LPRUP(MAXPUP) CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9) INTEGER I,IDB(2) SAVE PDFNUC,PDFPI ,PDFPHT DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM', & ' ',' '/ DATA PDFPI / 'OW-P',' ','SMRS-P',' ','GRV-P', & 'ABFKW-P',' ',' ',' '/ DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G', & ' ','WHIT-G','SaSph'/ C--call the user routine to do the initialisation CALL UPINIT C--setup the beam particles and momentum CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY) PART1=DUMMY CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY) PART2=DUMMY PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2) PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2) C--set up for PDFLIB if need DO I=1,2 IF(PDFGUP(I).NE.-1) THEN IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) CALL HWWARN('HWIGUP',500) MODPDF(I) = PDFSUP(I) C--proton/neutron beams IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN AUTPDF(I) = PDFNUC(PDFGUP(I)) C--photon beams ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN AUTPDF(I) = PDFPHT(PDFGUP(I)) C--pion beams ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN AUTPDF(I) = PDFPI(PDFGUP(I)) C--unknown beam type ELSE CALL HWWARN('HWIGUP',500) ENDIF ENDIF ENDDO C--decide what to do about the weights IF(ABS(IDWTUP).EQ.1) THEN WGTMAX = ZERO AVWGT = ONE AVABW = ONE NOWGT = .TRUE. C--sum up the magnitudes of the maximum weight LHMXSM = ZERO DO I=1,NPRUP LHXMAX(I) = XMAXUP(I)*1.0D-3 LHMXSM = LHMXSM+ABS(LHXMAX(I)) ENDDO ITYPLH = 0 ELSEIF(ABS(IDWTUP).EQ.2) THEN WGTMAX = ZERO AVWGT = ONE AVABW = ONE NOWGT = .TRUE. C--sum the cross sections and obtain the total LHMXSM = ZERO DO I=1,NPRUP LHXSCT(I) = XSECUP(I)*1.0D-3 LHXMAX(I) = XMAXUP(I)*1.0D-3 LHMXSM = LHMXSM+ABS(LHXSCT(I)) ENDDO ITYPLH = 0 ELSEIF(ABS(IDWTUP).EQ.3) THEN WGTMAX = ONE AVWGT = ONE AVABW = ONE NOWGT = .TRUE. ELSEIF(ABS(IDWTUP).EQ.4) THEN WGTMAX = ONE AVWGT = ONE NOWGT = .FALSE. ENDIF IF(IDWTUP.LT.0) NEGWTS = .TRUE. C--zero the weight DO I=1,NPRUP LHWGT (I) = ZERO LHWGTS(I) = ZERO LHIWGT(I) = 0 LHNEVT(I) = 0 ENDDO END CDECK ID>, HWIMDE. *CMZ :- -12/10/01 17.14.22 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWIMDE C----------------------------------------------------------------------- C Subroutine to merge Higgs WW/ZZ decay modes for four body ME C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IH,I,NMODE,J,K LOGICAL REMOVE DOUBLE PRECISION BR REMOVE = .FALSE. C--first identify the WW modes DO IH=203,204 BR = ZERO NMODE = 0 DO I=NDECSY,NDKYS IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0 & .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND. & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND. & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))) & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND. & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR. & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND. & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132)) & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0) & .AND. & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR. & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND. & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132)) & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN BR=BR+BRFRAC(I) NME(I) = -100 NMODE=NMODE+1 ENDIF ENDDO C--add the new mode to the event record IF(NMODE.GT.0) THEN REMOVE = .TRUE. NDKYS = NDKYS+1 IDK(NDKYS) = IH BRFRAC(NDKYS) = BR NME(I) = 0 IDKPRD(1,NDKYS) = 198 IDKPRD(2,NDKYS) = 199 DO I=3,5 IDKPRD(I,NDKYS) = 0 ENDDO ENDIF ENDDO C--now do the ZZ modes DO IH=203,204 BR = ZERO NMODE = 0 DO I=NDECSY,NDKYS IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0 & .AND.IDKPRD(1,I).EQ.200.AND. & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND. & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)) & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND. & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR. & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND. & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132)) & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0) & .AND. & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR. & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND. & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132)) & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN BR=BR+BRFRAC(I) NME(I) = -100 NMODE=NMODE+1 ENDIF ENDDO C--add the new mode to the event record IF(NMODE.GT.0) THEN REMOVE = .TRUE. NDKYS = NDKYS+1 IDK(NDKYS) = IH BRFRAC(NDKYS) = BR NME(I) = 0 IDKPRD(1,NDKYS) = 200 IDKPRD(2,NDKYS) = 200 DO I=3,5 IDKPRD(I,NDKYS) = 0 ENDDO ENDIF ENDDO IF(.NOT.REMOVE) RETURN C--now remove the modes we have marked I = 0 DO J=NDECSY,NDKYS 10 IF(NME(I+J).EQ.-100) I=I+1 IDK(J) = IDK(J+I) BRFRAC(J)=BRFRAC(I+J) NME(J) = NME(I+J) DO K=1,5 IDKPRD(K,J)=IDKPRD(K,I+J) ENDDO IF(NME(J).EQ.-100) GOTO 10 ENDDO C--reset the number of modes NDKYS = NDKYS-I END CDECK ID>, HWIPHS. *CMZ :- -02/04/01 12.11.55 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWIPHS(IOPT) C----------------------------------------------------------------------- C Subroutine to initialise the multichannel integration C IOPT = 1 sets the weights for the different channels to their C default values C IOPT = 2 optimises the weights for the process selected C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK LOGICAL CALLED,TEV,LHC DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH), & TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH), & TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2) COMMON /HWPSOM/ WI SAVE CALLED,DEM,TEVGWT,LHCGWT,TEVQWT,LHCQWT DATA CALLED/.FALSE./ DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0, & 0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0, & 0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0, & 0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0, & 0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0, & 0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0, & 0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0, & 0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0, & 0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0, & 0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/ DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0, & 0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0, & 0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0, & 0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0, & 0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0, & 0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0, & 0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0, & 0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0, & 0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0, & 0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/ DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0, & 0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0, & 0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0, & 0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0, & 0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0, & 0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0, & 0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0, & 0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0, & 0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0, & 0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0, & 0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0, & 0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0, & 0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0, & 0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0, & 0.32030D0,0.27465D0/ DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0, & 0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0, & 0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0, & 0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0, & 0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0, & 0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0, & 0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0, & 0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0, & 0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0, & 0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0, & 0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0, & 0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0, & 0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0, & 0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0, & 0.18255D0,0.08337D0/ IF(IERROR.NE.0) RETURN C--initialize for tevatron or LHC based on energy TEV = NINT(PBEAM1/1000.0D0).EQ.1 LHC = NINT(PBEAM1/1000.0D0).EQ.7 C--first the initalisation IF(IOPT.EQ.1) THEN IPRO = MOD(IPROC/100,100) IPRC=MOD(IPROC,100) DO I=1,20 CHNPRB(I) = ZERO CHON(I) = .FALSE. ENDDO C--gauge boson pair production IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25) & CALL HWWARN('HWIPHS',500) DO I=1,10 CHON(I) = .TRUE. ENDDO C--select the process IGAU = INT(IPRC/5) IF(IGAU.EQ.0) IGAU = IGAU+1 IF(TEV) THEN DO I=1,10 CHNPRB(I) = TEVGWT(I,IGAU) ENDDO ELSEIF(LHC) THEN DO I=1,10 CHNPRB(I) = LHCGWT(I,IGAU) ENDDO ELSE DO I=1,10 CHNPRB(I) = 0.1D0 ENDDO ENDIF CALLED=.TRUE. DEM = ONE/DBLE(IOPSH) C--Drell Yan + 2 jet production ELSEIF(IPRO.EQ.29) THEN DO I=1,6 CHON(I) = .TRUE. ENDDO IF(IPRC.LE.6) THEN IGAU = 1 ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN IGAU = 2 ELSE CALL HWWARN('HWIPHS',502) ENDIF IQRK = MOD(IPRC,10) IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503) IF(TEV) THEN DO I=1,6 CHNPRB(I) = TEVQWT(I,IQRK,IGAU) ENDDO ELSEIF(LHC) THEN DO I=1,6 CHNPRB(I) = LHCQWT(I,IQRK,IGAU) ENDDO ELSE DO I=1,6 CHNPRB(I) = 1.0D0/6.0D0 ENDDO ENDIF CALLED=.TRUE. DEM = ONE/DBLE(IOPSH) ELSE CALLED=.FALSE. RETURN ENDIF ELSE IF(.NOT.CALLED) RETURN TOTAL = ZERO DO I=1,IMAXCH IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I) ENDDO IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501) IF(TOTAL.NE.ONE) THEN DO I=1,IMAXCH IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL ENDDO ENDIF IF(.NOT.OPTM) RETURN WRITE(*,50) C--optimise the weights FSTWGT=.TRUE. C---SET UP INITIAL STATE NHEP=1 ISTHEP(NHEP)=101 PHEP(1,NHEP)=0. PHEP(2,NHEP)=0. PHEP(3,NHEP)=PBEAM1 PHEP(4,NHEP)=EBEAM1 PHEP(5,NHEP)=RMASS(IPART1) JMOHEP(1,NHEP)=0 JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHW(NHEP)=IPART1 IDHEP(NHEP)=IDPDG(IPART1) NHEP=NHEP+1 ISTHEP(NHEP)=102 PHEP(1,NHEP)=0. PHEP(2,NHEP)=0. PHEP(3,NHEP)=-PBEAM2 PHEP(4,NHEP)=EBEAM2 PHEP(5,NHEP)=RMASS(IPART2) JMOHEP(1,NHEP)=0 JMOHEP(2,NHEP)=0 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 IDHW(NHEP)=IPART2 IDHEP(NHEP)=IDPDG(IPART2) C---NEXT ENTRY IS OVERALL CM FRAME NHEP=NHEP+1 IDHW(NHEP)=14 IDHEP(NHEP)=0 ISTHEP(NHEP)=103 JMOHEP(1,NHEP)=NHEP-2 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(1,NHEP)=0 JDAHEP(2,NHEP)=0 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) DO ISTP=1,IOPSTP WRITE(*,100) ISTP DO ICH=1,IMAXCH CHWGTS(ICH) = ZERO CHNPST(ICH,ISTP) = CHNPRB(ICH) IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH) ENDDO C--compute the weights for the various channels DO I=1,IOPSH IF(IPRO.EQ.28) THEN CALL HWHGBP FSTWGT=.FALSE. CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO) ELSEIF(IPRO.EQ.29) THEN CALL HWHV2J FSTWGT=.FALSE. CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2) ENDIF DO ICH=1,IMAXCH IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH) ENDDO ENDDO WITOT = ZERO DO ICH=1,IMAXCH IF(CHON(ICH)) THEN WA(ICH) = CHWGTS(ICH)*DEM WITOT = WITOT+WA(ICH)*CHNPRB(ICH) ENDIF ENDDO C--now pick the next set of probablities for the different channels TOTAL = ZERO DO ICH=1,IMAXCH IF(CHON(ICH)) THEN CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH)) TOTAL = TOTAL+CHNPRB(ICH) ENDIF ENDDO DO ICH=1,IMAXCH CHNPRB(ICH)=CHNPRB(ICH)/TOTAL ENDDO D(ISTP) = ZERO DO ICH=1,IMAXCH IF(CHON(ICH)) THEN IF(D(ISTP).EQ.ZERO) THEN D(ISTP) = ABS(WITOT-WA(ICH)) ELSE D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH))) ENDIF ENDIF ENDDO WRITE(*,300) D(ISTP) ENDDO C--pick the best set of weights IWGT = 1 DMIN = D(1) DO I=2,IOPSTP IF(D(I).LT.DMIN) THEN IWGT = I DMIN = D(I) ENDIF ENDDO WRITE(*,500) IWGT DO I=1,IMAXCH IF(CHON(I)) THEN CHNPRB(I)=CHNPST(I,IWGT) WRITE(*,200) I,CHNPRB(I) ENDIF ENDDO OPTM = .FALSE. ENDIF RETURN 50 FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION') 100 FORMAT(/10X,'PERFORMING ITERATION',I2,/10X) 200 FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5) 300 FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5) 500 FORMAT(/10X,'SELECTED ITERATION',I2) END CDECK ID>, HWISPC. *CMZ :- -27/07/99 16.38.25 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWISPC C----------------------------------------------------------------------- C Calculates the couplings for the SUSY decays for spin correlations C and 3/4 body matrix elements C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4), & DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2) INTEGER I,J,K,L,IH,IK,IL,IQ COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP, & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4), & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4), & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2), & HZZ(2),ZAB(12,2,2),HHB(2,3) EXTERNAL HWUALF SAVE DIJ DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/ IF(IERROR.NE.0) RETURN C--coupling constants SW = SQRT(SWEIN) CW = SQRT(ONE-SWEIN) TW = SW/CW E = SQRT(FOUR*PIFAC/128.0D0) G = E/SW RT = SQRT(TWO) ORT = ONE/RT MW = RMASS(198) MZ = RMASS(200) IF(.NOT.SUSYIN) RETURN GS = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC) C--couplings of the neutralinos to the squarks DO 1 L=1,4 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB DO 1 I=1,3 J = 2*I-1 DO 2 K=1,2 AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K) & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L) 2 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K) & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L)) J = 2*I DO 1 K=1,2 AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K) & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L) 1 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K) & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L)) C--couplings of the neutralinos to the sleptons DO 3 L=1,4 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB DO 3 I=1,3 J = 2*I-1 IL = J+10 IK = J+6 DO 4 K=1,2 AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K) & +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)) 4 AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K) & +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L)) J = J+1 IL = IL+1 IK = IK+1 DO 3 K=1,2 AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L) 3 AFN(2,IK,K,L) = ZERO C--couplings of the gluinos to the squarks DO 5 I=1,6 DO 5 K=1,2 AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K) 5 AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K) C--couplings of the charginos to the squarks DO 6 L=1,2 MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB DO 6 I=1,3 J = 2*I-1 DO 7 K=1,2 AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K) & +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)) 7 AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)* & RMASS(J+1)*QMIXSS(J,1,K) J = 2*I DO 6 K=1,2 AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K) & +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)) 6 AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K) C--couplings of the charginos to the sleptons DO 8 L=1,2 MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB DO 8 I=1,3 J = 2*I-1 IL = J+6 DO 9 K=1,2 AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K) & +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K)) 9 AFC(2,IL,K,L) = ZERO J = J+1 IL = IL+1 DO 8 K=1,2 AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1) 8 AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J) C--couplings of chargino-neutralino to the W DO 10 I=1,4 DO 10 J=1,2 OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2) & +ZMXNSS(I,2)*WMXUSS(J,1)) 10 OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2) & +ZMXNSS(I,2)*WMXVSS(J,1)) C--couplings of chargino-chargino to the Z PRE = G/CW DO 11 I=1,2 DO 11 J=1,2 OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1) & -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN) 11 OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1) & -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN) C--couplings of neutralino-neutralino to the Z PRE = HALF*G/CW DO 12 I=1,4 DO 12 J=1,4 OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3) & -ZMIXSS(I,4)*ZMIXSS(J,4)) 12 OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J) C--couplings of the neutralino-neutralino to the Higgs DO 13 I=1,4 DO 13 J=1,4 QIJPP(I,J) = HALF*ZSGNSS(I)* & (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW) & +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW)) 13 SIJPP(I,J) = HALF*ZSGNSS(I)* & (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW) & +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW)) DO 14 I=1,4 DO 14 J=1,4 HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA) HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA) HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA) HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA) HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB) 14 HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB) C--couplings of chargino-chargino to the Higgs DO 15 I=1,2 DO 15 J=1,2 QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2) 15 SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1) DO 16 I=1,2 DO 16 J=1,2 HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA) HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA) HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA) HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA) HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB) 16 HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB) C--couplings of chargino-neutralino to the Higgs DO 17 I=1,4 DO 17 J=1,2 HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1) & -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2)) 17 HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1) & +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2)) C--fermion couplings to the Higgs R(1,1) = HALF*G*SINA/MW/COSB R(1,2) =-HALF*G*COSA/MW/SINB R(2,1) =-HALF*G*COSA/MW/COSB R(2,2) =-HALF*G*SINA/MW/SINB R(3,1) = HALF*G*TANB/MW R(3,2) = HALF*G*COTB/MW R(4,1) = G*ORT*TANB/MW R(4,2) = G*ORT*COTB/MW DO 18 I=1,3 J = 2*I-1 K = 2*I IL = J+6 IQ = K+6 DO 19 IK=1,3 DO 19 L=1,2 HFF(L,IK,J ) = R(IK,1)*RMASS(J) HFF(L,IK,K ) = R(IK,2)*RMASS(K) HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL) 19 HFF(L,IK,IQ) = ZERO HFF(2,3,J ) = -HFF(2,3, J) HFF(2,3,K ) = -HFF(2,3, K) HFF(2,3,IL) = -HFF(2,3,IL) HFF(1,4,I) = RMASS(J)*R(4,1) HFF(2,4,I) = RMASS(K)*R(4,2) HFF(1,4,I+3) = RMASS(114+IL)*R(4,1) 18 HFF(2,4,I+3) = ZERO C--couplings of the Higgs to gauge boson pairs HWW(1) = G*MW*SINBMA HWW(2) = G*MW*COSBMA HZZ(1) = G*MZ*SINBMA/CW HZZ(2) = G*MZ*COSBMA/CW C--couplings of the Z to the sfermions DO 20 I=1,3 IQ = 2*I-1 IL = 2*I IK = 2*I+5 IH = 2*I+6 DO 20 J=1,2 DO 20 K=1,2 ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K) & -TWO*DIJ(J,K) *SWEIN/THREE) ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K) & -FOUR*DIJ(J,K)*SWEIN/THREE) ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K) & -TWO*DIJ(J,K)*SWEIN) 20 ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1) C--couplings of the Higgs Higgs to the gauge bosons HHB(1,1) = HALF*G*COSBMA HHB(1,2) = HALF*G*SINBMA HHB(1,3) = HALF*G HHB(2,1) =-HALF*G*COSBMA/CW HHB(2,2) = HALF*G*SINBMA/CW HHB(2,3) = ZERO END CDECK ID>, HWISPN. *CMZ :- -12/10/01 17.22.48 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWISPN C----------------------------------------------------------------------- C Initialise all the decay modes for three/four body MEs and spin C correlations C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,NDKYST C--set the number of two and three body modes to zero N2MODE = 0 N3MODE = 0 NBMODE = 0 N4MODE = 0 C--if not reading in decay info calculate it IF(LRDEC.EQ.0) THEN C--initialise the couplings for the various decay modes CALL HWISPC C--Top decays and SUSY three body decays (including SUSY gauge C--boson 2 body modes which are treated as three body) IF(THREEB) CALL HWISP3 IF(IERROR.NE.0) RETURN C--then four body modes if needed IF(FOURB) CALL HWISP4 IF(IERROR.NE.0) RETURN C--Two body modes if needed for spin correlations IF(SYSPIN) CALL HWISP2 IF(IERROR.NE.0) RETURN C--otherwise read it in ELSEIF(LRDEC.GT.0) THEN C--open the unit IF (IPRINT.NE.0) WRITE (6,1) LRDEC 1 FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4) OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN') C--read options READ(UNIT=LRDEC) NDKYST IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501) READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB C--read two body decays IF(SYSPIN) THEN READ(UNIT=LRDEC) N2MODE DO 2 I=1,N2MODE 2 READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I), & ID2PRT(I),I2DRTP(I) ENDIF C--read three body decays IF(SYSPIN.OR.THREEB) THEN READ(UNIT=LRDEC) N3MODE DO 3 I=1,N3MODE READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I), & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I) DO 3 J=1,NDI3BY(I) 3 READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2), & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I) C--read two body gauge boson modes READ(UNIT=LRDEC) NBMODE DO 4 I=1,NBMODE 4 READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2), & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12), & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I) ENDIF C--read four body decays IF(FOURB) THEN READ(UNIT=LRDEC) N4MODE DO 5 I=1,N4MODE 5 READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12), & ((B4MODE(J,K,I),J=1,2),K=1,12), & ((P4MODE(J,K,I),J=1,12),K=1,12), & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I), & (I4MODE(J,I),J=1,2) ENDIF C--finally read in the matrix element codes READ(UNIT=LRDEC) NME ELSE CALL HWWARN('HWISPN',500) ENDIF C--write the decay information if needed IF(LWDEC.GT.0) THEN C--open the file IF (IPRINT.NE.0) WRITE (6,6) LWDEC 6 FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4) OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN') C--write options WRITE(UNIT=LWDEC) NDKYS WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB C--write two body decays IF(SYSPIN) THEN WRITE(UNIT=LWDEC) N2MODE DO 7 I=1,N2MODE 7 WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I), & ID2PRT(I),I2DRTP(I) ENDIF C--write three body decays IF(SYSPIN.OR.THREEB) THEN WRITE(UNIT=LWDEC) N3MODE DO 8 I=1,N3MODE WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I), & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I) DO 8 J=1,NDI3BY(I) 8 WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2), & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I) C--write two body gauge boson modes WRITE(UNIT=LWDEC) NBMODE DO 9 I=1,NBMODE 9 WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2), & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12), & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I) ENDIF C--write four body decays IF(FOURB) THEN WRITE(UNIT=LWDEC) N4MODE DO 10 I=1,N4MODE 10 WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12), & ((B4MODE(J,K,I),J=1,2),K=1,12), & ((P4MODE(J,K,I),J=1,12),K=1,12), & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I), & (I4MODE(J,I),J=1,2) ENDIF C--finally write the matrix element codes WRITE(UNIT=LWDEC) NME ENDIF END CDECK ID>, HWISP2. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWISP2 C----------------------------------------------------------------------- C Initialise the SUSY two body modes for spin correlations C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP, & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4), & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4), & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2), & HZZ(2),ZAB(12,2,2),HHB(2,3),FPI SAVE O,FPI DATA O/2,1/ DATA FPI/0.09298D0/ IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN C--now the two body modes for spin corrections DO 1000 JJ=1,NRES DO 1000 II=1,NMODES(JJ) IF(II.EQ.1) THEN I = LSTRT(JJ) ELSE I = LNEXT(I) ENDIF IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR. & (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000 L1 = IDK(I)-449 C--two body top to charged higgs decay IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND. & IDKPRD(2,I).EQ.5) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',100) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 2 P2MODE(N2MODE) = ONE DO 201 J=1,2 201 A2MODE(J,N2MODE) = HFF(O(J),4,3) C--two body antitop to charged higgs ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND. & IDKPRD(2,I).EQ.11) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',101) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 14 P2MODE(N2MODE) = ONE DO 202 J=1,2 202 A2MODE(J,N2MODE) = HFF( J ,4,3) C--two body modes of the gluino ELSEIF(L1.EQ.0) THEN L = IDKPRD(1,I)-449 C--gluino to antisfermion fermion IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',102) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 2 P2MODE(N2MODE) = HALF IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 DO 1 J=1,2 1 A2MODE(J,N2MODE) = AFG(J,IL,IM) C--gluino to sfermion antifermion ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',103) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 3 P2MODE(N2MODE) = HALF IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 DO 2 J=1,2 2 A2MODE(J,N2MODE) = AFG(O(J),IL,IM) C--gluino to neutralino gluon ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',104) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 4 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/ & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3* & HBAR/RLTIM(IDK(I))*BRFRAC(I) A2MODE(1,N2MODE) = ZSGNSS(L) C--gluino to gravitino gluon ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',105) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 9 P2MODE(N2MODE) = ONE/24.0D0 ENDIF C--two body modes of the neutralinos ELSEIF(L1.GE.1.AND.L1.LE.4) THEN L = IDKPRD(1,I)-449 IH = IDKPRD(2,I)-202 C--first the neutralino modes to neutralino Higgs IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN N2MODE = N2MODE+1 IF(N2MODE.GE.NMODE2) THEN CALL HWWARN('HWISP2',106) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 3 J=1,2 3 A2MODE(J,N2MODE) = HNN(J,IH,L,L1) C--neutralino to positive chargino negative Higgs ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN L = L-4 N2MODE = N2MODE+1 IF(N2MODE.GE.NMODE2) THEN CALL HWWARN('HWISP2',107) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 4 J=1,2 4 A2MODE(J,N2MODE) = HNC(O(J),L1,L) C--neutralino to negative chargino positive Higgs ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN L = L-6 N2MODE = N2MODE+1 IF(N2MODE.GE.NMODE2) THEN CALL HWWARN('HWISP2',108) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 5 J=1,2 5 A2MODE(J,N2MODE) = HNC(J,L1,L) C--neutralino to antisfermion sfermion ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',109) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 2 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 6 J=1,2 6 A2MODE(J,N2MODE) = AFN(J,IL,IM,L1) C--neutralino to sfermion antifermion ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',110) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 3 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 7 J=1,2 7 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1) C--neutralino to neutralino photon ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',111) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 4 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/ & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3* & HBAR/RLTIM(IDK(I))*BRFRAC(I) A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1) C--neutralino to gravitino photon for GMSB ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',112) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 9 P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0 C--neutralino to gravitino Higgs for GMSB ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',113) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 10 IF(IH.EQ.1) THEN P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA ELSEIF(IH.EQ.2) THEN P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA ELSE P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB ENDIF P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0 ELSE CALL HWWARN('HWISP2',1) ENDIF C--two body modes of the positive charginos ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN L1 = L1-4 L = IDKPRD(1,I)-449 IH = IDKPRD(2,I)-202 C--first the chargino modes to chargino Higgs IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN L = L-4 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',114) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 8 J=1,2 8 A2MODE(J,N2MODE) = HCC(J,IH,L,L1) C--then the chargino modes to neutralino Higgs ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',115) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 9 J=1,2 9 A2MODE(J,N2MODE) = HNC(J,L,L1) C--chargino modes to antisfermion fermion ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',116) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 2 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 10 J=1,2 10 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1) C--chargino modes to sfermion antifermion ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',117) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 3 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 11 J=1,2 11 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1) C--chargino --> neutralino pi+ ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',118) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 7 P2MODE(N2MODE) = FPI**2*G**2 DO 12 J=1,2 12 A2MODE(J,N2MODE) = OIJ(J,L,L1) ENDIF C--two body modes of the negative charginos ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN L1 = L1-6 L = IDKPRD(1,I)-449 IH = IDKPRD(2,I)-202 C--first the chargino modes to chargino Higgs IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN L = L-6 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',119) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 13 J=1,2 13 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1) C--then the chargino modes to neutralino Higgs ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',120) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 1 P2MODE(N2MODE) = ONE DO 14 J=1,2 14 A2MODE(J,N2MODE) = HNC(O(J),L,L1) C--chargino to antisfermion fermion ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',121) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 2 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 15 J=1,2 15 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1) C--chargino to sfermion antifermion ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',122) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 3 P2MODE(N2MODE) = ONE IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1 IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 16 J=1,2 16 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1) C--chargino --> neutralino pi- ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',123) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 7 P2MODE(N2MODE) = FPI**2*G**2 DO 17 J=1,2 17 A2MODE(J,N2MODE) =-OIJ(O(J),L,L1) ENDIF ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN C--sfermion decay modes L = IDKPRD(1,I)-449 C--first sfermion modes to gluinos IF(L.EQ.0) THEN C--first sfermion --> fermion gluino IF(IDPDG(IDKPRD(2,I)).GT.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',124) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = FOUR/THREE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 18 J=1,2 18 A2MODE(J,N2MODE) = AFG(J,IL,IM) C--then antisfermion --> antifermion gluino ELSE N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',125) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 5 P2MODE(N2MODE) = FOUR/THREE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 19 J=1,2 19 A2MODE(J,N2MODE) = AFG(O(J),IL,IM) ENDIF C--then sfermion modes to neutralinos ELSEIF(L.GE.1.AND.L.LE.4) THEN C--first sfermion --> fermion neutralino IF(IDPDG(IDKPRD(2,I)).GT.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',126) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 20 J=1,2 20 A2MODE(J,N2MODE) = AFN(J,IL,IM,L) C--then antisfermion --> fermion neutralino ELSE N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',127) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 5 P2MODE(N2MODE) = ONE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 21 J=1,2 21 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L) ENDIF C--sfermion modes to charginos ELSEIF(L.GE.5.AND.L.LE.8) THEN L = MOD(L-5,2)+1 C--first sfermion --> fermion chargino IF(IDPDG(IDKPRD(2,I)).GT.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',128) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 22 J=1,2 22 A2MODE(J,N2MODE) = AFC(J,IL,IM,L) C--then antisfermion --> fermion chargino ELSE N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',129) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 5 P2MODE(N2MODE) = ONE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 DO 23 J=1,2 23 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L) ENDIF C--sfermion modes to fermion gravitino ELSEIF(IDKPRD(2,I).EQ.458) THEN IF(IDPDG(IDKPRD(1,I)).GT.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',130) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 11 P2MODE(N2MODE) = ONE/THREE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 IF(IL.LE.6) THEN DO 40 J=1,2 40 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM) ELSE DO 41 J=1,2 41 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM) ENDIF ELSE N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',131) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 12 P2MODE(N2MODE) = ONE/THREE IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 IF(IL.LE.6) THEN DO 42 J=1,2 42 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM) ELSE DO 43 J=1,2 43 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM) ENDIF ENDIF C--R-parity violating decay modes C--LLE modes ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND. & IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN C--charged slepton decays IF(MOD(IDK(I),2).EQ.1) THEN C--right slepton decay IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ. & IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN C--particle decay N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',132) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN KKK = (IDK(I)-423)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF IF(MOD(IDKPRD(1,I),2).EQ.0) THEN III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)-119)/2 ELSE III = (IDKPRD(2,I)-120)/2 JJJ = (IDKPRD(1,I)-119)/2 ENDIF I2DRTP(N2MODE) = 6 A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)* & LAMDA1(III,JJJ,KKK) A2MODE(2,N2MODE) = 0.0D0 ELSE C--antiparticle decay KKK = (IDK(I)-429)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF IF(MOD(IDKPRD(1,I),2).EQ.0) THEN III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-125)/2 ELSE III = (IDKPRD(2,I)-126)/2 JJJ = (IDKPRD(1,I)-125)/2 ENDIF I2DRTP(N2MODE) = 13 A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)* & LAMDA1(III,JJJ,KKK) ENDIF C--left slepton decay ELSE N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',133) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN JJJ = (IDK(I)-423)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF IF(MOD(IDKPRD(1,I),2).EQ.0) THEN III = (IDKPRD(1,I)-126)/2 KKK = (IDKPRD(2,I)-119)/2 I2DRTP(N2MODE) = 8 ELSE III = (IDKPRD(2,I)-126)/2 KKK = (IDKPRD(1,I)-119)/2 I2DRTP(N2MODE) = 5 ENDIF A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)* & LAMDA1(III,JJJ,KKK) ELSE JJJ = (IDK(I)-429)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF IF(MOD(IDKPRD(1,I),2).EQ.0) THEN III = (IDKPRD(1,I)-120)/2 KKK = (IDKPRD(2,I)-125)/2 I2DRTP(N2MODE) = 5 ELSE III = (IDKPRD(2,I)-120)/2 KKK = (IDKPRD(1,I)-125)/2 I2DRTP(N2MODE) = 8 ENDIF A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)* & LAMDA1(III,JJJ,KKK) A2MODE(2,N2MODE) = 0.0D0 ENDIF ENDIF C--sneutrino decays ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN C--sneutrino decay N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',134) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN III = (IDK(I)-424)/2 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN KKK = (IDKPRD(1,I)-119)/2 JJJ = (IDKPRD(2,I)-125)/2 I2DRTP(N2MODE) = 5 ELSE JJJ = (IDKPRD(1,I)-125)/2 KKK = (IDKPRD(2,I)-119)/2 I2DRTP(N2MODE) = 8 ENDIF A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK) C--antisneutrino decay ELSE III = (IDK(I)-430)/2 IF(IDPDG(IDKPRD(1,I)).LT.0) THEN KKK = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-119)/2 I2DRTP(N2MODE) = 8 ELSE JJJ = (IDKPRD(1,I)-119)/2 KKK = (IDKPRD(2,I)-125)/2 I2DRTP(N2MODE) = 5 ENDIF A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK) A2MODE(2,N2MODE) = 0.0D0 ENDIF ENDIF C--LQD modes C--squark decays ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND. & IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND. & IDKPRD(2,I).LE.12) THEN C--up type squark decay IF(MOD(IDK(I),2).EQ.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',135) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN JJJ = (IDK(I)-400)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-125)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 8 A2MODE(1,N2MODE) = ZERO A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)* & LAMDA2(III,JJJ,KKK) ELSE JJJ = (IDK(I)-406)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-119)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 5 A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)* & LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = ZERO ENDIF C--down type squark to lepton up ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',136) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE C--particle IF(IDPDG(IDK(I)).GT.0) THEN KKK = (IDK(I)-399)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-119)/2 JJJ = IDKPRD(2,I)/2 I2DRTP(N2MODE) = 6 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)* & LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = ZERO C--antiparticle ELSE KKK = (IDK(I)-405)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-6)/2 I2DRTP(N2MODE) = 13 A2MODE(1,N2MODE) = ZERO A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)* & LAMDA2(III,JJJ,KKK) ENDIF C--down (left) squark --> nu d ELSEIF(MOD(IDK(I),2).EQ.1.AND. & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ. & -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',137) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN JJJ = (IDK(I)-399)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-126)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 8 A2MODE(1,N2MODE) = ZERO A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)* & LAMDA2(III,JJJ,KKK) ELSE JJJ = (IDK(I)-405)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-120)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 5 A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)* & LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = ZERO ENDIF C--down (right) squark --> nu d ELSEIF(MOD(IDK(I),2).EQ.1.AND. & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ. & IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',138) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = ONE IF(IDPDG(IDK(I)).GT.0) THEN KKK = (IDK(I)-399)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 6 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)* & LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = ZERO ELSE KKK = (IDK(I)-405)/2 IF(KKK.GT.3) THEN KKK = KKK-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 13 A2MODE(1,N2MODE) = ZERO A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)* & LAMDA2(III,JJJ,KKK) ENDIF ELSE CALL HWWARN('HWISP2',2) ENDIF C--slepton decays ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND. & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN C--sneutrino decay IF(MOD(IDK(I),2).EQ.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',140) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = THREE C--particle IF(IDPDG(IDK(I)).GT.0) THEN III = (IDK(I)-424)/2 JJJ = (IDKPRD(1,I)-5)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 8 A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK) C--antiparticle ELSE III = (IDK(I)-430)/2 JJJ = (IDKPRD(1,I)+1)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 5 A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = 0.0D0 ENDIF C--slepton decay ELSEIF(MOD(IDK(I),2).EQ.1) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',141) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = THREE C--particle IF(IDPDG(IDK(I)).GT.0) THEN III = (IDK(I)-423)/2 IF(III.GT.3) THEN III = III -6 IM = 2 ELSE IM = 1 ENDIF JJJ = (IDKPRD(1,I)-6)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 8 A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)* & LAMDA2(III,JJJ,KKK) C--antiparticle ELSE III = (IDK(I)-429)/2 IF(III.GT.3) THEN III = III -6 IM = 2 ELSE IM = 1 ENDIF JJJ = IDKPRD(1,I)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 5 A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)* & LAMDA2(III,JJJ,KKK) A2MODE(2,N2MODE) = 0.0D0 ENDIF ELSE CALL HWWARN('HWISP2',3) ENDIF C--UDD modes ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND. & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN C--up type squark decay IF(MOD(IDK(I),2).EQ.0) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',143) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = 2.0D0 C--squark decay IF(IDPDG(IDK(I)).GT.0) THEN III = (IDK(I)-400)/2 IF(III.GT.3) THEN III = III-6 IM = 2 ELSE IM = 1 ENDIF JJJ = (IDKPRD(1,I)-5)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 13 A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK) A2MODE(2,N2MODE)=0.0D0 C--antisquark decay ELSE III = (IDK(I)-406)/2 IF(III.GT.3) THEN III = III-6 IM = 2 ELSE IM = 1 ENDIF JJJ = (IDKPRD(1,I)+1)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 6 A2MODE(1,N2MODE) =0.0D0 A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK) ENDIF ELSE C--down type squark decay N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',144) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I P2MODE(N2MODE) = 2.0D0 C--squark decay IF(IDPDG(IDK(I)).GT.0) THEN JJJ = (IDK(I)-399)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = (IDKPRD(1,I)-6)/2 KKK = (IDKPRD(2,I)-5)/2 I2DRTP(N2MODE) = 13 A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)* & LAMDA3(III,JJJ,KKK) A2MODE(2,N2MODE)= 0.0D0 C--antisquark decay ELSE JJJ = (IDK(I)-405)/2 IF(JJJ.GT.3) THEN JJJ = JJJ-6 IM = 2 ELSE IM = 1 ENDIF III = IDKPRD(1,I)/2 KKK = (IDKPRD(2,I)+1)/2 I2DRTP(N2MODE) = 6 A2MODE(1,N2MODE) = 0.0D0 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)* & LAMDA3(III,JJJ,KKK) ENDIF ENDIF ELSE IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND. & RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4) ENDIF ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN IH = IDK(I)-202 L = IDKPRD(1,I)-449 L1 = IDKPRD(2,I)-449 C--Neutral Higgs decays IF(IH.GE.1.AND.IH.LE.3) THEN C--Higgs to neutralino neutralino IF(L.GE.1.AND.L.LE.4) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',146) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE IF(L.EQ.L1) P2MODE(N2MODE) = HALF DO 24 J=1,2 24 A2MODE(J,N2MODE) = HNN(J,IH,L,L1) C--Higgs to chargino chargino ELSEIF(L.GE.5.AND.L.LE.8) THEN L = MOD(L -5,2)+1 L1 = MOD(L1-5,2)+1 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',147) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE DO 25 J=1,2 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN A2MODE(J,N2MODE) = HCC( J ,IH,L,L1) ELSE A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1) ENDIF 25 CONTINUE C--Higgs to fermion antifermion ELSEIF((L.GE.-448.AND.L.LE.-437) & .OR.(L.GE.-328.AND.L.LE.-317)) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',148) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 5 P2MODE(N2MODE) = ONE IL = IDKPRD(1,I) IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120) IF(IL.LE.6) P2MODE(N2MODE) = THREE DO 26 J=1,2 26 A2MODE(J,N2MODE) = HFF(J,IH,IL) ELSE IF(.NOT. & (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO) & .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13) & .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59) & .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND. & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200)) & CALL HWWARN('HWISP2',5) ENDIF C--charged Higgs decays ELSE IH = IDK(I)-205 L = IDKPRD(1,I)-449 L1 = IDKPRD(2,I)-449 C--positive Higgs decays IF(IH.EQ.1) THEN C--decay to chargino neutralino IF(L.EQ.5.OR.L.EQ.6) THEN L = L-4 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',149) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE DO 27 J=1,2 27 A2MODE(J,N2MODE) = HNC(O(J),L1,L) C--decay to neutralino chargino ELSEIF(L.GE.1.AND.L.LE.4) THEN L1 = L1-4 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',150) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE DO 28 J=1,2 28 A2MODE(J,N2MODE) = HNC(O(J),L1,L) C--fermion antifermion decay modes ELSEIF((L.GE.-448.AND.L.LE.-437) & .OR.(L.GE.-328.AND.L.LE.-317)) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',151) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 5 P2MODE(N2MODE) = ONE IL = IDKPRD(1,I) IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120) IL = INT((IL+1)/2) IF(IL.LE.3) P2MODE(N2MODE) = THREE DO 29 J=1,2 29 A2MODE(J,N2MODE) = HFF(J,4,IL) ELSE IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE. & ZERO) CALL HWWARN('HWISP2',6) ENDIF C--negative Higgs decays ELSE C--Higgs to chargino neutralino IF(L.EQ.7.OR.L.EQ.8) THEN L = L-6 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',152) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE DO 30 J=1,2 30 A2MODE(J,N2MODE) = HNC(J,L1,L) C--Higgs to neutralino chargino ELSEIF(L.GE.1.AND.L.LE.4) THEN L1 = L1-6 N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',153) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 6 P2MODE(N2MODE) = ONE DO 31 J=1,2 31 A2MODE(J,N2MODE) = HNC(J,L1,L) C--fermion antifermion decay modes ELSEIF((L.GE.-448.AND.L.LE.-437) & .OR.(L.GE.-328.AND.L.LE.-317)) THEN N2MODE = N2MODE+1 IF(N2MODE.GT.NMODE2) THEN CALL HWWARN('HWISP2',154) GOTO 999 ENDIF NME(I) = 30000+N2MODE ID2PRT(N2MODE) = I I2DRTP(N2MODE) = 8 P2MODE(N2MODE) = ONE IL = IDKPRD(1,I) IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120) IL = INT((IL+1)/2) IF(IL.LE.3) P2MODE(N2MODE) = THREE DO 32 J=1,2 32 A2MODE(J,N2MODE) = HFF(O(J),4,IL) ELSE IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE. & ZERO) CALL HWWARN('HWISP2',7) ENDIF ENDIF ENDIF ENDIF 1000 CONTINUE C--now find the maximum weights and compute the decay rates DO 2000 I=1,N2MODE IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))), & RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I))) 2000 CALL HWD2ME(I) RETURN 5010 FORMAT(/'CALCULATING TWO BODY DECAY ', & A8,' --> ',A8,' ',A8/) 999 RETURN END CDECK ID>, HWISP3. *CMZ :- -30/09/02 14:05:28 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWISP3 C----------------------------------------------------------------------- C Initialise the top/SUSY three body decay modes C gravitino and RPV modes added by Peter Richardson C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ, & III,JJJ,KKK DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4), & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4), & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2), & HZZ(2),ZAB(12,2,2),HHB(2,3) DOUBLE COMPLEX RHOIN(2,2) COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP, & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB SAVE O DATA O/2,1/ IF(IERROR.NE.0) RETURN C--loop over the decays and find the top decays DO 1000 JJ=6,12,6 DO 1000 II=1,NMODES(JJ) IF(II.EQ.1) THEN I = LSTRT(JJ) ELSE I = LNEXT(I) ENDIF C--top decay via W IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',100) GOTO 999 ENDIF P3MODE(N3MODE) = ONE IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 I3DRTP(1,N3MODE) = 1 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 198 A3MODE(1,1,N3MODE) = ZERO A3MODE(2,1,N3MODE) = -G*ORT B3MODE(1,1,N3MODE) = ZERO B3MODE(2,1,N3MODE) = -G*ORT C--antitop decay via W ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',101) GOTO 999 ENDIF P3MODE(N3MODE) = ONE IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 I3DRTP(1,N3MODE) = 5 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 199 A3MODE(1,1,N3MODE) = ZERO A3MODE(2,1,N3MODE) = -G*ORT B3MODE(1,1,N3MODE) = ZERO B3MODE(2,1,N3MODE) = -G*ORT C--top decay via charged Higgs ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',102) GOTO 999 ENDIF P3MODE(N3MODE) = ONE IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 I3DRTP(1,N3MODE) = 2 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 206 IL = IDKPRD(1,I) IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120) IL = INT((IL+1)/2) DO 201 J=1,2 A3MODE(J,1,N3MODE) = HFF(O(J),4,3) 201 B3MODE(J,1,N3MODE) = HFF( J ,4,IL) C--antitop decay via charged Higgs ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',103) GOTO 999 ENDIF P3MODE(N3MODE) = ONE IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 I3DRTP(1,N3MODE) = 17 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 207 IL = IDKPRD(1,I) IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120) IL = INT((IL+1)/2) DO 202 J=1,2 A3MODE(J,1,N3MODE) = HFF( J ,4,3) 202 B3MODE(J,1,N3MODE) = HFF(O(J),4,IL) ENDIF 1000 CONTINUE IF(.NOT.SUSYIN) GOTO 2999 C--loop over all the SUSY decay modes and find the ones we want C--first the true three body gaugino decays DO 2000 JJ=1,NRES DO 2000 II=1,NMODES(JJ) IF(II.EQ.1) THEN I = LSTRT(JJ) ELSE I = LNEXT(I) ENDIF L = IDKPRD(1,I)-449 IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500 C--gluino modes first IF(IDK(I).EQ.449) THEN C--first the gluino modes to quark-antiquark neutralino IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN IQ = IDKPRD(2,I) IF(IQ.GT.6) IQ=IQ-6 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200) N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',104) GOTO 999 ENDIF P3MODE(N3MODE) = HALF SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 C--only squark exchange diagrams DO 1 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ DO 1 J=1,2 A3MODE(J,K ,N3MODE) = AFG( J ,IQ,K) B3MODE(J,K ,N3MODE) = AFN(O(J),IQ,K,L) A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K) 1 B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN( J ,IQ,K,L) C--then the gluino modes to quark-antiquark +ve chargino ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN L = L-4 IQ = IDKPRD(2,I) IF(IQ.GT.6) IQ=IQ-6 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201) IQ = (IQ+MOD(IQ,2))/2 IQ1 = 2*IQ-1 IQ2 = 2*IQ N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',105) GOTO 999 ENDIF P3MODE(N3MODE) = HALF SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 C--only squark exchange diagrams DO 2 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2 DO 2 J=1,2 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K) B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L) A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K) 2 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L) C--then the gluino modes to quark-antiquark -ve chargino ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN L = L-6 IQ = IDKPRD(2,I) IF(IQ.GT.6) IQ=IQ-6 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202) IQ = (IQ+MOD(IQ,2))/2 IQ1 = 2*IQ IQ2 = 2*IQ-1 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',106) GOTO 999 ENDIF P3MODE(N3MODE) = HALF SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 C--only squark exchange diagrams DO 3 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2 DO 3 J=1,2 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K) B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L) A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K) 3 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L) C--RPV decay modes C--LQD first ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',107) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE P3MODE(N3MODE) = HALF SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 NDI3BY(N3MODE) = 4 DO 98 J=1,4 98 I3DRCF(J,N3MODE) = 1 C--first the neutrino mode IF(MOD(IDKPRD(1,I),2).EQ.0) THEN C--particle mode IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)-5)/2 DO 99 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRTP(K+2,N3MODE) = 4 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 99 J=1,2 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ-1,K) 99 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K) C--antiparticle mode ELSE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)+1)/2 DO 101 K=1,2 I3DRTP(K ,N3MODE) = 9 I3DRTP(K+2,N3MODE) = 10 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 101 J=1,2 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ-1,K) 101 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K) ENDIF C--then the charged lepton mode ELSE C--particle mode IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = (IDKPRD(1,I)-119)/2 JJJ = IDKPRD(2,I)/2 KKK = (IDKPRD(3,I)-5)/2 DO 102 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRTP(K+2,N3MODE) = 4 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K ,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 102 J=1,2 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ ,K) 102 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K) C--antiparticle mode ELSE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-6)/2 KKK = (IDKPRD(3,I)+1)/2 DO 103 K=1,2 I3DRTP(K ,N3MODE) = 9 I3DRTP(K+2,N3MODE) = 10 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 103 J=1,2 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ ,K) 103 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K) ENDIF ENDIF C--then UDD ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND. & IDKPRD(3,I).LE.12) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',108) GOTO 999 ENDIF P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 3 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 6 DO 70 J=1,3 DO 70 K=1,3 IF(J.NE.K) THEN SPN3CF(J,K,N3MODE) = -HALF ELSE SPN3CF(J,K,N3MODE) = ONE ENDIF 70 CONTINUE C--particle mode IF(IDKPRD(1,I).LE.6) THEN C--antiparticle mode III = IDKPRD(1,I)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)+1)/2 DO 71 K=1,2 I3DRTP(K ,N3MODE) = 11 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 12 I3DRCF(K+2,N3MODE) = 2 I3DRTP(K+4,N3MODE) = 13 I3DRCF(K+4,N3MODE) = 3 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(1,K+4,N3MODE) = 0.0D0 DO 71 J=1,2 A3MODE(J,K ,N3MODE) = AFG(J,2*III ,K) A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K) 71 A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K) ELSE III = (IDKPRD(1,I)-6)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)-5)/2 DO 72 K=1,2 I3DRTP(K ,N3MODE) = 14 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 15 I3DRCF(K+2,N3MODE) = 2 I3DRTP(K+4,N3MODE) = 16 I3DRCF(K+4,N3MODE) = 3 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(2,K+4,N3MODE) = 0.0D0 DO 72 J=1,2 A3MODE(J,K ,N3MODE) = AFG(O(J),2*III ,K) A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K) 72 A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K) ENDIF C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',1) ENDIF ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN L1 = IDK(I)-449 C--neutralino modes next IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN C--first the neutralino modes to fermion-antifermion neutralino IFR = IDKPRD(2,I) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J SIFR = IFR+18*J N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',109) GOTO 999 ENDIF P3MODE(N3MODE) = ONE IF(IFR.LE.6) P3MODE(N3MODE)=THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 C--sfermion exchange diagrams DO 4 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+400+SIFR I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR DO 4 J=1,2 A3MODE(J,K ,N3MODE) = AFN( J ,IFR,K,L1) B3MODE(J,K ,N3MODE) = AFN(O(J),IFR,K,L ) A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1) 4 B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN( J ,IFR,K,L ) C--now add higgs diagrams if third generation fermion, if Higgs off shell IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN DO 5 J=1,3 IF(RMASS(IDK(I)).LT. & RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP( NDI3BY(N3MODE),N3MODE) = 2 I3DRCF( NDI3BY(N3MODE),N3MODE) = 1 I3MODE( NDI3BY(N3MODE),N3MODE) = 203+J DO 6 K=1,2 A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1) 6 B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR) ENDIF 5 CONTINUE ENDIF C-- and gauge boson diagrams if Z not on-shell IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1 I3MODE(NDI3BY(N3MODE),N3MODE) = 200 DO 7 J=1,2 7 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJPP(J,L,L1) B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL) B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL) ENDIF ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN C--then the neutralino modes to fermion-antifermion +ve chargino C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000 L = L-4 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',110) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--gauge boson diagram I3DRTP(1,N3MODE) = 1 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 199 DO 8 J=1,2 8 A3MODE(J,1,N3MODE) = OIJ(J,L1,L) B3MODE(1,1,N3MODE) = ZERO B3MODE(2,1,N3MODE) = -G*ORT ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN C--then the neutralino modes to fermion-antifermion -ve chargino C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000 L = L-6 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',111) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--gauge boson diagram I3DRTP(1,N3MODE) = 1 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 198 DO 9 J=1,2 9 A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L) B3MODE(1,1,N3MODE) = ZERO B3MODE(2,1,N3MODE) = -G*ORT C--gravitino E+e- modes ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN IFR = IDKPRD(2,I) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',112) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 1 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--diagram I3DRTP(1,N3MODE) = 7 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 59 A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1) A3MODE(2,1,N3MODE) = 0 B3MODE(1,1,N3MODE) = -E*QFCH(IL) B3MODE(2,1,N3MODE) = -E*QFCH(IL) C--R-parity violating modes C--LLE modes ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND. & IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',113) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 5 P3MODE(N3MODE) = ONE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--particle mode DO 53 J=1,6 53 I3DRCF(J,N3MODE) = 1 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = (IDKPRD(1,I)-119)/2 JJJ = (IDKPRD(2,I)-120)/2 KKK = (IDKPRD(3,I)-125)/2 DO 51 J=1,2 I3DRTP(J ,N3MODE) = 2 I3DRTP(J+2,N3MODE) = 4 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12 B3MODE(1,J ,N3MODE) = LMIXSS(2*III-1,1,J)* & LAMDA1(III,JJJ,KKK) B3MODE(2,J ,N3MODE) = 0.0D0 B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)* & LAMDA1(III,JJJ,KKK) B3MODE(2,J+2,N3MODE) = 0.0D0 DO 51 K=1,2 A3MODE(K,J ,N3MODE) = AFN( K ,5+2*III,J,L1) 51 A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1) DO 48 K=1,2 48 A3MODE(K,5,N3MODE) = AFN( K ,6+2*JJJ,1,L1) I3DRTP(5,N3MODE) = 3 I3MODE(5,N3MODE) = 430+2*JJJ B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK) B3MODE(2,5,N3MODE) = 0.0D0 C--antiparticle mode ELSE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-126)/2 KKK = (IDKPRD(3,I)-119)/2 DO 52 J=1,2 I3DRTP(J ,N3MODE) = 8 I3DRTP(J+2,N3MODE) = 10 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12 B3MODE(2,J ,N3MODE) = LMIXSS(2*III-1,1,J)* & LAMDA1(III,JJJ,KKK) B3MODE(1,J ,N3MODE) = 0.0D0 B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)* & LAMDA1(III,JJJ,KKK) B3MODE(1,J+2,N3MODE) = 0.0D0 DO 52 K=1,2 A3MODE(K,J ,N3MODE) = AFN(O(K),5+2*III,J,L1) 52 A3MODE(K,J+2,N3MODE) = AFN( K ,5+2*KKK,J,L1) DO 49 K=1,2 49 A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1) I3DRTP(5,N3MODE) = 9 I3MODE(5,N3MODE) = 430+2*JJJ B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK) B3MODE(1,5,N3MODE) = 0.0D0 ENDIF C--LQD modes ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',114) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE P3MODE(N3MODE) = 3.0D0 SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 DO 81 J=1,6 81 I3DRCF(J,N3MODE) = 1 C--first the neutrino mode IF(MOD(IDKPRD(1,I),2).EQ.0) THEN NDI3BY(N3MODE) = 5 C--particle mode IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)-5)/2 DO 82 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRTP(K+2,N3MODE) = 4 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 82 J=1,2 A3MODE(J,K ,N3MODE) = AFN( J ,2*JJJ-1,K,L1) 82 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1) I3DRTP(5,N3MODE) = 2 I3MODE(5,N3MODE) = 424+2*III B3MODE(2,5,N3MODE) = 0.0D0 B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK) DO 83 J=1,2 83 A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1) C--antiparticle mode ELSE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)+1)/2 DO 84 K=1,2 I3DRTP(K ,N3MODE) = 9 I3DRTP(K+2,N3MODE) = 10 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 84 J=1,2 A3MODE(J,K ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1) 84 A3MODE(J,K+2,N3MODE) = AFN( J ,2*KKK-1,K,L1) I3DRTP(5,N3MODE) = 8 I3MODE(5,N3MODE) = 424+2*III B3MODE(1,5,N3MODE) = 0.0D0 B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK) DO 85 J=1,2 85 A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1) ENDIF C--then the charged lepton mode ELSE NDI3BY(N3MODE) = 6 C--particle mode IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = (IDKPRD(1,I)-119)/2 JJJ = IDKPRD(2,I)/2 KKK = (IDKPRD(3,I)-5)/2 DO 86 K=1,2 I3DRTP(K ,N3MODE) = 2 I3DRTP(K+2,N3MODE) = 3 I3DRTP(K+4,N3MODE) = 4 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+4,N3MODE) = 0.0D0 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 86 J=1,2 A3MODE(J,K ,N3MODE) = AFN( J ,2*III+5,K,L1) A3MODE(J,K+2,N3MODE) = AFN( J ,2*JJJ ,K,L1) 86 A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1) C--antiparticle mode ELSE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-6)/2 KKK = (IDKPRD(3,I)+1)/2 DO 87 K=1,2 I3DRTP(K ,N3MODE) = 8 I3DRTP(K+2,N3MODE) = 9 I3DRTP(K+4,N3MODE) = 10 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+4,N3MODE) = 0.0D0 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 87 J=1,2 A3MODE(J,K ,N3MODE) = AFN(O(J),2*III+5,K,L1) A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ ,K,L1) 87 A3MODE(J,K+4,N3MODE) = AFN( J ,2*KKK-1,K,L1) ENDIF ENDIF C--UDD modes ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND. & IDKPRD(3,I).LE.12) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',115) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 6 P3MODE(N3MODE) = 6.0D0 SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 DO 61 J=1,6 61 I3DRCF(J,N3MODE) = 1 C--particle mode IF(IDPDG(IDKPRD(1,I)).GT.0) THEN III = IDKPRD(1,I)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)+1)/2 DO 62 J=1,2 I3DRTP(J ,N3MODE) = 11 I3DRTP(J+2,N3MODE) = 12 I3DRTP(J+4,N3MODE) = 13 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12 B3MODE(2,J ,N3MODE) = QMIXSS(2*III,2,J)* & LAMDA3(III,JJJ,KKK) B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)* & LAMDA3(III,JJJ,KKK) B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)* & LAMDA3(III,JJJ,KKK) B3MODE(1,J ,N3MODE) = 0.0D0 B3MODE(1,J+2,N3MODE) = 0.0D0 B3MODE(1,J+4,N3MODE) = 0.0D0 DO 62 K=1,2 A3MODE(K,J ,N3MODE) = AFN(K,2*III ,J,L1) A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1) 62 A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1) C--antiparticle mode ELSE III = (IDKPRD(1,I)-6)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)-5)/2 DO 63 J=1,2 I3DRTP(J ,N3MODE) = 14 I3DRTP(J+2,N3MODE) = 15 I3DRTP(J+4,N3MODE) = 16 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12 B3MODE(2,J ,N3MODE) = 0.0D0 B3MODE(2,J+2,N3MODE) = 0.0D0 B3MODE(2,J+4,N3MODE) = 0.0D0 B3MODE(1,J ,N3MODE) = QMIXSS(2*III,2,J)* & LAMDA3(III,JJJ,KKK) B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)* & LAMDA3(III,JJJ,KKK) B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)* & LAMDA3(III,JJJ,KKK) DO 63 K=1,2 A3MODE(K,J ,N3MODE) = AFN(O(K),2*III ,J,L1) A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1) 63 A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1) ENDIF C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',2) ENDIF ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN C--+ve chargino modes C--first the chargino modes to fermion-antifermion neutralino IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN IFR = IDKPRD(2,I) IFR = IFR+MOD(IFR,2) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J SIFR = IFR+18*J L1 = IDK(I)-453 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',116) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--sfermion exchange diagrams DO 10 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+405+SIFR I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR DO 10 J=1,2 A3MODE(J,K ,N3MODE) = AFC( J ,IFR-1,K,L1) B3MODE(J,K ,N3MODE) = AFN(O(J),IFR-1,K,L ) A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR ,K,L1) 10 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR ,K,L ) C--gauge boson diagram IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1 I3MODE(NDI3BY(N3MODE),N3MODE) = 198 DO 11 J=1,2 11 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1) B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT ENDIF C--then the chargino modes to fermion-antifermion chargino ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN L = L-4 IFR = IDKPRD(2,I) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J SIFR = IFR+18*J IF(MOD(IFR,2).EQ.0) THEN IFR = IFR-1 SIFR = SIFR-1 ELSE IFR = IFR+1 SIFR = SIFR+1 ENDIF L1 = IDK(I)-453 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',117) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--sfermion exchange diagrams IF(MOD(IL,2).EQ.0) THEN DO 12 K=1,2 I3DRTP(K,N3MODE) = 3 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR DO 12 J=1,2 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1) 12 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L ) ELSE DO 13 K=1,2 I3DRTP(K,N3MODE) = 4 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR DO 13 J=1,2 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1) 13 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L ) ENDIF C--gauge boson diagram IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1 I3MODE(NDI3BY(N3MODE),N3MODE) = 200 DO 14 J=1,2 14 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1) B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL) B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL) ENDIF C--R-parity violating decays C--LLE first ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND. & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN L1 = IDK(I)-453 C--neutrino lepton neutrino IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND. & MOD(IDKPRD(3,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',118) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-125)/2 KKK = (IDKPRD(3,I)-120)/2 DO 54 K=1,2 I3DRTP(K,N3MODE) = 10 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1) B3MODE(1,K,N3MODE) = 0.0D0 B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K) DO 54 J=1,2 54 A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1) C--neutrino neutrino lepton ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',119) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)-120)/2 KKK = (IDKPRD(3,I)-125)/2 DO 55 K=1,2 I3DRTP(K ,N3MODE) = 2 I3DRTP(K+2,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1) I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1) B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)* & LMIXSS(2*III-1,1,K) B3MODE(2,K,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)* & LMIXSS(2*JJJ-1,1,K) B3MODE(2,K+2,N3MODE) = 0.0D0 DO 55 J=1,2 A3MODE(J,K,N3MODE) = AFC(J,5+2*III,K,L1) 55 A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1) C--lepton lepton lepton ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',120) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-125)/2 KKK = (IDKPRD(3,I)-119)/2 I3DRTP(1,N3MODE) = 8 I3DRTP(2,N3MODE) = 9 I3DRCF(1,N3MODE) = 1 I3DRCF(2,N3MODE) = 1 I3MODE(1,N3MODE) = 424+2*III I3MODE(2,N3MODE) = 424+2*JJJ B3MODE(1,1,N3MODE) = 0.0D0 B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK) B3MODE(1,2,N3MODE) = 0.0D0 B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK) DO 56 J=1,2 A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1) 56 A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1) ELSE CALL HWWARN('HWISP3',3) ENDIF C--LQD decays ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN L1 = IDK(I)-453 C--nubar dbar u IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',121) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = IDKPRD(3,I)/2 DO 88 K=1,2 I3DRTP(K,N3MODE) = 10 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1) B3MODE(1,K,N3MODE) = 0.0D0 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 88 J=1,2 88 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1) C--l+ ubar u ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND. & MOD(IDKPRD(2,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',122) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-6)/2 KKK = IDKPRD(3,I)/2 DO 89 K=1,2 I3DRTP(K,N3MODE) = 10 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1) B3MODE(1,K,N3MODE) = 0.0D0 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 89 J=1,2 89 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1) C--l+ dbar d ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND. & MOD(IDKPRD(2,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',123) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 3 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-125)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)+1)/2 I3DRTP(1,N3MODE) = 8 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 424+2*III B3MODE(1,1,N3MODE) = 0.0D0 B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK) DO 91 J=1,2 91 A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1) DO 92 K=1,2 I3DRTP(K+1,N3MODE) = 9 I3DRCF(K+1,N3MODE) = 1 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1) B3MODE(1,K+1,N3MODE) = 0.0D0 B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) DO 92 J=1,2 92 A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1) C--nu u dbar ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',124) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-120)/2 JJJ = IDKPRD(2,I)/2 KKK = (IDKPRD(3,I)-5)/2 DO 90 K=1,2 I3DRTP(K ,N3MODE) = 2 I3DRTP(K+2,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1) I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1) B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 DO 90 J=1,2 A3MODE(J,K ,N3MODE) = AFC(J,2*III+5,K,L1) 90 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1) C--unrecognised ELSE CALL HWWARN('HWISP3',4) ENDIF C--UDD decays ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND. & IDKPRD(3,I).LE.12) THEN L1 = IDK(I)-453 C--dbar dbar dbar mode IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND. & MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',125) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 6 N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-5)/2 JJJ = (IDKPRD(2,I)-5)/2 KKK = (IDKPRD(3,I)-5)/2 P3MODE(N3MODE) = ONE IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE) DO 66 K=1,6 66 I3DRCF(K,N3MODE) = 1 DO 65 K=1,2 I3DRTP(K ,N3MODE) = 14 I3DRTP(K+2,N3MODE) = 15 I3DRTP(K+4,N3MODE) = 16 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K ,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)* & LAMDA3(JJJ,III,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)* & LAMDA3(KKK,III,JJJ) B3MODE(2,K+4,N3MODE) = 0.0D0 DO 65 J=1,2 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III,K,L1) A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1) 65 A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1) C--u u d mode ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',126) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = 6.0D0 N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = IDKPRD(1,I)/2 JJJ = IDKPRD(2,I)/2 KKK = (IDKPRD(3,I)+1)/2 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE) DO 64 K=1,2 I3DRTP(K ,N3MODE) = 11 I3DRTP(K+2,N3MODE) = 12 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = QMIXSS(2*III-1,2,K)* & LAMDA3(JJJ,III,KKK) c B3MODE(2,K,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)* & LAMDA3(III,JJJ,KKK) DO 64 J=1,2 A3MODE(J,K ,N3MODE) = AFC(J,2*III-1,K,L1) 64 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1) C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',5) ENDIF C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',6) ENDIF ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN C-- -ve chargino modes last C--first the chargino modes to fermion-antifermion neutralino IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN IFR = IDKPRD(2,I) IFR = IFR+MOD(IFR,2) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J SIFR = IFR+18*J L1 = IDK(I)-455 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',127) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--sfermion exchange diagrams DO 15 K=1,2 I3DRTP(K ,N3MODE) = 3 I3DRCF(K ,N3MODE) = 1 I3DRTP(K+2,N3MODE) = 4 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 12*(K-1)+406+SIFR I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR DO 15 J=1,2 A3MODE(J,K ,N3MODE) = AFC( J ,IFR ,K,L1) B3MODE(J,K ,N3MODE) = AFN(O(J),IFR ,K,L ) A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1) 15 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR-1,K,L ) C--gauge boson diagram IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1 I3MODE(NDI3BY(N3MODE),N3MODE) = 199 DO 16 J=1,2 16 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1) B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT ENDIF C--then the chargino modes to fermion-antifermion chargino ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR. & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN L = L-6 IFR = IDKPRD(2,I) J = INT((IFR-1)/120) IFR = IFR-6*INT((IFR-1)/6)+6*J IL = IFR+4*J SIFR = IFR+18*J IF(MOD(IFR,2).EQ.0) THEN IFR = IFR-1 SIFR = SIFR-1 ELSE IFR = IFR+1 SIFR = SIFR+1 ENDIF L1 = IDK(I)-455 N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',128) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE SPN3CF(1,1,N3MODE) = ONE N3NCFL(N3MODE) = 1 C--sfermion exchange diagrams IF(MOD(IL,2).EQ.0) THEN DO 17 K=1,2 I3DRTP(K,N3MODE) = 4 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR DO 17 J=1,2 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1) 17 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L ) ELSE DO 18 K=1,2 I3DRTP(K,N3MODE) = 3 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR DO 18 J=1,2 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1) 18 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L ) ENDIF C--gauge boson diagram IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN NDI3BY(N3MODE) = NDI3BY(N3MODE)+1 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1 I3MODE(NDI3BY(N3MODE),N3MODE) = 200 DO 19 J=1,2 19 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1) B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL) B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL) ENDIF C--R-parity violating decays C--LLE first ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND. & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN L1 = IDK(I)-455 C--neutrino lepton neutrino IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND. & MOD(IDKPRD(3,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',129) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)-119)/2 KKK = (IDKPRD(3,I)-126)/2 DO 57 K=1,2 I3DRTP(K,N3MODE) = 4 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1) B3MODE(2,K,N3MODE) = 0.0D0 B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K) DO 57 J=1,2 57 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1) C--neutrino neutrino lepton ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',130) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-126)/2 KKK = (IDKPRD(3,I)-119)/2 DO 58 K=1,2 I3DRTP(K ,N3MODE) = 8 I3DRTP(K+2,N3MODE) = 9 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1) I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1) B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)* & LMIXSS(2*III-1,1,K) B3MODE(1,K,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)* & LMIXSS(2*JJJ-1,1,K) B3MODE(1,K+2,N3MODE) = 0.0D0 DO 58 J=1,2 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*III,K,L1) 58 A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1) C--lepton lepton lepton ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',131) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = ONE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-119)/2 JJJ = (IDKPRD(2,I)-119)/2 KKK = (IDKPRD(3,I)-125)/2 I3DRTP(1,N3MODE) = 2 I3DRTP(2,N3MODE) = 3 I3DRCF(1,N3MODE) = 1 I3DRCF(2,N3MODE) = 1 I3MODE(1,N3MODE) = 424+2*III I3MODE(2,N3MODE) = 424+2*JJJ B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK) B3MODE(2,1,N3MODE) = 0.0D0 B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK) B3MODE(2,2,N3MODE) = 0.0D0 DO 59 J=1,2 A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1) 59 A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1) ELSE CALL HWWARN('HWISP3',7) ENDIF C--LQD decays ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND. & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN L1 = IDK(I)-455 C--nu d ubar IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',132) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-120)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)-6)/2 DO 93 K=1,2 I3DRTP(K,N3MODE) = 4 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1) B3MODE(2,K,N3MODE) = 0.0D0 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 93 J=1,2 93 A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1) C--l- u ubar ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND. & MOD(IDKPRD(2,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',133) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 2 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-119)/2 JJJ = IDKPRD(2,I)/2 KKK = (IDKPRD(3,I)-6)/2 DO 94 K=1,2 I3DRTP(K,N3MODE) = 4 I3DRCF(K,N3MODE) = 1 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1) B3MODE(2,K,N3MODE) = 0.0D0 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)* & LAMDA2(III,JJJ,KKK) DO 94 J=1,2 94 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1) C--l- d dbar ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND. & MOD(IDKPRD(2,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',134) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 3 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-119)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)-5)/2 I3DRTP(1,N3MODE) = 2 I3DRCF(1,N3MODE) = 1 I3MODE(1,N3MODE) = 424+2*III B3MODE(2,1,N3MODE) = 0.0D0 B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK) DO 95 J=1,2 95 A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1) DO 96 K=1,2 I3DRTP(K+1,N3MODE) = 3 I3DRCF(K+1,N3MODE) = 1 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1) B3MODE(2,K+1,N3MODE) = 0.0D0 B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)* & LAMDA2(III,JJJ,KKK) DO 96 J=1,2 96 A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1) C--nubar ubar d ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',135) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = THREE N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-126)/2 JJJ = (IDKPRD(2,I)-6)/2 KKK = (IDKPRD(3,I)+1)/2 DO 97 K=1,2 I3DRTP(K ,N3MODE) = 8 I3DRTP(K+2,N3MODE) = 9 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1) I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1) B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)* & LAMDA2(III,JJJ,KKK) B3MODE(1,K+2,N3MODE) = 0.0D0 DO 97 J=1,2 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III+5,K,L1) 97 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1) C--unrecognised ELSE CALL HWWARN('HWISP3',8) ENDIF C-- UDD modes ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND. & IDKPRD(3,I).LE.12) THEN L1 = IDK(I)-455 C-- d d d mode IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND. & MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',136) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 6 N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)+1)/2 JJJ = (IDKPRD(2,I)+1)/2 KKK = (IDKPRD(3,I)+1)/2 P3MODE(N3MODE) = ONE IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE) DO 68 K=1,6 68 I3DRCF(K,N3MODE) = 1 DO 67 K=1,2 I3DRTP(K ,N3MODE) = 12 I3DRTP(K+2,N3MODE) = 13 I3DRTP(K+4,N3MODE) = 14 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12 B3MODE(1,K ,N3MODE) = 0.0D0 B3MODE(1,K+2,N3MODE) = 0.0D0 B3MODE(1,K+4,N3MODE) = 0.0D0 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)* & LAMDA3(JJJ,III,KKK) B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)* & LAMDA3(KKK,III,JJJ) DO 67 J=1,2 A3MODE(J,K ,N3MODE) = AFC(J,2*III,K,L1) A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1) 67 A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1) C--u u d mode ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN N3MODE = N3MODE+1 IF(N3MODE.GT.NMODE3) THEN CALL HWWARN('HWISP3',137) GOTO 999 ENDIF ID3PRT(N3MODE) = I NME(I) = 10000+N3MODE NDI3BY(N3MODE) = 4 P3MODE(N3MODE) = 6.0D0 N3NCFL(N3MODE) = 1 SPN3CF(1,1,N3MODE) = ONE III = (IDKPRD(1,I)-6)/2 JJJ = (IDKPRD(2,I)-6)/2 KKK = (IDKPRD(3,I)-5)/2 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE) DO 69 K=1,2 I3DRTP(K ,N3MODE) = 11 I3DRTP(K+2,N3MODE) = 12 I3DRCF(K ,N3MODE) = 1 I3DRCF(K+2,N3MODE) = 1 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12 B3MODE(1,K ,N3MODE) = QMIXSS(2*III-1,2,K)* & LAMDA3(JJJ,III,KKK) B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)* & LAMDA3(III,JJJ,KKK) B3MODE(2,K+2,N3MODE) = 0.0D0 B3MODE(2,K+2,N3MODE) = 0.0D0 DO 69 J=1,2 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III-1,K,L1) 69 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1) C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',9) ENDIF C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',10) ENDIF ENDIF C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY 2500 IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000 L1 = IDK(I)-449 IH1 = IDK(I)-202 IH = IDKPRD(1,I)-202 C--first the neutralino decay modes IF(L1.GE.1.AND.L1.LE.4.AND. & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN C--neutralino --> neutralino Z IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',138) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 1 DO 20 J=1,2 20 ABMODE(J,NBMODE) = OIJPP(J,L,L1) DO 21 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = THREE ELSE IL=K+4 PBMODE(K,NBMODE) = ONE ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 21 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--neutralino --> chargino+ W- ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN L = L-4 NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',139) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 199 IBDRTP(NBMODE) = 1 DO 22 J=1,2 22 ABMODE(J,NBMODE) = OIJ(J,L1,L) DO 23 K=1,6 PBMODE(K,NBMODE) = ONE IF(K.LE.3) PBMODE(K,NBMODE) = THREE BBMODE(1,K,NBMODE) = ZERO 23 BBMODE(2,K,NBMODE) = -G*ORT C--neutralino --> chargino- W+ ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN L = L-6 NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',140) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 198 IBDRTP(NBMODE) = 1 DO 24 J=1,2 24 ABMODE(J,NBMODE) =-OIJ(O(J),L1,L) DO 25 K=1,6 PBMODE(K,NBMODE) = ONE IF(K.LE.3) PBMODE(K,NBMODE) = THREE BBMODE(1,K,NBMODE) = ZERO 25 BBMODE(2,K,NBMODE) = -G*ORT C--gravitino Z modes ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',141) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 7 ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2) ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)* & (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB) DO 41 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = THREE ELSE IL=K+4 PBMODE(K,NBMODE) = ONE ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 41 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--unrecognized decay issue warning ELSE CALL HWWARN('HWISP3',11) ENDIF C--then the +ve chargino decay modes ELSEIF((L1.EQ.5.OR.L1.EQ.6) & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN L1 = L1-4 C--chargino --> chargino Z IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN L = L-4 NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',142) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 1 DO 26 J=1,2 26 ABMODE(J,NBMODE) = OIJP(J,L,L1) DO 27 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = THREE ELSE IL=K+4 PBMODE(K,NBMODE) = ONE ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 27 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--chargino --> neutralino W+ ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',143) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 198 IBDRTP(NBMODE) = 1 DO 28 J=1,2 28 ABMODE(J,NBMODE) = OIJ(J,L,L1) DO 29 K=1,6 PBMODE(K,NBMODE) = ONE IF(K.LE.3) PBMODE(K,NBMODE) = THREE BBMODE(1,K,NBMODE) = ZERO 29 BBMODE(2,K,NBMODE) = -G*ORT C--unrecognised decay issue warning ELSE CALL HWWARN('HWISP3',12) ENDIF C--then the -ve chargino decay modes ELSEIF((L1.EQ.7.OR.L1.EQ.8) & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN L1 = L1-6 C--chargino --> chargino Z IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN L = L-6 NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',144) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 1 DO 30 J=1,2 30 ABMODE(J,NBMODE) =-OIJP(O(J),L,L1) DO 31 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = THREE ELSE IL=K+4 PBMODE(K,NBMODE) = ONE ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 31 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--chargino --> neutralino W- ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',145) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 199 IBDRTP(NBMODE) = 1 DO 32 J=1,2 32 ABMODE(J,NBMODE) =-OIJ(O(J),L,L1) DO 33 K=1,6 PBMODE(K,NBMODE) = ONE IF(K.LE.3) PBMODE(K,NBMODE) = THREE BBMODE(1,K,NBMODE) = ZERO 33 BBMODE(2,K,NBMODE) = -G*ORT C--unrecognised decay issue warning ELSE CALL HWWARN('HWISP3',13) ENDIF C--gauge boson decay modes of the Higgs ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND. & IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN C--decay of the A0 to scalar Higgs and Z boson IF(IH1.EQ.3.AND.IH.LE.2) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',146) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 6 ABMODE(1,NBMODE) =-HHB(2,IH) ABMODE(2,NBMODE) = ZERO DO 34 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = 3.0D0 ELSE IL=K+4 PBMODE(K,NBMODE) = 1.0D0 ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 34 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--decay of scalar Higgs to A0 and Z ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',147) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 6 ABMODE(1,NBMODE) = HHB(2,IH1) ABMODE(2,NBMODE) = ZERO DO 35 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = 3.0D0 ELSE IL=K+4 PBMODE(K,NBMODE) = 1.0D0 ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 35 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--decay of the positively charged Higgs ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',148) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 198 IBDRTP(NBMODE) = 6 ABMODE(1,NBMODE) =-HHB(1,IH) ABMODE(2,NBMODE) = ZERO DO 36 K=1,6 PBMODE(K,NBMODE) = 1.0D0 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0 BBMODE(1,K,NBMODE) = ZERO 36 BBMODE(2,K,NBMODE) = -G*ORT C--decay of the negatively charged Higgs ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',149) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 199 IBDRTP(NBMODE) = 6 ABMODE(1,NBMODE) =-HHB(1,IH) ABMODE(2,NBMODE) = ZERO DO 37 K=1,6 PBMODE(K,NBMODE) = 1.0D0 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0 BBMODE(1,K,NBMODE) = ZERO 37 BBMODE(2,K,NBMODE) = -G*ORT ENDIF C--finally sfermion modes to gauge bosons ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND. & IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND. & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN C--change the order of the decay products IM = MOD(INT((IDK(I)-389)/12)+1,2)+1 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1 IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1 IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1 C--first the Z decay modes IF(IDKPRD(1,I).EQ.200) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',150) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 200 IBDRTP(NBMODE) = 6 ABMODE(1,NBMODE) = ZAB(IL,IM,IH) ABMODE(2,NBMODE) = ZERO DO 38 K=1,12 IF(K.LE.6) THEN IL = K PBMODE(K,NBMODE) = 3.0D0 ELSE IL=K+4 PBMODE(K,NBMODE) = 1.0D0 ENDIF BBMODE(1,K,NBMODE) = -E*RFCH(IL) 38 BBMODE(2,K,NBMODE) = -E*LFCH(IL) C--then the W+ decay modes ELSEIF(IDKPRD(1,I).EQ.198) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',151) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 198 IBDRTP(NBMODE) = 6 IF(IL.LE.6) THEN ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH) ELSE ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)* & LMIXSS(IQ-6,1,IH) ENDIF ABMODE(2,NBMODE) = ZERO DO 39 K=1,6 PBMODE(K,NBMODE) = 1.0D0 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0 BBMODE(1,K,NBMODE) = ZERO 39 BBMODE(2,K,NBMODE) = -G*ORT ELSEIF(IDKPRD(1,I).EQ.199) THEN NBMODE = NBMODE+1 IF(NBMODE.GT.NMODEB) THEN CALL HWWARN('HWISP3',152) GOTO 999 ENDIF NME(I) = 20000+NBMODE IDBPRT(NBMODE) = I IBMODE(NBMODE) = 199 IBDRTP(NBMODE) = 6 IF(IL.LE.6) THEN ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH) ELSE ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)* & LMIXSS(IQ-6,1,IH) ENDIF ABMODE(2,NBMODE) = ZERO DO 40 K=1,6 PBMODE(K,NBMODE) = 1.0D0 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0 BBMODE(1,K,NBMODE) = ZERO 40 BBMODE(2,K,NBMODE) = -G*ORT ENDIF ENDIF 2000 CONTINUE C--now compute the maximum weights for the three body decays found 2999 CONTINUE DO 3000 I=1,N3MODE IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN RHOIN(1,1) = ONE RHOIN(1,2) = ZERO RHOIN(2,1) = ZERO RHOIN(2,2) = ZERO ELSE RHOIN(1,1) = HALF RHOIN(1,2) = ZERO RHOIN(2,1) = ZERO RHOIN(2,2) = HALF ENDIF PHEP(5,1) = RMASS(IDK(ID3PRT(I))) PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2) PHEP(1,1) = 100.0D0 PHEP(2,1) = 0.0D0 PHEP(3,1) = 0.0D0 IF(IPRINT.GE.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))), & RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))), & RNAME(IDKPRD(3,ID3PRT(I))) 3000 CALL HWD3ME(1,0,I,RHOIN,1) IF(.NOT.SUSYIN) RETURN C--and for the two body gauge boson modes DO 4000 I=1,NBMODE IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN RHOIN(1,1) = ONE RHOIN(1,2) = ZERO RHOIN(2,1) = ZERO RHOIN(2,2) = ZERO ELSE RHOIN(1,1) = HALF RHOIN(1,2) = ZERO RHOIN(2,1) = ZERO RHOIN(2,2) = HALF ENDIF PHEP(5,1) = RMASS(IDK(IDBPRT(I))) PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2) PHEP(1,1) = 100.0D0 PHEP(2,1) = 0.0D0 PHEP(3,1) = 0.0D0 IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))), & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I))) IL = 12 IF(IBMODE(I).NE.200) IL = 6 DO 4000 J=1,IL 4000 CALL HWD3ME(1,J,I,RHOIN,1) RETURN 5000 FORMAT(/'CALCULATING THREE BODY DECAY ', & A8,' --> ',A8,' ',A8,' ',A8/) 5010 FORMAT(/'CALCULATING TWO BODY DECAY ', & A8,' --> ',A8,' ',A8/) 999 RETURN END CDECK ID>, HWISP4. *CMZ :- -12/10/01 12.04.54 by Peter Richardson *-- Author : Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWISP4 C----------------------------------------------------------------------- C Initialise the Higgs four body modes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,IL,IH,II,JJ DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4), & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4), & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2), & HZZ(2),ZAB(12,2,2),HHB(2,3),GS COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP, & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN C--four body Higgs modes via virtual WW and ZZ DO 1000 JJ=1,NRES DO 1000 II=1,NMODES(JJ) IF(II.EQ.1) THEN I = LSTRT(JJ) ELSE I = LNEXT(I) ENDIF IH=IDK(I)-202 IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND. & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND. & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN C--first the WW modes IF(IDKPRD(1,I).NE.200) THEN N4MODE = N4MODE+1 IF(N4MODE.GT.NMODE4) THEN CALL HWWARN('HWISP4',100) GOTO 999 ENDIF NME(I) = 40000+N4MODE ID4PRT(N4MODE) = I I4MODE(1,N4MODE) = 198 I4MODE(2,N4MODE) = 199 DO 1 K=1,6 A4MODE(1,K,N4MODE) = ZERO A4MODE(2,K,N4MODE) =-G*ORT B4MODE(1,K,N4MODE) = ZERO 1 B4MODE(2,K,N4MODE) =-G*ORT C--now the prefactors DO 2 J=1,6 COL(1) = HWW(IH)**2 IF(J.LE.3) COL(1) = THREE*COL(1) DO 2 K=1,6 COL(2) = ONE IF(K.LE.3) COL(2) = THREE*COL(2) 2 P4MODE(J,K,N4MODE) = COL(1)*COL(2) C--then the ZZ modes ELSE N4MODE = N4MODE+1 IF(N4MODE.GT.NMODE4) THEN CALL HWWARN('HWISP4',101) GOTO 999 ENDIF NME(I) = 40000+N4MODE ID4PRT(N4MODE) = I I4MODE(1,N4MODE) = 200 I4MODE(2,N4MODE) = 200 DO 3 K=1,12 IL = K IF(K.GT.6) IL=K+4 A4MODE(1,K,N4MODE) =-E*RFCH(IL) A4MODE(2,K,N4MODE) =-E*LFCH(IL) B4MODE(1,K,N4MODE) =-E*RFCH(IL) 3 B4MODE(2,K,N4MODE) =-E*LFCH(IL) DO 4 J=1,12 COL(1) = HALF*HZZ(IH)**2 IF(J.LE.6) COL(1)=THREE*COL(1) DO 4 K=1,12 COL(2) = ONE IF(K.LE.6) COL(2) = THREE 4 P4MODE(J,K,N4MODE) = COL(1)*COL(2) ENDIF ENDIF 1000 CONTINUE C--compute the maximum weights IF(N4MODE.EQ.0) RETURN DO 2000 I=1,N4MODE PHEP(5,1) = RMASS(IDK(ID4PRT(I))) PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2) PHEP(1,1) = 100.0D0 PHEP(2,1) = 0.0D0 PHEP(3,1) = 0.0D0 IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))), & RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I))) IL = 12 IF(I4MODE(1,I).NE.200) IL = 6 DO 2000 J=1,IL DO 2000 K=1,IL 2000 CALL HWD4ME(1,J,K,I) RETURN 5010 FORMAT(/'CALCULATING TWO BODY DECAY ', & A8,' --> ',A8,' ',A8/) 999 RETURN END CDECK ID>, HWISSP. *CMZ :- -12/10/01 09:41:43 by Peter Richardson *-- Author : Bryan Webber, modified by Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWISSP C----------------------------------------------------------------------- C Reads in SUSY particle properties and decays, C in format generated by ISAWIG C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2 LOGICAL FIRST EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200)) SAVE MDKYS SAVE FIRST DATA FIRST/.TRUE./ IF (FIRST) THEN MDKYS=NDKYS FIRST=.FALSE. ELSE NDKYS=MDKYS ENDIF C--reset susy input flag IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500) SUSYIN = .TRUE. C C Input SUSY particle + top quark table C WRITE (6,9) ' ' 9 FORMAT(//10X,A28//, & 10X,'Since SUSY processes are called,' & ,/, 10X,'please also reference: S.Moretti, K.Odagiri,' & ,/, 10X,'P.Richardson, M.H.Seymour & B.R.Webber,' & ,/, 10X,'JHEP 0204 (2002) 028') WRITE (6,10) LRSUSY 10 FORMAT (/10X,'Reading in SUSY data from unit',I3) READ (LRSUSY,'(I4)') NSSP IF (NSSP.LE.0) RETURN RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2)) RMMNSS=RMMAX DO I=1,NSSP READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW) C Negative gaugino mass means physical field is gamma_5*psi C Store the signs IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN IF (IHW.LE.453) THEN J=IHW-449 ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW)) ELSEIF (IHW.LE.455) THEN J=IHW-453 WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW)) ENDIF RMASS(IHW)=ABS(RMASS(IHW)) ENDIF IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO)) & RMMNSS=MIN(RMMNSS,RMASS(IHW)) IF (IHW.GT.NRES) THEN IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501) NRES=IHW ENDIF ENDDO XLMNSS=TWO*LOG(RMMNSS/RMMAX) 1 FORMAT(I5,F12.4,E15.5) C C Input decay modes C NDECSY = NDKYS+1 DO I=1,NSSP READ (LRSUSY,'(I4)') NDEC IF (NDEC.GT.0) THEN DO J=1,NDEC NDKYS=NDKYS+1 IF (NDKYS.GT.NMXDKS) THEN CALL HWWARN('HWISSP',100) GOTO 999 ENDIF READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS), & (IDKPRD(K,NDKYS),K=1,5) 11 FORMAT(I6,F16.8,6I6) ENDDO ENDIF ENDDO C C Mixings and other SUSY parameters C READ (LRSUSY,'(2F16.8)') TANB,ALPHAH DO I=1,4 READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4) END DO WEINSIN = SQRT(SWEIN) WEINCOS = SQRT(1.-SWEIN) DO I=1,4 ZMIXSS(I,1) = WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2) ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2) ZMIXSS(I,3) = ZMXNSS(I,3) ZMIXSS(I,4) = ZMXNSS(I,4) END DO DO J=1,16 IF ((J.LE.6).OR.(J.GE.11)) THEN C--left and right couplings now computed in HWIGIN DO I=1,4 SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J) SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J) END DO ENDIF END DO READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2) READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2) READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS READ (LRSUSY,'( F16.8)') MUSS DO I=1,6 QMIXSS(I,1,1)=1. QMIXSS(I,1,2)=0. QMIXSS(I,2,1)=0. QMIXSS(I,2,2)=1. LMIXSS(I,1,1)=1. LMIXSS(I,1,2)=0. LMIXSS(I,2,1)=0. LMIXSS(I,2,2)=1. END DO QMIXSS(6,1,1)= COS(THETAT) QMIXSS(6,1,2)= SIN(THETAT) QMIXSS(6,2,1)=-QMIXSS(6,1,2) QMIXSS(6,2,2)= QMIXSS(6,1,1) QMIXSS(5,1,1)= COS(THETAB) QMIXSS(5,1,2)= SIN(THETAB) QMIXSS(5,2,1)=-QMIXSS(5,1,2) QMIXSS(5,2,2)= QMIXSS(5,1,1) LMIXSS(5,1,1)= COS(THETAL) LMIXSS(5,1,2)= SIN(THETAL) LMIXSS(5,2,1)=-LMIXSS(5,1,2) LMIXSS(5,2,2)= LMIXSS(5,1,1) C--Evaluating Higgs parameters and couplings BETAH=ATAN(TANB) COTB=ONE/TANB COSBPA=COS(BETAH+ALPHAH) SINBPA=SIN(BETAH+ALPHAH) COSBMA=COS(BETAH-ALPHAH) SINBMA=SIN(BETAH-ALPHAH) COSA=COS(ALPHAH) SINA=SIN(ALPHAH) COSB=COS(BETAH) SINB=SIN(BETAH) GHWWSS(1)=SINBMA GHWWSS(2)=COSBMA GHWWSS(3)=ZERO DO 30 I=1,3 GHZZSS(I)=GHWWSS(I) 30 CONTINUE GHDDSS(1)=-SINA/COSB GHDDSS(2)= COSA/COSB GHDDSS(3)= TANB GHUUSS(1)= COSA/SINB GHUUSS(2)= SINA/SINB GHUUSS(3)= COTB GHWHSS(1)= COSBMA GHWHSS(2)= SINBMA GHWHSS(3)= ONE MZSW2 = MZ**2 * SQRT(SWEIN*(ONE-SWEIN)) DTERM(1) =-SINBPA*MZSW2 DTERM(2) = COSBPA*MZSW2 DTERM(3) = ZERO FTMUU(1) = MUSS*SINA/SINB FTMUU(2) =-MUSS*COSA/SINB FTMUU(3) =-MUSS FTMUU(4) =-MUSS FTMTT(1) = ATSS*COSA/SINB FTMTT(2) = ATSS*SINA/SINB FTMTT(3) =-ATSS*COTB FTMTT(4) =-ATSS*COTB FTMDD(1) =-MUSS*COSA/COSB FTMDD(2) =-MUSS*SINA/COSB FTMDD(3) =-MUSS FTMDD(4) =-MUSS FTMBB(1) =-ABSS*SINA/COSB FTMBB(2) = ABSS*COSA/COSB FTMBB(3) =-ABSS*TANB FTMBB(4) =-ABSS*TANB DO 40 IH=1,4 FTMU=FTMUU(IH) FTMD=FTMDD(IH) DO 50 I=1,6 IF (I.EQ.5) FTMU=FTMU+FTMTT(IH) IF (I.EQ.5) FTMD=FTMD+FTMBB(IH) IF (MOD(I,2).EQ.0) THEN YTM = GHUUSS(IH) FTM = FTMU ELSE YTM = GHDDSS(IH) FTM = FTMD END IF IF (IH.EQ.3) THEN GHSQSS(IH,I,1,1) = ZERO GHSQSS(IH,I,2,2) = ZERO GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2) GOTO 50 ELSEIF (IH.EQ.4) THEN SQHF=SQRT(HALF) SNBCSB=SINB*COSB DO 60 J=1,2 DO 70 K=1,2 IF (MOD(I,2).EQ.1) THEN GHSQSS(IH,I,J,K)=SQHF*( & RMASS(I )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K) & +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K) & +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB & -RMASS(I )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K) & -RMASS(I)*RMASS(I+1)/SNBCSB & *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW ELSE GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J) END IF 70 END DO 60 END DO ELSE DO 80 J=1,2 DO 90 K=1,2 YTM1=ZERO IF (J.EQ.K) YTM1=YTM*RMASS(I)**2 GHSQSS(IH,I,J,K)=( YTM1 & +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K) & -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH) & +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K) & +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW 90 CONTINUE 80 CONTINUE END IF 50 CONTINUE 40 CONTINUE C--Rparity violation READ (LRSUSY,'(L5)') RPARTY IF(.NOT.RPARTY) THEN READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3) READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3) READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3) ENDIF 13 FORMAT(4F16.8) 20 FORMAT(27E16.8) CLOSE(LRSUSY) IF(FOURB) CALL HWIMDE 999 RETURN END CDECK ID>, HWMEVT. *CMZ :- -04/05/99 14.28.59 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWMEVT C----------------------------------------------------------------------- C IPROC = 1000,... ADDS SOFT UNDERLYING EVENT C = 8000: CREATES MINIMUM-BIAS EVENT C SUPPRESSED BY ADDING 10000 TO IPROC C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3) INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS, & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2), & INID(2,2),JBT C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM) DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN SAVE VCLX,VCLY,VCLZ,VCLT DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/ C--END FIX IF (IERROR.NE.0) RETURN IF (.NOT.GENSOF) GOTO 990 IF (IPROC.EQ.8000) THEN C---SET UP BEAM AND TARGET CLUSTERS 5 NETC=0 DO 10 IBT=1,2 JBT=IBT IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT) IDBT=IDHW(JBT) IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=110 ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN INID(1,IBT)=116 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.30) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=8 ELSEIF (IDBT.EQ.38) THEN INID(1,IBT)=2 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.34) THEN INID(1,IBT)=3 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.46) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=9 ELSEIF (IDBT.EQ.59) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=HWRINT(7,8) ELSE CALL HWWARN('HWMEVT',100) GOTO 999 ENDIF NETC=NETC+ICHRG(IDBT) & -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3 ENFAC=1. IDHW(NHEP+IBT)=19 IDHEP(NHEP+IBT)=91 ISTHEP(NHEP+IBT)=163+IBT JMOHEP(1,NHEP+IBT)=JBT 10 CONTINUE IF (NETC.EQ.0) THEN ID3=HWRINT(1,2) ELSEIF (NETC.EQ.-1) THEN ID3=1 ELSEIF (NETC.EQ.1) THEN ID3=2 ELSE GOTO 5 ENDIF DO 12 IBT=1,2 NHEP=NHEP+1 JBT=IBT IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT) CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP)) 12 INHEP(IBT)=NHEP ELSE C---FIND BEAM AND TARGET CLUSTERS DO 20 IBT=1,2 DO 15 KHEP=1,NHEP IF (ISTHEP(KHEP).EQ.163+IBT) THEN INHEP(IBT)=KHEP INID(1,IBT)=IDHW(JMOHEP(1,KHEP)) INID(2,IBT)=IDHW(JMOHEP(2,KHEP)) GOTO 20 ENDIF 15 CONTINUE C---COULDN'T FIND ONE INHEP(IBT)=0 20 CONTINUE JCL=-1 C---TEST FOR BOTH FOUND IF (INHEP(1).EQ.0) JCL=INHEP(2) IF (INHEP(2).EQ.0) JCL=INHEP(1) IF (JCL.EQ.0) THEN CALL HWWARN('HWMEVT',101) GOTO 999 ENDIF IF (JCL.GT.0) THEN ISTHEP(JCL)=163 CALL HWCFOR CALL HWCDEC CALL HWDHAD CALL HWDHVY GOTO 90 ENDIF ID3=HWRINT(1,2) ENFAC=ENSOF NETC=0 ENDIF C---FIND SOFT CM MOMENTUM AND MULTIPLICITY NTRY=0 NHEP=NHEP+1 IF (NHEP.GT.NMXHEP) THEN CALL HWWARN('HWMEVT',102) GOTO 999 ENDIF ICMS=NHEP IDHW(NHEP)=16 IDHEP(NHEP)=0 C--Bug Fix 31/03/00 PR JMOHEP(1,ICMS)=INHEP(1) JMOHEP(2,ICMS)=INHEP(2) C--End of Fix ISTHEP(NHEP)=170 CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) TECM=PHEP(5,NHEP) IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN SECM=TECM*ENFAC ELSE SECM=PHEP(5,3)*ENFAC ENDIF C---CHOOSE MULTIPLICITY 25 CALL HWMULT(SECM,NPPBAR) 30 NCL=0 MCHT=0 IERROR=0 NHEP =ICMS SUMM=0. NTRY=NTRY+1 C---CREATE CLUSTERS 35 NCL=NCL+1 NHEP=NHEP+1 IF (NHEP.GT.NMXHEP) THEN CALL HWWARN('HWMEVT',103) GOTO 999 ENDIF JCL=NHEP IDHW(JCL)=19 IDHEP(JCL)=91 IF (NCL.LT.3) THEN ISTHEP(JCL)=170+NCL ID1=INID(1,NCL) ID2=INID(2,NCL) ELSE ID1=ID2-6 IF (NCL.EQ.3) ID1=ID3 ID2=HWRINT(7,8) ISTHEP(JCL)=173 ENDIF JMOHEP(1,JCL)=ICMS JMOHEP(2,JCL)=0 CALL HWVZRO(3,PHEP(1,JCL)) PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2) PHEP(5,JCL)=PHEP(4,JCL) C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE C--VERTEX POSITION FOR CLUSTER FORMATION VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX) VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY) VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ) VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2) & -VCLT*LOG(HWRGEN(0)) C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM CALL HWVZRO(4,VTXPIP) C--END FIXES C---HADRONIZE AND DECAY CLUSTERS CALL HWCFLA(ID1,ID2,JD1,JD2) CALL HWCHAD(JCL,JD1,JD2,JD3) IF (IERROR.NE.0) RETURN IF (JD3.EQ.0) THEN EMCL=RMASS(IDHW(NHEP)) IF (PHEP(4,JCL).NE.EMCL) THEN PHEP(4,JCL)=EMCL PHEP(5,JCL)=EMCL PHEP(4,NHEP)=EMCL PHEP(5,NHEP)=EMCL ENDIF ELSE EMCL=PHEP(5,JCL) ENDIF IDCL(NCL)=JD3 PPCL(5,NCL)=EMCL SUMM=SUMM +EMCL CALL HWDHAD CALL HWDHVY IF (IERROR.NE.0) RETURN C---CHECK CHARGED MULTIPLICITY MODC=0 DO 50 KHEP=JCL,NHEP IF (ISTHEP(KHEP).EQ.1) THEN ICH=ICHRG(IDHW(KHEP)) IF (ICH.NE.0) THEN MCHT=MCHT+ABS(ICH) MODC=MODC+ICH ENDIF ENDIF 50 CONTINUE IF (NCL.EQ.1) THEN NCHT=NPPBAR+NETC+ABS(MODC) GOTO 35 ELSEIF (NCL.EQ.2) THEN NCHT=NCHT+ABS(MODC) IF (NCHT.LT.0) NCHT=NCHT+2 ENDIF IF (MCHT.LT.NCHT) THEN GOTO 35 ELSEIF (MCHT.GT.NCHT) THEN IF (MOD(NTRY,50).EQ.0) GOTO 25 IF (NTRY.LT.NSTRY) GOTO 30 C---NO PHASE SPACE FOR SOFT EVENT NHEP=ICMS-1 IF (IPROC.EQ.8000) THEN C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS DO 60 IBT=1,2 KHEP=INHEP(IBT) LHEP=JMOHEP(1,KHEP) ISTHEP(KHEP)=1 IDHEP(KHEP)=IDHEP(LHEP) IDHW(KHEP)=IDHW(LHEP) 60 CONTINUE ELSE C---UNDERLYING EVENT: DECAY THEM ISTHEP(INHEP(1))=163 ISTHEP(INHEP(2))=163 CALL HWCFOR CALL HWCDEC CALL HWDHAD CALL HWDHVY ENDIF GOTO 90 ENDIF C---GENERATE CLUSTER MOMENTA IN CLUSTER CM C FRAME. N.B. SECOND CLUSTER IS TARGET IF (SUMM.GT.TECM) GOTO 25 CALL HWMLPS(TECM) IF (NCL.EQ.0) GOTO 25 JCL=0 C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP) CALL HWUROT(BMP, ONE,ZERO,BMR) C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE) DO 70 KHEP=ICMS+1,NHEP IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190 $ .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN ISTHEP(KHEP)=ISTHEP(KHEP)+3 LHEP=KHEP JCL=JCL+1 CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL)) CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL)) C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER ENDIF CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP)) C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP)) C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190 $ .AND.JMOHEP(1,KHEP).EQ.ICMS)) $ CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP)) C--END FIXES 70 CONTINUE ISTHEP(INHEP(1))=167 ISTHEP(INHEP(2))=168 JDAHEP(1,INHEP(1))=ICMS JDAHEP(2,INHEP(1))=0 JDAHEP(1,INHEP(2))=ICMS JDAHEP(2,INHEP(2))=0 JDAHEP(1,ICMS)=ICMS+1 JDAHEP(2,ICMS)=LHEP 90 CONTINUE 990 ISTAT=100 999 RETURN END CDECK ID>, HWMLPS. *CMZ :- -04/05/99 14.17.04 by Bryan Webber *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWMLPS(TECM) C----------------------------------------------------------------------- C GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH C RETURNS WITH NCL=0 IF UNSUCCESSFUL C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX, & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3, & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL) INTEGER NTRY,I,NIT,IY(NMXCL),IDP EXTERNAL HWREXT,HWRUNG,HWUSQR IF (NCL.GT.NMXCL) THEN CALL HWWARN('HWMLPS',1) NCL=NMXCL ENDIF ESS=TECM**2 ALOGS=LOG(ESS) EPS=1D-10/NCL NTRY=0 11 NTRY=NTRY+1 IF (NTRY.GT.NSTRY) THEN NCL=0 RETURN ENDIF SUMX=0. SUMY=0. DO 12 I=1,NCL C---Pt distribution of form exp(-b*Mt) C---Factors for pt slopes to fit data. IDCL contains the type of C q-qbar pair produced in this cluster (0 if 1-particle cluster). IDP=IDCL(I) IF (IDP.LE.2) THEN SLOP=PMBP1 ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN SLOP=PMBP2 ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN SLOP=PMBP3 ELSE CALL HWWARN('HWMLPS',IDP) IF(IDP.LT.0.OR.IDP.GT.49) GOTO 999 SLOP=PMBP2 ENDIF PT=HWREXT(PPCL(5,I),SLOP) PT=HWUSQR(PT**2-PPCL(5,I)**2) CALL HWRAZM(PT,PX,PY) PPCL(1,I)=PX PPCL(2,I)=PY SUMX=SUMX+PPCL(1,I) 12 SUMY=SUMY+PPCL(2,I) SUMX=SUMX/NCL SUMY=SUMY/NCL SUMPT2=0. SUMTM=0. DO 13 I=1,NCL PPCL(1,I)=PPCL(1,I)-SUMX PPCL(2,I)=PPCL(2,I)-SUMY PT2=PPCL(1,I)**2+PPCL(2,I)**2 SUMPT2=SUMPT2+PT2 C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2) 13 SUMTM=SUMTM+PPCL(3,I) IF (SUMTM.GT.TECM) GOTO 11 DO 14 I=1,NCL C---Form of "reduced rapidity" distribution XI(I)=HWRUNG(0.6*ONE,ONE) 14 CONTINUE CALL HWUSOR(XI,NCL,IY,1) XIMIN=XI(1) XIMAX=XI(NCL)-XI(1) C---N.B. TARGET CLUSTER IS SECOND XI(1)=0. DO 16 I=NCL-1,2,-1 XI(I+1)=(XI(I)-XIMIN)/XIMAX 16 CONTINUE XI(2)=1. YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2))) DO 18 NIT=1,10 SUM1=0. SUM2=0. SUM3=0. SUM4=0. DO 19 I=1,NCL TM=PPCL(3,I) EX=EXP(YY*XI(I)) SUM1=SUM1+(TM*EX) SUM2=SUM2+(TM/EX) SUM3=SUM3+(TM*EX)*XI(I) 19 SUM4=SUM4+(TM/EX)*XI(I) FY=ALOGS-LOG(SUM1*SUM2) DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2) DYY=FY/DD IF(ABS(DYY/YY).LT.EPS) GOTO 20 18 YY=YY+DYY C---Y ITERATIONS EXCEEDED - TRY AGAIN IF (NTRY.LT.100) GOTO 11 EPS=10.*EPS IF (EPS.GT.ONE) THEN CALL HWWARN('HWMLPS',100) GOTO 999 ENDIF CALL HWWARN('HWMLPS',50) GOTO 11 20 YY=YY+DYY ZZ=LOG(TECM/SUM1) DO 22 I=1,NCL TM=PPCL(3,I) E1=EXP(ZZ+YY*XI(I)) PPCL(3,I)=(0.5*TM)*((1./E1)-E1) PPCL(4,I)=(0.5*TM)*((1./E1)+E1) 22 CONTINUE 999 RETURN END CDECK ID>, HWMNBI. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWMNBI(N,AVNCH,EK) C----------------------------------------------------------------------- C---Computes negative binomial probability C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWMNBI,AVNCH,EK,R INTEGER N,I IF(N.LE.0) THEN HWMNBI=0 ELSE R=AVNCH/EK HWMNBI=(1.+R)**(-EK) R=R/(1.+R) DO 1 I=1,N HWMNBI=HWMNBI*R*(EK+I-1)/I 1 CONTINUE ENDIF END CDECK ID>, HWMODK. *CMZ :- -27/07/99 13.33.03 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP, & IATMP,IBTMP,ICTMP,IDTMP,IETMP) C----------------------------------------------------------------------- C Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it C if internal pointers not set up (.NOT.DKPSET) else if pre-existing C mode updates branching ratio BRTMP and matrix element code IMETMP, C if -ve leaves as is. If a new mode adds to table and if consistent C adjusts pointers, sets CMMOM (for two-body mode) and resets RSTAB C if necessary. The branching ratios of any other IDKTMP decays are C scaled by (1.-BRTMP)/(1.-BR_OLD) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5), & L,I,J,K,JPREV LOGICAL MATCH(5),IFGO CHARACTER*8 CDUM EXTERNAL HWUPCM PARAMETER (EPS=1.D-6) C Convert to internal format CALL HWUIDT(1,IDKTMP,IDKY,CDUM) IF (IDKY.EQ.20) THEN WRITE(6,10) IDKTMP 10 FORMAT(1X,'Particle decaying,',I7,', is not recognised') RETURN ENDIF CALL HWUIDT(1,IATMP,ITMP(1),CDUM) CALL HWUIDT(1,IBTMP,ITMP(2),CDUM) CALL HWUIDT(1,ICTMP,ITMP(3),CDUM) CALL HWUIDT(1,IDTMP,ITMP(4),CDUM) CALL HWUIDT(1,IETMP,ITMP(5),CDUM) C If internal pointers not yet set up simply store decay IF (.NOT.DKPSET) THEN NDKYS=NDKYS+1 IF (NDKYS.GT.NMXDKS) THEN CALL HWWARN('HWMODK',100) GOTO 999 ENDIF IDK(NDKYS)=IDKY BRFRAC(NDKYS)=BRTMP NME(NDKYS)=IMETMP DO 20 I=1,5 20 IDKPRD(I,NDKYS)=ITMP(I) ELSE IF (NMODES(IDKY).GT.0) THEN C First search to see if mode pre-exists IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR. & (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN C Partonic respect order L=LSTRT(IDKY) DO 30 K=1,NMODES(IDKY) IF (ITMP(1).EQ.IDKPRD(1,L).AND. & ITMP(2).EQ.IDKPRD(2,L).AND. & ITMP(3).EQ.IDKPRD(3,L).AND. & ITMP(4).EQ.IDKPRD(4,L).AND. & ITMP(5).EQ.IDKPRD(5,L)) GOTO 90 30 L=LNEXT(L) ELSE C Allow for different order in matching L=LSTRT(IDKY) DO 70 I=1,NMODES(IDKY) DO 40 J=1,5 40 MATCH(J)=.FALSE. DO 60 J=1,5 DO 50 K=1,5 IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN MATCH(K)=.TRUE. GOTO 60 ENDIF 50 CONTINUE 60 CONTINUE IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND. & MATCH(4).AND.MATCH(5)) GOTO 90 70 L=LNEXT(L) ENDIF ENDIF C A new mode put decay products in table NDKYS=NDKYS+1 IF (NDKYS.GT.NMXDKS) THEN CALL HWWARN('HWMODK',101) GOTO 999 ENDIF DO 80 I=1,5 80 IDKPRD(I,NDKYS)=ITMP(I) C If decay consistent set up new pointers CALL HWDCHK(IDKY,NDKYS,IFGO) IF(IFGO) GOTO 980 IF (NMODES(IDKY).EQ.0) THEN LSTRT(IDKY)=NDKYS IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN RSTAB(IDKY)=.FALSE. DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR ELSE RSTAB(IDKY)=.TRUE. ENDIF ELSE LNEXT(L)=NDKYS ENDIF NMODES(IDKY)=NMODES(IDKY)+1 LNEXT(NDKYS)=NDKYS L=NDKYS C Set CMMOM if two body decay IF (NPRODS(L).EQ.2) CMMOM(L)= & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L))) C A Pre-existing mode, line L, add/update ME code and BR, scaling all C other branching fractions 90 IF (IMETMP.GT.0) NME(L)=IMETMP IF (ABS(BRTMP-1.).LT.EPS) THEN C This modes dominant: eliminate others NMODES(IDKY)=1 LSTRT(IDKY)=L BRFRAC(L)=ONE LNEXT(L)=L ELSEIF (ABS(BRTMP).LT.EPS) THEN C This mode insignificant: eliminate it IF (NMODES(IDKY).EQ.1) THEN RSTAB(IDKY)=.TRUE. ELSE J=LSTRT(IDKY) IF (J.EQ.L) THEN LSTRT(IDKY)=LNEXT(J) ELSE JPREV=J DO 100 I=2,NMODES(IDKY) J=LNEXT(J) IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J) 100 JPREV=J ENDIF C Rescale other modes SCALE=ONE/(ONE-BRFRAC(L)) J=LSTRT(IDKY) DO 110 I=1,NMODES(IDKY)-1 BRFRAC(J)=SCALE*BRFRAC(J) 110 J=LNEXT(J) ENDIF NMODES(IDKY)=NMODES(IDKY)-1 ELSE C Rescale all other modes IF (NMODES(IDKY).EQ.1) THEN BRFRAC(L)=ONE ELSE IF (L.EQ.NDKYS) THEN SCALE=ONE-BRTMP ELSE SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L)) ENDIF J=LSTRT(IDKY) DO 120 I=1,NMODES(IDKY) IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J) 120 J=LNEXT(J) BRFRAC(L)=BRTMP ENDIF ENDIF ENDIF GOTO 999 980 WRITE(6,990) 990 FORMAT(1X,'Decay mode inconsistent, no modifications made') 999 RETURN END CDECK ID>, HWMULT. *CMZ :- -04/05/99 11.11.55 by Bryan Webber *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWMULT(EPPBAR,NCHT) C----------------------------------------------------------------------- C Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R, & CUM(500) INTEGER NCHT,IMAX,I,N SAVE E0,CUM,IMAX EXTERNAL HWMNBI,HWRGEN DATA E0/0/ IF (EPPBAR.NE.E0) THEN E0=EPPBAR C---Initialize ALOGS=2.*LOG(EPPBAR) RK=PMBK1*ALOGS+PMBK2 IF (ABS(RK).GT.1000.) RK=1000. EK=1./RK AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3 IF (AVN.LT.ONE) AVN=1. SUM=0. IMAX=1 DO 10 I=1,500 N=2*I CUM(I)=HWMNBI(N,AVN,EK) IF (CUM(I).LT.1D-7*SUM) GOTO 11 IMAX=I SUM=SUM+CUM(I) CUM(I)=SUM 10 CONTINUE 11 CONTINUE IF (IMAX.LE.1) THEN IMAX=1 CUM(1)=1 ELSEIF (IMAX.EQ.500) THEN E0=0 CALL HWWARN('HWMULT',101) GOTO 999 ELSE DO 12 I=1,IMAX 12 CUM(I)=CUM(I)/SUM ENDIF ENDIF C --- Select NCHT R=HWRGEN(0) DO 20 I=1,IMAX IF(R.GT.CUM(I)) GOTO 20 NCHT=2*I RETURN 20 CONTINUE CALL HWWARN('HWMULT',100) 999 RETURN END CDECK ID>, HWMWGT. *CMZ :- -02/11/93 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWMWGT C----------------------------------------------------------------------- C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION S,X,Y INTEGER IDB,IDT,IDBT IF (IERROR.NE.0) RETURN IDB=IDHW(1) IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1)) IDT=IDHW(2) IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2)) IDBT=100*IDB+IDT IF (IDT.GT.IDB) IDBT=100*IDT+IDB C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF C CERN-TH.6635/92 IF (IDBT.EQ.9173) THEN X=21.70 Y=98.39 ELSEIF (IDBT.EQ.7373) THEN X=21.70 Y=56.08 ELSEIF (IDBT.EQ.7330) THEN X=13.63 Y=36.02 ELSEIF (IDBT.EQ.7338) THEN X=13.63 Y=27.56 ELSEIF (IDBT.EQ.7334) THEN X=11.82 Y=26.36 ELSEIF (IDBT.EQ.7346) THEN X=11.82 Y= 8.15 ELSEIF (IDBT.EQ.7359) THEN X=.0677 Y=.1290 ELSEIF (IDBT.EQ.9175) THEN X=21.70 Y=92.71 ELSEIF (IDBT.EQ.7573) THEN X=21.70 Y=54.77 ELSEIF (IDBT.EQ.5959) THEN C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE X=2.1E-4 Y=3.0E-4 ELSE PRINT *,' IDBT=',IDBT CALL HWWARN('HWMWGT',100) GOTO 999 ENDIF S=PHEP(5,3)**2 C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS C ASSUMING NON-DIFFRACTIVE = TOTAL*0.7 EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525)) 999 RETURN END CDECK ID>, HWPHTP. *CMZ :- -11/08/03 15:30:25 by Peter Richardson *-- Author : Peter Richardson and Zbigniew Was C----------------------------------------------------------------------- SUBROUTINE HWPHTP(IHEP) C----------------------------------------------------------------------- C subroutine for radiation in top decays C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP) DOUBLE PRECISION HWDPWT EXTERNAL HWDPWT C--add an extra photon for top or W IF(IERROR.NE.0) RETURN IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN NHEP0=NHEP KK1=JDAHEP(1,IHEP) KK2=JDAHEP(2,IHEP) C--copy the colour mother infomation DO KK=KK1,KK2 JMOH(KK)=JMOHEP(2,KK) JMOHEP(2,KK)=0 ENDDO C--call photos IPOS=-IHEP CALL PHOTOS(IPOS) C--reset the colour mother infomation DO KK=KK1,KK2 JMOHEP(2,KK)=JMOH(KK) ENDDO C--update the decaying particle JDAHEP(2,IHEP) = NHEP C--set up the additions photons in the record NN=NHEP-NHEP0 NHEP=NHEP0 IF(NN.GT.0) THEN DO KK=1,NN C--photon mass probably not needed PHEP(5,NHEP+1) = ZERO C--info on the photon ISTHEP(NHEP+1) = 114 IDHW(NHEP+1) = 59 IDHEP(NHEP+1) = 22 JMOHEP(1,NHEP+1) = IHEP JMOHEP(2,NHEP+1) = NHEP+1 JDAHEP(2,NHEP+1) = NHEP+1 NHEP = NHEP+1 ENDDO ENDIF ENDIF END CDECK ID>, HWPHTT. *CMZ :- -11/08/03 15:30:25 by Peter Richardson *-- Author : Peter Richardson and Zbigniew Was C----------------------------------------------------------------------- SUBROUTINE HWPHTT C----------------------------------------------------------------------- C subroutine for radiation in top production C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' C--local variables INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX C--initialisation IF(IERROR.NE.0) RETURN IFOUND=0 DO K=1,10 IMO(K)=0 ENDDO C--loop to find mothers of any tops NSTART=1 DO I=NSTART,NHEP IF (ABS(IDHEP(I)).EQ.6) THEN DO K=1,IFOUND IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10 ENDDO IFOUND=IFOUND+1 IMO(IFOUND)=JMOHEP(1,I) ENDIF 10 CONTINUE ENDDO C--generate the radiation DO K=1,IFOUND C--save the colour mother pointers JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K))) JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K))) C--zero the second mothers JMOHEP(2,JDAHEP(1,IMO(K)))=0 JMOHEP(2,JDAHEP(2,IMO(K)))=0 C--call photos to generate radiation CALL PHOTOS(IMO(K)) NHEPX=NHEP DO 11 J=NHEP,1,-1 IF(IDHEP(J).EQ.22) THEN NHEPX=NHEPX-1 ELSE GOTO 11 ENDIF 11 CONTINUE C--reset the colour pointers JMOHEP(2, JDAHEP(1,IMO(K)))=JMO(1) JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2) C--setup the photons DO L=NHEPX+1,NHEP ISTHEP(L)=114 JMOHEP(2,L) = L JDAHEP(2,L) = L IDHW(L) = 59 ENDDO ENDDO END CDECK ID>, HWRAZM. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWRAZM(PT,PX,PY) C----------------------------------------------------------------------- C RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO PARAMETER(ONE=1.0D0, ZERO=0.0D0) EXTERNAL HWRGEN 10 C=2.*HWRGEN(1)-1. S=2.*HWRGEN(2)-1. CS=C*C+S*S IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10 QT=PT/CS PX=(C*C-S*S)*QT PY=2.*C*S*QT END CDECK ID>, HWREXP. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWREXP(AV) C----------------------------------------------------------------------- C Random number from dN/d(x**2)=exp(-b*x) with mean AV C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2 EXTERNAL HWRGEN B=2./AV R1=HWRGEN(0) R2=HWRGEN(1) HWREXP=-LOG(R1*R2)/B END CDECK ID>, HWREXQ. *CMZ :- -02/06/94 11.02.47 by Mike Seymour *-- Author : David Ward, modified by Bryan Webber and Mike Seymour C----------------------------------------------------------------------- FUNCTION HWREXQ(AV,XMAX) C----------------------------------------------------------------------- C Random number from dN/d(x**2)=EXQ(-b*x) with mean AV, C But truncated at XMAX C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN EXTERNAL HWRGEN B=2./AV BXMAX=B*XMAX IF (BXMAX.LT.50) THEN RMIN=EXP(-BXMAX) ELSE RMIN=0 ENDIF 10 R1=HWRGEN(0)*(1-RMIN)+RMIN R2=HWRGEN(1)*(1-RMIN)+RMIN R=R1*R2 IF (R.LT.RMIN) GOTO 10 HWREXQ=-LOG(R)/B END CDECK ID>, HWREXT. *CMZ :- -26/04/91 11.11.55 by Bryan Webber *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWREXT(AM0,B) C----------------------------------------------------------------------- C Random number from dN/d(x**2)=exp(-B*TM) distribution, where C TM = SQRT(X**2+AM0**2). Uses Newton's method to solve F-R=0 C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM INTEGER NIT EXTERNAL HWRGEN R=HWRGEN(0) C --- Starting value AM=AM0-LOG(R)/B DO 1 NIT=1,20 A=EXP(-B*(AM-AM0))/(1.+B*AM0) F=(1.+B*AM)*A-R DF=-B**2*AM*A DAM=-F/DF AM=AM+DAM IF(AM.LT.AM0) AM=AM0+.001 IF(ABS(DAM).LT..001) GOTO 2 1 CONTINUE CALL HWWARN('HWREXT',1) 2 HWREXT=AM END CDECK ID>, HWRGAU. *CMZ :- -19/05/99 11.11.56 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- FUNCTION HWRGAU(J,A,B) C----------------------------------------------------------------------- C Gaussian random number, mean A, standard deviation B. C Generates uncorrelated pairs and throws one of them away. C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH INTEGER J EXTERNAL HWRGEN 10 X=HWRGEN(J) IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10 X=SQRT(-TWO*LOG(X)) CALL HWRAZM(X,X,TRASH) HWRGAU=A+B*X END CDECK ID>, HWRGEN. *CMZ :- -26/04/91 12.42.30 by Federico Carminati *-- Author : F. James, modified by Mike Seymour *- Split in 3 files by M. Kirsanov. Initial seeds ISEED set in HWUDAT C----------------------------------------------------------------------- FUNCTION HWRGEN(I) C----------------------------------------------------------------------- C MAIN RANDOM NUMBER GENERATOR C USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN COMMON/HWSEED/ISEED(2) INTEGER ISEED INTEGER I,K,IZ C K=ISEED(1)/53668 ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211 IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563 K=ISEED(2)/52774 ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791 IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399 IZ=ISEED(1)-ISEED(2) IF (IZ.LT.1) IZ=IZ+2147483562 HWRGEN=DBLE(IZ)*4.656613001013252D-10 C---> (4.656613001013252D-10 = 1.D0/2147483589) END CDECK ID>, HWRSET. *CMZ :- -26/04/91 12.42.30 by Federico Carminati *-- Author : F. James, modified by Mike Seymour C----------------------------------------------------------------------- FUNCTION HWRSET(JSEED) C----------------------------------------------------------------------- C MAIN RANDOM NUMBER GENERATOR C SETTING SEEDS C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRSET COMMON/HWSEED/ISEED(2) INTEGER ISEED INTEGER JSEED(2) HWRSET=0.0D0 IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) THEN CALL HWWARN('HWRSET',99) GOTO 999 ENDIF ISEED(1)=JSEED(1) ISEED(2)=JSEED(2) 999 RETURN END CDECK ID>, HWRGET. *CMZ :- -26/04/91 12.42.30 by Federico Carminati *-- Author : F. James, modified by Mike Seymour C----------------------------------------------------------------------- FUNCTION HWRGET(JSEED) C----------------------------------------------------------------------- C MAIN RANDOM NUMBER GENERATOR C GET SEEDS C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGET COMMON/HWSEED/ISEED(2) INTEGER ISEED INTEGER JSEED(2) C JSEED(1)=ISEED(1) JSEED(2)=ISEED(2) HWRGET=0.0D0 END CDECK ID>, HWRINT. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWRINT(IMIN,IMAX) C----------------------------------------------------------------------- C RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN,RN,ONE INTEGER HWRINT,IMIN,IMAX EXTERNAL HWRGEN PARAMETER (ONE=1.0D0) 1 RN=HWRGEN(0) IF (RN.EQ.ONE) GOTO 1 RN=RN*(IMAX-IMIN+1) HWRINT=IMIN+INT(RN) END CDECK ID>, HWRLOG. *CMZ :- -26/04/91 14.15.56 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWRLOG(A) C----------------------------------------------------------------------- C Returns .TRUE. with probability A C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN,A,R LOGICAL HWRLOG EXTERNAL HWRGEN HWRLOG=.TRUE. R=HWRGEN(0) IF(R.GT.A) HWRLOG=.FALSE. END CDECK ID>, HWRPIP. *CMZ :- -07/09/00 10:06:23 by Peter Richardson *-- Author : Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWRPIP C----------------------------------------------------------------------- C Generates a random primary IP using a triple Gaussian distribution C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWRGAU INTEGER I EXTERNAL HWRGAU DO 10 I=1,3 10 VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I)) VTXPIP(4)=ZERO END CDECK ID>, HWRPOW. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWRPOW(XVAL,XJAC) C----------------------------------------------------------------------- C RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW C AND CORRESPONDING JACOBIAN FACTOR XJAC C SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO LOGICAL FIRST PARAMETER(ZERO=0.0D0) EXTERNAL HWRGEN SAVE Q,A,B,C COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST IF (FIRST) THEN P=XPOW+1. IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500) Q=1./P A=XMIN**P B=XMAX**P-A C=B*Q FIRST=.FALSE. ENDIF Z=A+B*HWRGEN(0) XVAL=Z**Q XJAC=XVAL*C/Z END CDECK ID>, HWRUNG. *CMZ :- -26/04/91 14.55.45 by Federico Carminati *-- Author : David Ward, modified by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWRUNG(A,B) C----------------------------------------------------------------------- C Random number from distribution having flat top [-A,A] & gaussian C tail of s.d. B C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO LOGICAL HWRLOG EXTERNAL HWRGAU,HWRUNI,HWRLOG PARAMETER (ZERO=0.D0) IF (A.EQ.ZERO) THEN PRUN=0 ELSE PRUN=1./(1.+B*1.2533/A) ENDIF IF(HWRLOG(PRUN)) THEN HWRUNG=HWRUNI(0,-A,A) ELSE HWRUNG=HWRGAU(0,ZERO,B) HWRUNG=HWRUNG+SIGN(A,HWRUNG) ENDIF END CDECK ID>, HWRUNI. *CMZ :- -26/04/91 14.55.45 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWRUNI(I,A,B) C----------------------------------------------------------------------- C Uniform random random number in range [A,B] C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN INTEGER I EXTERNAL HWRGEN RN=HWRGEN(I) HWRUNI=A+RN*(B-A) END CDECK ID>, HWSBRN. *CMZ :- -18/10/99 19.08.45 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWSBRN(KPAR) C----------------------------------------------------------------------- C DOES BRANCHING OF SPACELIKE PARTON KPAR C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ, & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA, & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP, & PTMP(2),JAC,OTHJAC,S,T,U,EMB2,PTMX INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2, & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ LOGICAL HWSVAL,FORCE,VALPAR,FTMP EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD, & HWSVAL COMMON/HWTABC/XLAST,N0,IS,ID SAVE ISUD,DMIN DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/ IF (IERROR.NE.0) RETURN ID=IDPAR(KPAR) C--TEST FOR PARTON TYPE IF (ID.LE.13) THEN IS=ISUD(ID) ELSEIF (ID.GE.208) THEN IS=7 ELSE IS=0 END IF QNOW=-1. IF (IS.NE.0) THEN C--SPACELIKE PARTON BRANCHING QLST=PPAR(1,KPAR) IDHAD=IDHW(INHAD) VALPAR=HWSVAL(ID) QP=HWBVMC(ID) XLAST=XFACT*PPAR(4,KPAR) IF (XLAST.GE.ONE) THEN CALL HWWARN('HWSBRN',107) GOTO 999 ENDIF C--SET UP Q BOUNDARY IF (VALPAR) THEN QMIN=QG/(1.-XLAST) ELSEIF (ID.EQ.13) THEN QMIN=QV/(1.-XLAST) ELSE QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST) ENDIF QSAV=QMIN IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN QMIN=QSPAC N1=NSPAC(IS) ELSEIF (QMIN.LE.QEV(1,IS)) THEN QMIN=QEV(1,IS) N1=1 ELSE DO 110 I=2,NQEV IF (QEV(I,IS).GT.QMIN) GOTO 120 110 CONTINUE 120 N1=I-1 ENDIF N0=N1-1 MQ=NQEV-N0 NTRY=0 125 NTRY=NTRY+1 NREJ=1 IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN IF (QLST.LE.QMIN) THEN C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON IF (QLST.LT.QSAV) THEN CALL HWWARN('HWSBRN',ISLENT*105) GOTO 999 ENDIF FORCE=.TRUE. QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV ELSE C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH C IS CAPABLE OF BEING THE HARDEST SO FAR IF (QLST.GT.HARDST) NREJ=2 QTMP=-1 DO 300 IREJ=1,NREJ C--FIND NEW VALUE OF SUD/DIST CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD) IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN) IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID) CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD) IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST) IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID) RN=HWRGEN(0) IF (RN.EQ.ZERO) THEN SNOW=SLST*2. ELSE SNOW=SLST/RN ENDIF IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200 IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN FORCE=.FALSE. ELSE C--FORCE SPLITTING OF NON-VALENCE PARTON FORCE=.TRUE. QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV ENDIF IF (QNOW.LT.ZERO) THEN C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR SUDA=SMAX NDEL=32 NA=N1 130 NB=NA+NDEL IF (NB.GT.NQEV) THEN CALL HWWARN('HWSBRN',103) GOTO 999 ENDIF CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD) IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS)) IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN SUDB=SUD(NB,IS)/DIST(ID) IF (SUDB.GT.SUDA) THEN SUDA=SUDB NA=NB GOTO 130 ELSEIF (NA.NE.N1) THEN IF (SUDB.LT.SNOW) THEN NDEL=NDEL/2 IF (NDEL.EQ.0) THEN CALL HWWARN('HWSBRN',100) GOTO 999 ENDIF GOTO 130 ENDIF N1=NB N0=N1-1 MQ=NQEV-N0 ENDIF C--NOW FIND NEW Q QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER) IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD C CALL HWWARN('HWSBRN',1) QNOW=HWRUNI(0,QMIN,QLST) ENDIF ENDIF 200 CONTINUE IF (QNOW.GT.QTMP) THEN QTMP=QNOW FTMP=FORCE ENDIF QNOW=-1 300 CONTINUE QNOW=QTMP FORCE=FTMP ENDIF IF (QNOW.LT.ZERO) GOTO 210 C--NOW FIND NEW X CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ) IF (ID1.LT.0) THEN C--NO PHASE SPACE FOR BRANCHING FROST=.TRUE. RETURN ELSEIF (ID1.EQ.0) THEN C--BRANCHING REJECTED: REDUCE Q AND REPEAT IF (NTRY.GT.NBTRY.OR.IERROR.NE.0) THEN CALL HWWARN('HWSBRN',102) GOTO 999 ENDIF QLST=QNOW QNOW=-1. GOTO 125 ELSEIF (ID1.EQ.59) THEN C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING IF (IDHAD.NE.59) THEN CALL HWWARN('HWSBRN',109) GOTO 999 ENDIF ENOW=PPAR(4,KPAR)/XLAST XI=(QNOW/ENOW)**2 QLAM=QNOW*(1.-XLAST) IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN C--BRANCHING REJECTED: REDUCE Q AND REPEAT IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWSBRN',110) GOTO 999 ENDIF QLST=QNOW QNOW=-1. GOTO 125 ENDIF CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2)) CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD)) PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2 ANOMSC(1,JNHAD)=QNOW ANOMSC(2,JNHAD)=QNOW*(1.-XLAST) QNOW=-1. QLST=QNOW GOTO 125 ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWSBRN',108) GOTO 999 ENDIF QLST=QNOW QNOW=-1. GOTO 125 ENDIF ENDIF 210 CONTINUE IF (QNOW.GT.ZERO) THEN C--BRANCHING HAS OCCURRED ENOW=PPAR(4,KPAR)/ZZ XI=(QNOW/ENOW)**2 QLAM=QNOW*(1.-ZZ) IF ((SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR. & (2.-XI)*QLAM**2.GT.EMSCA**2).AND..NOT.FORCE) THEN C--BRANCHING REJECTED: REDUCE Q AND REPEAT IF (NTRY.GT.NBTRY) THEN CALL HWWARN('HWSBRN',104) GOTO 999 ENDIF QLST=QNOW QNOW=-1. GOTO 125 ENDIF C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION IF (.NOT.FORCE) THEN REJFAC=1 IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP) X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI)) X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI) X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2) IF (ID2.EQ.13) THEN C---GLUON EMISSION REJFAC=ZZ**3*(1-X1-X2+2*X1*X2) $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ))) $ *(1+ZZ**2)/((1-ZZ)*XI) $ *(1-X1)*(1-X2)/ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2) C---CHECK WHETHER IT IS IN THE OVERLAP REGION OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2)) IF (OTHXI.LT.ONE) THEN OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2 REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ)) $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI) $ *(1-X1)*(1-X2)/ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2) ENDIF ELSEIF (ID1.EQ.13) THEN C---GLUON SPLITTING REJFAC=ZZ**3*(1-X1-X2+2*X1*X2) $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ))) $ *(ZZ**2+(1-ZZ)**2)/XI $ *(1-X2)/ $ (( X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2 $ +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2) ENDIF ELSE C---COLOUR PARTNER IS ALSO INCOMING T=-(1-ZZ)*XI/ZZ**2 S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ))) U=1-S-T JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ))) IF (ID2.EQ.13) THEN C---GLUON EMISSION REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI) & *JAC*S**2*T*U/((1-U)**2+(1-T)**2) C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ) IF (OTHXI.LT.OTHZ**2) THEN OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI* & (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ))) REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI) & *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2) ENDIF ELSEIF (ID1.EQ.13) THEN C---GLUON SPLITTING REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI) & *JAC*S**3*T/((1-S)**2+(1-T)**2) ENDIF ENDIF ENDIF IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN QLST=QNOW QNOW=-1. GOTO 125 ENDIF IF (QLAM.GT.HARDST) HARDST=QLAM ENDIF IF (IW2.GT.IW1) THEN LPAR=NPAR+1 MPAR=NPAR+2 C---NEW MOTHER-DAUGHTER RELATIONS C N.B. DEFINED MOVING AWAY FROM HARD PROCESS JDAPAR(1,KPAR)=LPAR JDAPAR(2,KPAR)=MPAR C---NEW COLOUR CONNECTIONS JCOPAR(3,KPAR)=MPAR JCOPAR(4,KPAR)=LPAR JCOPAR(1,MPAR)=KPAR JCOPAR(2,MPAR)=LPAR JCOPAR(1,LPAR)=MPAR JCOPAR(2,LPAR)=KPAR ELSE MPAR=NPAR+1 LPAR=NPAR+2 JDAPAR(1,KPAR)=MPAR JDAPAR(2,KPAR)=LPAR JCOPAR(3,KPAR)=LPAR JCOPAR(4,KPAR)=MPAR JCOPAR(1,MPAR)=LPAR JCOPAR(2,MPAR)=KPAR JCOPAR(1,LPAR)=KPAR JCOPAR(2,LPAR)=MPAR ENDIF JMOPAR(1,LPAR)=KPAR JMOPAR(1,MPAR)=KPAR IDPAR(LPAR)=ID1 IDPAR(MPAR)=ID2 TMPAR(LPAR)=.FALSE. TMPAR(MPAR)=.TRUE. PPAR(1,LPAR)=QNOW PPAR(2,LPAR)=XI PPAR(4,LPAR)=ENOW PPAR(1,MPAR)=QNOW*(1.-ZZ) PPAR(2,MPAR)=XI PPAR(4,MPAR)=ENOW*(1.-ZZ) NPAR=NPAR+2 ENDIF ENDIF IF (QNOW.LT.ZERO) THEN C--BRANCHING STOPS JDAPAR(1,KPAR)=0 JDAPAR(2,KPAR)=0 JCOPAR(3,KPAR)=0 JCOPAR(4,KPAR)=0 IF (ID.LE.13) THEN C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL XLAST=XFACT*PPAR(4,KPAR) IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2) & THEN FROST=.TRUE. RETURN ENDIF C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION c$$$ PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST) c$$$ & +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD)) PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST) EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD)) PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0* $ ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2 C---END BRW MOD ELSEIF (ID.EQ.IDHW(INHAD)) THEN C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD)) ELSE PPAR(5,KPAR)=RMASS(ID)**2 ENDIF PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR) IF (PMOM.LT.ZERO) THEN FROST=.TRUE. RETURN ENDIF PPAR(3,KPAR)=SQRT(PMOM) ENDIF 999 RETURN END CDECK ID>, HWSDGG. *CMZ := =26/04/91 12.47.48 by Federico Carminati *-- Author : Drees, Grassie, Charchula, modified by Bryan Webber C =============================================================== C DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION C C HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA (!) C HWSDGG(X,Q2,NFL) - X*GLUON_IN_PHOTON/ALPHA (!) C WHERE: C (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3 C 2 FOR 2/3 C (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/ C Q2 - SQUARE OF MOMENTUM Q /IN GEV2/ C X - LONGITUDINAL FRACTION C LAMBDA=0.4 GEV C C NFL=3: 1 < Q2 < 50 GEV^2 C NFL=4: 20 < Q2 < 500 GEV^2 C NFL=5: 200 < Q2 < 10^4 GEV^2 C C C KRZYSZTOF CHARCHULA /14.02.1989/ C================================================================ C C PS. Note that for the case of three flavors, one has to add C the QPM charm contribution for getting F2. C C================================================================ C MODIFIED FOR HERWIG BY BRW 19/4/91 C--- ----------------------------------------------- C GLUON PART OF THE PHOTON SF C--- ----------------------------------------------- FUNCTION HWSDGG(X,Q2,NFL) IMPLICIT REAL (A-H,P-Z) INTEGER NFL DIMENSION A(3,4,3),AT(3) ALAM2=0.160 T=LOG(Q2/ALAM2) C- --- CHECK WHETHER NFL HAVE RIGHT VALUES ----- IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN WRITE(6,131) 131 FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/ *' NFL=3 IS ASSUMED') NFL=3 ELSEIF (T.LE.0) THEN WRITE(6,132) 132 FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.') HWSDGG=0 RETURN ENDIF C ------ INITIALIZATION OF PARAMETERS ARRAY ----- DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/ + -0.20700,-0.19870, 5.11900, + 0.61580, 0.62570,-0.27520, + 1.07400, 8.35200,-6.99300, + 0.00000, 5.02400, 2.29800, + 0.8926E-2, 0.05090,-0.23130, + 0.659400, 0.27740, 0.13820, + 0.476600,-0.39060, 6.54200, + 0.019750,-0.32120, 0.51620, + 0.031970, -0.618E-2, -0.1216, + 1.0180, 0.94760, 0.90470, + 0.24610, -0.60940, 2.6530, + 0.027070, -0.010670, 0.2003E-2/ C ------ Q2 DEPENDENCE ----------- LF=NFL-2 DO 20 I=1,3 AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF)) 20 CONTINUE C ------ GLUON DISTRIBUTION ------------- HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137. END CDECK ID>, HWSDGQ. *CMZ :- -26/04/91 13.04.45 by Federico Carminati *-- Author : Drees, Grassie, Charchula, modified by Bryan Webber C -------------------------------------- C QUARK PART OF THE PHOTON SF C -------------------------------------- FUNCTION HWSDGQ(X,Q2,NFL,NCH) IMPLICIT REAL (A-H,P-Z) INTEGER NFL,NCH DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2) COMMON/DG/F2 C SQUARE OF LAMBDA=0.4 GEV ALAM2=0.160 T=LOG(Q2/ALAM2) C C CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES C IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN WRITE(6,111) 111 FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/ *' NFL=3 IS ASSUMED') NFL=3 ELSEIF (T.LE.0) THEN WRITE(6,132) 132 FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.') HWSDGQ=0 RETURN ENDIF IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN WRITE(6,121) 121 FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET', *' TO 1 OR 2;'/ *' NCH=1 IS ASSUMED') NCH=1 ENDIF C ------ INITIALIZATION ------ DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/ + 2.28500, 6.07300, -0.42020,-0.08080, 0.05530, +-0.01530, -0.81320, 0.01780, 0.63460, 1.13600, + 1.3300E3,-41.3100, 0.92160, 1.20800, 0.95120, + 4.21900, 3.16500, 0.18000, 0.20300, 0.01160, +16.6900, 0.17600, -0.02080,-0.01680,-0.19860, +-0.79160, 0.04790, 0.3386E-2,1.35300, 1.10000, + 1.0990E3, 1.04700, 4.85300, 1.42600, 1.13600, + 4.42800, 0.02500, 0.84040, 1.23900,-0.27790/ DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/ +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160, + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660, + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100, +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590, +-0.12070,25.00000,-0.012300,-0.09190, 0.020150, + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690, + 1.97700,-0.015630,0.482400, 0.63970,-0.070360, +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/ DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/ +15.80, 2.7420, 0.029170,-0.03420, -0.023020, +-0.94640, -0.73320, 0.046570, 0.71960, 0.92290, +-0.50, 0.71480, 0.17850, 0.73380, 0.58730, +-0.21180, 3.2870, 0.048110, 0.081390,-0.79E-4, + 6.7340, 59.880, -0.3226E-2,-0.03321, 0.10590, +-1.0080, -2.9830, 0.84320, 0.94750, 0.69540, +-0.085940, 4.480, 0.36160, -0.31980, -0.66630, + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/ C ------- EVALUATION OF PARAMETERS IN Q2 --------- E(1)=1.0 IF (NFL.EQ.3) THEN E(2)=9.0 LF=1 ELSEIF (NFL.EQ.4) THEN E(2)=10.0 LF=2 ELSEIF (NFL.EQ.5) THEN E(2)=55.0/6.0 LF=3 ENDIF DO 10 J=1,2 DO 20 I=1,5 ATP=A(I,1,J,LF)*T**A(I,2,J,LF) AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF)) 20 CONTINUE 10 CONTINUE DO 30 J=1,2 POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X)) POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J) XQPOM(J)=E(J)*POM1+POM2 30 CONTINUE C ------- QUARK DISTRIBUTIONS ---------- HWSDGQ=0 IF (NFL.EQ.3) THEN IF (NCH.EQ.2) THEN HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1)) ELSEIF(NCH.EQ.1) THEN HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1)) ENDIF F2=2.0/9.0*XQPOM(2)+XQPOM(1) ELSEIF (NFL.EQ.4) THEN IF (NCH.EQ.2) THEN HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1)) ELSEIF(NCH.EQ.1) THEN HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1)) ENDIF F2=5.0/18.0*XQPOM(2)+XQPOM(1) ELSEIF (NFL.EQ.5) THEN IF (NCH.EQ.2) THEN HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1)) ELSEIF(NCH.EQ.1) THEN HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1)) ENDIF F2=11.0/45.0*XQPOM(2)+XQPOM(1) ENDIF HWSDGQ=HWSDGQ/137. END CDECK ID>, HWSFBR. *CMZ :- -15/07/92 14.08.45 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z) C----------------------------------------------------------------------- C FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD C EVOLUTION AT ENERGY FRACTION X AND SCALE QQ C C FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON C C IW,IW1,IW2 ARE COLOUR CONNECTION WORDS C C ID1.LT.0 ON RETURN MEANS NO PHASE SPACE C ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV, & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ, & PVAL,EY,DIST(13),PROB(13,100),PPHO INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL ID1=-1 QP=HWBVMC(ID) WQG=1.-QG/QQ WQV=1.-QV/QQ WQP=1.-QP/QQ XQV=X/WQV NONV=.NOT.HWSVAL(ID) NONF=.NOT.FORCED IF (ID.EQ.13) THEN ZMIN=X IF (NONF) THEN ZMAX=WQG ELSE ZMAX=WQV ENDIF ELSE IF (NONV) THEN ZMIN=XQV IF (NONF) THEN ZMAX=WQG ELSE ZMAX=WQP ENDIF ELSE ZMIN=X ZMAX=MAX(WQG,WQP) ENDIF ENDIF IF (ZMIN.GE.ZMAX) RETURN ID1=0 C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z)) YMIN=LOG(ZMIN/(1.-ZMIN)) YMAX=LOG(ZMAX/(1.-ZMAX)) DELY=YMAX-YMIN NZ=MIN(INT(ZBINM*DELY)+1,NZBIN) DELY=(YMAX-YMIN)/FLOAT(NZ) YY=YMIN+0.5*DELY PSUM=0. IDHAD=IDHW(INHAD) C---SET UP TABLES FOR CHOOSING BRANCHING DO 40 IZ=1,NZ EZ=EXP(YY) WR=1.+EZ ZR=WR/EZ WZ=1./WR ZZ=WZ*EZ AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG)) CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD) IF (ID.NE.13) THEN C---SPLITTING INTO QUARK DO 10 IP=1,ID-1 10 PROB(IP,IZ)=PSUM IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR DO 20 IP=ID,12 20 PROB(IP,IZ)=PSUM PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ) PROB(13,IZ)=PSUM ELSE C---SPLITTING INTO GLUON DO 30 IP=1,12 PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR 30 PROB(IP,IZ)=PSUM IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ) PROB(13,IZ)=PSUM ENDIF 40 YY=YY+DELY 50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13 IF (PHOTPR) THEN C---ALLOW ANOMALOUS PHOTON SPLITTING PPHO=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2) & *ICHRG(ID)**2/9D0 IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN C---ANOMALOUS PHOTON SPLITTING OCCURRED ID1=59 RETURN ENDIF ENDIF IF (PSUM.LE.ZERO) RETURN C---CHOOSE Z PVAL=PSUM*HWRGEN(0) DO 60 IZ=1,NZ IF (PROB(13,IZ).GT.PVAL) GOTO 70 60 CONTINUE IZ=NZ 70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1))) ZZ=EY/(1.+EY) C---CHOOSE BRANCHING DO 80 IP=1,13 IF (PROB(IP,IZ).GT.PVAL) GOTO 90 80 CONTINUE IP=13 C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT) 90 CONTINUE IF (ID.NE.13) THEN IF (IP.EQ.ID) THEN IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN IF (PHOTPR) GOTO 50 RETURN ENDIF ELSE IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN IF (PHOTPR) GOTO 50 RETURN ENDIF ENDIF ELSE IF (IP.EQ.ID) THEN IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN ELSEIF (.NOT.HWSVAL(IP)) THEN WQN=1.-HWBVMC(IP)/QQ IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN ENDIF ENDIF C---EVERYTHING OK: LABEL NEW BRANCHES Z=ZZ ID1=IP IW1=IW*2 IW2=IW1+1 IF (ID.LE.6) THEN IF (ID1.EQ.13) THEN ID2=ID+6 ELSE ID2=13 IW2=IW1 ENDIF ELSE IF (ID.NE.13) THEN IF (ID1.EQ.13) THEN ID2=ID-6 IW2=IW1 ELSE ID2=13 ENDIF ELSE ID2=ID1 IF (ID1.EQ.13) THEN IF (HWRLOG(HALF)) IW2=IW1 ELSE IF (ID1.GT.6) THEN IW2=IW1 END IF END IF IF (IW2.EQ.IW1) IW1=IW1+1 END CDECK ID>, HWSFUN. *CMZ :- -02/05/91 11.30.51 by Federico Carminati *-- Author : Miscellaneous, combined by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWSFUN(XIN,SCALE,IDHAD,NSET,DIST,IBEAM) C----------------------------------------------------------------------- C NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE) C C IDHAD = TYPE OF HADRON: C 73=P 91=PBAR 75=N 93=NBAR 38=PI+ 30=PI- 59=PHOTON C C NEW SPECIAL CODES: C 71=`REMNANT PHOTON' 72=`REMNANT NUCLEON' C C NSET = STRUCTURE FUNCTION SET C = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE) C = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY) C = 5 FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606) C C FOR PHOTON DREES+GRASSIE IS USED C C N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS C IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND C SET=MODPDF(IBEAM) IS USED. FOR COMPATABILITY WITH VERSIONS 3 C AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE' C NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE C REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET C C IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC) C C IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW C C FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE C SUPPRESSED BY LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2)) C L = -------------------------------------- , C LOG((Q**2+PHOMAS**2)/( PHOMAS**2)) C WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2, C WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON C C DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N) C + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-) C WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER C WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV C DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991) C PION NOT RELIABLE ABOVE SCALE = 50 GEV C C EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG, C REV. MOD. PHYS. 56 (1984) 579 C REVISED AS IN REV. MOD. PHYS. 58 (1986) 1065 C RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1 C C DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451 C MODIFIED IN M.DREES & C.S.KIM, DESY 91-039 C AND C.S.KIM, DTP/91/16 FOR HEAVY QUARKS C C FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR C CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN C----------------------------------------------------------------------- C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T, & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM, & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5), & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2), & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2) DOUBLE PRECISION XIN,PDFFAC REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM, & XPVMD,XPANL,XPANH,XPBEH,XPDIR COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), & XPDIR(-6:6) LOGICAL PDFWRX(2,2),PDFWRQ(2,2) DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL, & MPDF,IHAD,ISET,IOP1,IOP2,IP2 CHARACTER*20 PARM(20) CHARACTER*20 PARMSAVE DOUBLE PRECISION VALSAVE COMMON/HWSFSA/PARMSAVE COMMON/HWSFSB/VALSAVE EXTERNAL HWSGAM,HWSDGG,HWSDGQ SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX SAVE PDFWRX,PDFWRQ,B,BB,NEHLQ,CEHLQ,TBMIN,TTMIN,DMIN,Q0,QL DATA PDFWRX,PDFWRQ/8*.TRUE./ DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/ &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0, &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0, &6*0.D0,1.D0, &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0, &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0, &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0, &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0, &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0, &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0, &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0, &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0, &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0, &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0, &0.D0,15.261D0,-10.085D0/ DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/ &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0, &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0, &6*0.D0,1.D0,0.D0, &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0, &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0, &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0, &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0, &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0, &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0, &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0, &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0, &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0, &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0, &0.D0,-.59649D0,.12611D0/ DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/ &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0, &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0, &0.003671D0,5.0D0,0.8673D0,0.04747D0, &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0, &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0, &9.433D0, &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0, &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0, &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/ DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/ &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0, &0.01451D0,27*0.D0, &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0, &-2.474D0,1.575D0, &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0, &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0, &0.2424D0, &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0, &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0, &-0.2550D0, &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/ C---COEFFTS FOR NEW OWENS 1.1 SET DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0, &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0, &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0, &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0, &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0, &.909D0,-.4023D0,.006305D0,0.D0, &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0, &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0, &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0, &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0, &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0, &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0, &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0, &-.1668D0, &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0, &-.8411D0, &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/ C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION C...POWERS OF 1-X IN DIFFERENT CASES DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/ C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/ 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04, 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03, 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03, 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03, 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03, 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04, 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04, 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03, 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04, 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04, 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05, 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/ DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/ 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04, 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03, 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03, 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03, 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03, 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04, 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04, 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03, 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04, 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04, 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05, 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/ C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/ 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04, 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03, 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03, 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03, 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04, 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04, 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04, 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03, 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04, 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04, 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05, 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/ DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/ 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04, 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03, 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03, 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03, 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04, 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04, 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04, 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03, 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04, 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04, 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05, 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/ C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/ 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04, 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03, 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05, 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04, 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04, 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05, 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04, 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03, 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04, 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05, 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00, 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/ DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/ 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04, 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03, 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04, 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04, 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04, 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04, 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03, 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03, 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04, 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05, 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05, 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/ C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02, 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02, 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02, 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03, 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04, 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03, 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02, 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02, 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02, 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03, 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03, 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/ DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/ 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02, 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02, 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02, 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02, 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02, 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02, 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02, 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01, 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02, 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03, 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03, 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/ C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/ 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04, 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03, 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04, 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04, 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04, 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05, 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04, 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03, 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04, 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05, 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00, 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/ DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/ 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04, 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03, 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04, 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04, 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04, 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04, 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03, 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03, 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04, 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05, 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05, 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/ C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03, 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03, 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04, 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05, 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05, 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05, 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04, 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03, 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04, 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04, 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05, 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/ 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03, 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03, 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04, 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05, 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05, 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05, 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03, 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03, 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04, 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04, 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05, 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/ C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03, 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04, 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04, 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05, 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05, 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05, 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03, 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03, 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04, 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05, 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05, 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/ 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03, 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04, 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04, 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05, 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00, 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05, 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03, 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03, 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04, 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05, 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05, 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/ C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/ 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04, 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04, 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04, 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00, 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05, 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03, 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03, 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04, 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05, 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00, 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/ 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04, 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04, 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04, 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00, 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05, 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03, 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03, 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04, 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05, 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00, 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/ DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/ DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/ DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0, & .4D0,.2D0,.29D0,.177D0/ C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0 X=MAX(XIN,PDFX0) IF (X.LE.ZERO) THEN CALL HWWARN('HWSFUN',100) GOTO 999 ENDIF XMWN=ONE-X IF (XMWN.LE.ZERO) THEN DO 1 I=1,13 DIST(I)=0 1 CONTINUE RETURN ENDIF C---FREEZE THE SCALE IF REQUIRED SCALEF=SCALE IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC) C---CHECK IF PDFLIB REQUESTED IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN MPDF=MODPDF(IBEAM) ELSE MPDF=-1 ENDIF QSCA=ABS(SCALEF) IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN IF (MPDF.GE.0) THEN C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS PARM(1)=AUTPDF(IBEAM) VAL(1)=FLOAT(MPDF) C---FIX TO CALL SCHULER-SJOSTRAND CODE IF (AUTPDF(IBEAM).EQ.'SaSph') THEN XSP=SNGL(X) IF ( XSP.LE.ZERO) THEN CALL HWWARN('HWSFUN',102) GOTO 999 ENDIF IF (ONE-XSP.LE.ZERO) THEN CALL HWWARN('HWSFUN',103) GOTO 999 ENDIF Q2=SNGL(QSCA**2) ISET=MOD(MODPDF(IBEAM),10) IOP1=MOD(MODPDF(IBEAM)/10,2) IOP2=MOD(MODPDF(IBEAM)/20,2) IP2=MODPDF(IBEAM)/100 IF (IOP2.EQ.0) THEN P2=0. ELSE IHAD=IBEAM IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) P2=SNGL(PHEP(5,IHAD)**2) ENDIF CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA) IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN DO 5 I=-6,6 5 XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I) ENDIF UPV=XPGA(2) DNV=XPGA(1) USEA=XPGA(2) DSEA=XPGA(1) STR=XPGA(3) CHM=XPGA(4) BTM=XPGA(5) TOP=XPGA(6) GLU=XPGA(0) ELSE IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN PARMSAVE=PARM(1) VALSAVE=VAL(1) CALL PDFSET(PARM,VAL) ENDIF IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR. & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN CALL HWWARN('HWSFUN',2) WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X, & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE. IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE. ENDIF IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR. & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN CALL HWWARN('HWSFUN',3) WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA, & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX) WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE. IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE. ENDIF CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU) ENDIF DIST(1)=DSEA DIST(2)=USEA DIST(7)=DSEA DIST(8)=USEA ELSE XSP=SNGL(X) IF ( XSP.LE.ZERO) THEN CALL HWWARN('HWSFUN',102) GOTO 999 ENDIF IF (ONE-XSP.LE.ZERO) THEN CALL HWWARN('HWSFUN',103) GOTO 999 ENDIF Q2=SNGL(SCALEF**2) W2=Q2*(1-XSP)/XSP EMC2=SNGL(4*RMASS(4)**2) EMB2=SNGL(4*RMASS(5)**2) ALAM2=0.160 NFL=3 IF (Q2.GT.50.) NFL=4 IF (Q2.GT.500.) NFL=5 STR=HWSDGQ(XSP,Q2,NFL,1) CHM=HWSDGQ(XSP,Q2,NFL,2) GLU=HWSDGG(XSP,Q2,NFL) DIST(1)=STR DIST(2)=CHM DIST(7)=STR DIST(8)=CHM IF (W2.GT.EMB2) THEN BTM=STR IF (W2*ALAM2.LT.Q2*EMB2) & BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2) ELSE BTM=0. ENDIF IF (W2.GT.EMC2) THEN IF (W2*ALAM2.LT.Q2*EMC2) & CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2) ELSE CHM=0. ENDIF TOP=0. ENDIF C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN IHAD=IBEAM IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) IF (IDHW(IHAD).EQ.59) THEN FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/ $ LOG((QSCA**2+PHOMAS**2)/( PHOMAS**2)) IF (FAC.LT.ZERO) FAC=ZERO DIST(1)=DIST(1)*FAC DIST(2)=DIST(2)*FAC DIST(7)=DIST(7)*FAC DIST(8)=DIST(8)*FAC STR=STR*FAC CHM=CHM*FAC BTM=BTM*FAC TOP=TOP*FAC GLU=GLU*FAC**2 ELSE CALL HWWARN('HWSFUN',1) ENDIF ENDIF GOTO 900 ENDIF IF (MPDF.GE.0) THEN C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS PARM(1)=AUTPDF(IBEAM) VAL(1)=FLOAT(MPDF) IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN PARMSAVE=PARM(1) VALSAVE=VAL(1) CALL PDFSET(PARM,VAL) ENDIF IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR. & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN CALL HWWARN('HWSFUN',4) WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X, & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE. IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE. ENDIF IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR. & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN CALL HWWARN('HWSFUN',5) WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA, & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX) WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE. IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE. ENDIF CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU) C--new MRST98 LO PDF's ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU) TOP=ZERO ELSE IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400) IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET) IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN C---INITIALIZE QOLD=QSCA IOLD=IDHAD NOLD=NSET SS=LOG(QSCA/QL(NSET)) SMIN=LOG(Q0(NSET)/QL(NSET)) IF (NSET.LT.3.OR.NSET.EQ.5) THEN S=LOG(SS/SMIN) ELSE T=2.*SS TMIN=2.*SMIN TMAX=2.*LOG(1.E4/QL(NSET)) ENDIF IF (IDHAD.GE.72) THEN IF (NSET.LT.3) THEN IP=NSET DO 10 I=1,5 DO 10 J=1,6 10 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP)) DO 20 K=1,2 AA=ONE+A(2,K)+A(3,K) 20 G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K)) & *HWSGAM(ONE+A(3,K))) ELSEIF (NSET.EQ.5) THEN DO 21 I=1,5 DO 21 J=1,6 21 A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I))) DO 22 K=1,2 AA=ONE+A(2,K)+A(3,K) 22 G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+ & (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K)) & *HWSGAM(ONE+A(3,K))) ELSE IP=NSET-2 VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN))) WT=VT*VT C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION TT(1)=1. TT(2)=VT TT(3)= 2.*WT- 1. TT(4)= (4.*WT- 3.)*VT TT(5)= (8.*WT- 8.)*WT+1. TT(6)=((16.*WT-20.)*WT+5.)*VT ENDIF ELSEIF (NSET.LT.3) THEN IP=NSET+2 DO 30 I=1,5 DO 30 J=1,6 30 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP)) AA=ONE+A(2,1)+A(3,1) G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1))) G(2)=0. ENDIF ENDIF C IF (NSET.LT.3.OR.NSET.EQ.5) THEN DO 50 I=1,5 50 F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X* & (A(4,I)+X*(A(5,I) + X*A(6,I)))) F(1)=F(1)*G(1) F(2)=F(2)*G(2) UPV=F(1)-F(2) DNV=F(2) SEA=F(3)/6. STR=SEA CHM=F(4) BTM=ZERO TOP=ZERO GLU=F(5) ELSE IF (X.NE.XOLD) THEN XOLD=X IF (X.GT.0.1) THEN NX=1 VX=(2.*X-1.1)/0.9 ELSE NX=2 VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776) ENDIF WX=VX*VX TX(1)=1. TX(2)=VX TX(3)= 2.*WX- 1. TX(4)= (4.*WX- 3.)*VX TX(5)= (8.*WX- 8.)*WX+1. TX(6)=((16.*WX-20.)*WX+5.)*VX ENDIF C...CALCULATE STRUCTURE FUNCTIONS DO 120 IFL=1,6 XQSUM=0. DO 110 IT=1,6 DO 110 IX=1,6 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT) 120 XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP) UPV=XQ(1) DNV=XQ(2) STR=XQ(5) CHM=XQ(6) SEA=XQ(3) GLU=XQ(4) C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS) IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN BTM=0. ELSE VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP)))) WT=VT*VT TB(1)=1. TB(2)=VT TB(3)= 2.*WT- 1. TB(4)= (4.*WT- 3.)*VT TB(5)= (8.*WT- 8.)*WT+1. TB(6)=((16.*WT-20.)*WT+5.)*VT XQSUM=0. DO 130 IT=1,6 DO 130 IX=1,6 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT) BTM=XQSUM*XMWN**NEHLQ(7,IP) ENDIF C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS) TPMIN=TTMIN(IP)+TMTOP C---TMTOP=2.*LOG(TOPMAS/30.) TPMAX=TMAX+TMTOP IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN TOP=0. ELSE VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN))) WT=VT*VT TB(1)=1. TB(2)=VT TB(3)= 2.*WT- 1. TB(4)= (4.*WT- 3.)*VT TB(5)= (8.*WT- 8.)*WT+1. TB(6)=((16.*WT-20.)*WT+5.)*VT XQSUM=0. DO 150 IT=1,6 DO 150 IX=1,6 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT) TOP=XQSUM*XMWN**NEHLQ(8,IP) ENDIF ENDIF ENDIF IF (MPDF.LT.0.AND.NSET.LE.5) THEN USEA=SEA DSEA=USEA ENDIF IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN WRITE(6,*) ' THIS SET OF PDFS DOES NOT SUPPORT PIONS' WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB' STOP ENDIF IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN DIST(1)=DSEA+DNV DIST(2)=USEA+UPV DIST(7)=DSEA DIST(8)=USEA ELSEIF (IDHAD.EQ.91) THEN DIST(1)=DSEA DIST(2)=USEA DIST(7)=DSEA+DNV DIST(8)=USEA+UPV ELSEIF (IDHAD.EQ.75) THEN DIST(1)=USEA+UPV DIST(2)=DSEA+DNV DIST(7)=USEA DIST(8)=DSEA ELSEIF (IDHAD.EQ.93) THEN DIST(1)=USEA DIST(2)=DSEA DIST(7)=USEA+UPV DIST(8)=DSEA+DNV ELSEIF (IDHAD.EQ.38) THEN DIST(1)=USEA DIST(2)=USEA+UPV DIST(7)=USEA+UPV DIST(8)=USEA ELSEIF (IDHAD.EQ.30) THEN DIST(1)=USEA+UPV DIST(2)=USEA DIST(7)=USEA DIST(8)=USEA+UPV ELSE PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD CALL HWWARN('HWSFUN',401) ENDIF 900 DIST(3)=STR DIST(4)=CHM DIST(5)=BTM DIST(6)=TOP DIST(9)=STR DIST(10)=CHM DIST(11)=BTM DIST(12)=TOP DIST(13)=GLU DO 901 I=1,13 IF (DIST(I).LT.DMIN) DIST(I)=DMIN 901 CONTINUE C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS, C WHILE MAINTAINING MOMENTUM SUM RULE IF (IDHAD.EQ.72) THEN TOTAL=0 DO 910 I=1,13 TOTAL=TOTAL+DIST(I) 910 CONTINUE DIST(1)=DIST(1)-DNV DIST(2)=DIST(2)-UPV IF (TOTAL.GT.DNV+UPV) THEN DO 920 I=1,13 DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV) 920 CONTINUE ENDIF ENDIF C---IF X HAS BEEN FROZEN USE A POWER LAW IF (XIN.LT.PDFX0) THEN PDFFAC=(XIN/PDFX0)**PDFPOW DO 930 I=1,13 DIST(I)=DIST(I)*PDFFAC 930 CONTINUE ENDIF 999 RETURN END CDECK ID>, HWSGAM. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Adapted by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWSGAM(ZINPUT) C----------------------------------------------------------------------- C Gamma function computed by eq. 6.1.40, Abramowitz. C B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number. C HLNTPI = .5*LOG(2.*PI) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ INTEGER I SAVE B,HLNTPI DATA B/ 1 0.83333333333333333333D-01, -0.27777777777777777778D-02, 1 0.79365079365079365079D-03, -0.59523809523809523810D-03, 1 0.84175084175084175084D-03, -0.19175269175269175269D-02, 1 0.64102564102564102564D-02, -0.29550653594771241830D-01, 1 0.17964437236883057316D0 , -1.3924322169059011164D0 / DATA HLNTPI/0.91893853320467274178D0/ C C Shift argument to large value ( > 20 ) C Z=ZINPUT SHIFT=1. 10 IF (Z.LT.20.D0) THEN SHIFT = SHIFT*Z Z = Z + 1.D0 GOTO 10 ENDIF C C Compute asymptotic formula C G = (Z-.5D0)*LOG(Z) - Z + HLNTPI T = 1.D0/Z RECZSQ = T**2 DO 20 I = 1,10 G = G + B(I)*T T = T*RECZSQ 20 CONTINUE HWSGAM = EXP(G)/SHIFT END CDECK ID>, HWSGEN. *CMZ :- -26/04/91 14.55.45 by Federico Carminati *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWSGEN(GENEX) C----------------------------------------------------------------------- C GENERATES X VALUES (IF GENEX) C EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWBVMC,HWRUNI,X,QL INTEGER I,J LOGICAL GENEX EXTERNAL HWBVMC,HWRUNI IF (GENEX) THEN XX(1)=EXP(HWRUNI(0,ZERO,XLMIN)) XX(2)=XXMIN/XX(1) ENDIF DO 10 I=1,2 J=I IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I) X=XX(I) QL=(1.-X)*EMSCA CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I) DO 10 J=1,13 IF (QL.LT.HWBVMC(J)) DISF(J,I)=0. 10 CONTINUE END CDECK ID>, HWSGQQ. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWSGQQ(QSCA) C----------------------------------------------------------------------- C CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION: C G->Q-QBAR PART OF FORM FACTOR C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG EXTERNAL HWUALF GG=HWUALF(1,QSCA)**(-ONE/BETAF) IF (GG.LT.ONE) GG=ONE IF (QSCA.GT.RMASS(6)) THEN HWSGQQ=GG**6 ELSEIF (QSCA.GT.RMASS(5)) THEN HWSGQQ=GG**5 ELSEIF (QSCA.GT.RMASS(4)) THEN HWSGQQ=GG**4 ELSE HWSGQQ=GG**3 ENDIF END CDECK ID>, HWSMRS. *CMZ :- -26/04/01 10.00.16 by Peter Richardson *-- Author : Dick Roberts, modified by Peter Richardson C----------------------------------------------------------------------- SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU) C----------------------------------------------------------------------- C MRST98 Leading order PDF's central and higher gluon + average C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX, & QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS), & XSAVE,Q2SAVE,XXX,A,B,FAC INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2) PARAMETER(NTENTH=23) SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0 DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/ DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5, & 1d-4,2d-4,4d-4,6d-4,8d-4, & 1d-3,2d-3,4d-3,6d-3,8d-3, & 1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2, & .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0, & .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0, & .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0, & .8d0,.9d0,1d0/ DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1, & 1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2, & 1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4, & 1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6, & 1.8d6,3.2d6,5.6d6,1d7/ DATA N0/3,4,5,9,9,9,9,9/ DATA INIT,WARN/0,0,0/ Q2=Q*Q C--issue warning if x or q out of range IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN CALL HWWARN('HWSMRS',5) WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',Q, & ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX) WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' WARN(1) = 1 ENDIF IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN CALL HWWARN('HWSMRS',4) WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X', & ' OUTSIDE ALLOWED RANGE!' WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X, & ', MINIMUM=',XMIN,', MAXIMUM=',XMAX WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED' WARN(2) = 1 ENDIF C--now the evaluation XSAVE = X Q2SAVE = Q2 C--first the initialisation IF(INIT.NE.0) GOTO 10 DO 15 ML=3,1,-1 DO 20 N=1,NXMRS-1 DO 20 M=1,NQMRS DO 20 I=1,NPMRS c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea IF(ML.LE.2) THEN FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I) ELSE FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/ & (1.0D0-XXMRS(N))**N0(I) ENDIF 20 CONTINUE DO 31 J=1,NTENTH-1 DO 31 I=1,8 IF(I.EQ.5.OR.I.EQ.7) GOTO 31 DO 30 K=1,NQMRS 30 FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K)) & +FMRS(ML,I,NTENTH,K) 31 CONTINUE DO 40 I=1,NPMRS DO 40 M=1,NQMRS 40 FMRS(ML,I,NXMRS,M)=0.0D0 15 CONTINUE DO 32 J=1,NTENTH-1 32 XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH) INIT=1 10 CONTINUE C--check x and q within range of set IF(X.LT.XMIN) X=XMIN IF(X.GT.XMAX) X=XMAX IF(Q2.LT.QSQMIN) Q2=QSQMIN IF(Q2.GT.QSQMAX) Q2=QSQMAX C--find X and Q XXX=X IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH) N = 0 70 N=N+1 IF(XXX.GT.XXMRS(N+1)) GOTO 70 A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N)) M=0 80 M=M+1 IF(Q2.GT.QQ(M+1)) GOTO 80 B=(Q2-QQ(M))/(QQ(M+1)-QQ(M)) DO 60 I=1,NPMRS G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N ,M ) & +(1.0D0-A)* B *FMRS(MODE,I,N ,M+1) & + A *(1.0D0-B)*FMRS(MODE,I,N+1,M ) & + A * B *FMRS(MODE,I,N+1,M+1) IF(N.GE.NTENTH) GOTO 65 IF(I.EQ.5.OR.I.EQ.7) GOTO 65 FAC = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1) G(I) = FAC*10.0d0**(G(I)-FAC) 65 continue G(I)=G(I)*(1.0d0-X)**N0(I) 60 continue UPV = G(1) DNV = G(2) USEA = G(4) DSEA = G(8) STR = G(6) CHM = G(5) GLU = G(3) BOT = G(7) X = XSAVE Q2 = Q2SAVE END CDECK ID>, HWSSPC. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWSSPC C----------------------------------------------------------------------- C REPLACES SPACELIKE PARTONS BY SPECTATORS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5) INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP EXTERNAL HWUSQR IF (IERROR.NE.0) RETURN DO 50 KHEP=1,NHEP IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN IP=ISTHEP(KHEP)-144 JP=IP IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP) IDH=IDHW(JP) IDP=IDHW(KHEP) IF (IDH.NE.IDP) THEN IF (IDH.EQ.59) THEN C---PHOTON CASE IF (IDP.LT.7) THEN IDSPC=IDP+6 ELSEIF (IDP.LT.13) THEN IDSPC=IDP-6 ELSE CALL HWWARN('HWSSPC',100) GOTO 999 ENDIF C---IDENTIFY SPECTATOR C (1) QUARK CASE ELSEIF (IDP.LE.3) THEN DO 10 ISP=1,12 10 IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20 CALL HWWARN('HWSSPC',101) GOTO 999 20 IF (ISP.LE.3) THEN IDSPC=ISP+6 ELSEIF (ISP.LE.9) THEN IDSPC=ISP+105 ELSE IDSPC=ISP ENDIF C---(2) ANTIQUARK CASE ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN IDP=IDP-6 DO 30 ISP=1,12 30 IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40 CALL HWWARN('HWSSPC',103) GOTO 999 40 IF (ISP.LE.3) THEN IDSPC=ISP ELSEIF (ISP.LE.9) THEN IDSPC=ISP+111 ELSE IDSPC=ISP-6 ENDIF C---SPECIAL CASE FOR REMNANT HADRON ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN IF (IDP.EQ.13) THEN IDSPC=IDP ELSE CALL HWWARN('HWSSPC',106) GOTO 999 ENDIF ELSE CALL HWWARN('HWSSPC',105) GOTO 999 ENDIF C---REPLACE PARTON BY SPECTATOR IDHW(KHEP)=IDSPC IDHEP(KHEP)=IDPDG(IDSPC) ISTHEP(KHEP)=146+IP EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP)) EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2 EPAR=PHEP(4,KHEP) CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP)) IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN CALL HWUMAS(PHEP(1,KHEP)) ELSE C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS XPAR=EPAR/PHEP(4,JP) QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP)) PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR & -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR) ENDIF C---CHECK FOR UNPHYSICAL SPECTATOR IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE. C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET IF (QORQQB(IDHW(KHEP))) THEN JHEP=JMOHEP(2,KHEP) ELSEIF (QBORQQ(IDHW(KHEP))) THEN JHEP=JDAHEP(2,KHEP) ELSE JHEP=0 ENDIF IF (JHEP.GT.0) THEN CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL) CALL HWUMAS(PCL) C---IF IT IS NEGATIVE, REJECT IF (PCL(5).LT.ZERO) FROST=.TRUE. ENDIF ENDIF ENDIF 50 CONTINUE 999 RETURN END CDECK ID>, HWSSUD. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWSSUD(I) C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13) INTEGER I,N0,IS,ID EXTERNAL HWSGQQ COMMON/HWTABC/XLAST,N0,IS,ID SAVE DMIN DATA DMIN/1.D-15/ QSCA=QEV(N0+I,IS) CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD) IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA) IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN HWSSUD=SUD(N0+I,IS)/DIST(ID) END CDECK ID>, HWSTAB. *CMZ :- -26/04/91 11.11.56 by Bryan Webber *-- Author : Adapted by Bryan Webber C----------------------------------------------------------------------- FUNCTION HWSTAB(F,AFUN,NN,X,MM) C----------------------------------------------------------------------- C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF C LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A C----------------------------------------------------------------------- IMPLICIT NONE INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20) LOGICAL EXTRA EXTERNAL AFUN SAVE MMAX DATA MMAX/10/ N=NN M=MIN(MM,MMAX,N-1) MPLUS=M+1 IX=0 IY=N+1 IF (AFUN(1).GT.AFUN(N)) GOTO 94 91 MID=(IX+IY)/2 IF (X.GE.AFUN(MID)) GOTO 92 IY=MID GOTO 93 92 IX=MID 93 IF (IY-IX.GT.1) GOTO 91 GOTO 97 94 MID=(IX+IY)/2 IF (X.LE.AFUN(MID)) GOTO 95 IY=MID GOTO 96 95 IX=MID 96 IF (IY-IX.GT.1) GOTO 94 97 NPTS=M+2-MOD(M,2) IP=0 L=0 GOTO 99 98 L=-L IF (L.GE.0) L=L+1 99 ISUB=IX+L IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100 NPTS=MPLUS GOTO 101 100 IP=IP+1 T(IP)=AFUN(ISUB) D(IP)=F(ISUB) 101 IF (IP.LT.NPTS) GOTO 98 EXTRA=NPTS.NE.MPLUS DO 14 L=1,M IF (.NOT.EXTRA) GOTO 12 ISUB=MPLUS-L D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB)) 12 I=MPLUS DO 13 J=L,M ISUB=I-L D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB)) I=I-1 13 CONTINUE 14 CONTINUE SUM=D(MPLUS) IF (EXTRA) SUM=0.5*(SUM+D(M+2)) J=M DO 15 L=1,M SUM=D(J)+(X-T(J))*SUM J=J-1 15 CONTINUE HWSTAB=SUM END CDECK ID>, HWSVAL. *CMZ :- -26/04/91 10.18.58 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWSVAL(ID) C----------------------------------------------------------------------- C TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER ID,IDHAD LOGICAL HWSVAL HWSVAL=.FALSE. IDHAD=IDHW(INHAD) IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE. ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE. ELSEIF (IDHAD.EQ.30) THEN IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE. ELSEIF (IDHAD.EQ.38) THEN IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE. ELSEIF (IDHAD.EQ.59) THEN IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE. ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN IF (ID.EQ.13) HWSVAL=.TRUE. ELSE CALL HWWARN('HWSVAL',100) ENDIF END CDECK ID>, HWUAEM. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWUAEM(Q2) C----------------------------------------------------------------------- C Running electromagnetic coupling constant. C See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129 C Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3, & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X LOGICAL FIRST EXTERNAL HWUAER SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2 PARAMETER (EPS=1.D-6) SAVE A1,B1,C1,A2,B2,C2,A3,B3,C3,A4,B4,C4 DATA A1,B1,C1/0.0 D0,0.00835D0,1.000D0/ DATA A2,B2,C2/0.0 D0,0.00238D0,3.927D0/ DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/ DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/ DATA FIRST/.TRUE./ IF (FIRST) THEN AEMPI=ALPHEM/(THREE*PIFAC) EEL2 =RMASS(121)**2 EMU2 =RMASS(123)**2 ETAU2=RMASS(125)**2 ETOP2=RMASS(6)**2 FIRST=.FALSE. ENDIF IF (ABS(Q2).LT.EPS) THEN HWUAEM=ALPHEM RETURN ENDIF C Leptonic component REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2)) C Hadronic component from light quarks X=ABS(Q2) IF (X.LT.9.D-2) THEN REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X) ELSEIF (X.LT.9.D0) THEN REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X) ELSEIF (X.LT.1.D4) THEN REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X) ELSE REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X) ENDIF C Top Contribution REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2) HWUAEM=ALPHEM/(ONE-REPIGG) END CDECK ID>, HWUAER. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWUAER(R) C----------------------------------------------------------------------- C Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0, & FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0) PARAMETER (RMAX=1.D6) IF (ABS(R).LT.1.D-3) THEN C Use assymptotic formula HWUAER=-FVTHR-LOG(ABS(R)) ELSEIF (ABS(R).GT.RMAX) THEN HWUAER=ZERO ELSEIF (FOUR*R.GT.ONE) THEN BETA=SQRT(FOUR*R-ONE) HWUAER=THIRD & -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R))) ELSE BETA=SQRT(ONE-FOUR*R) HWUAER=THIRD & -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE)))) ENDIF END CDECK ID>, HWUALF. *CMZ :- -15/07/92 14.08.45 by Mike Seymour *-- Author : Bryan Webber C----------------------------------------------------------------------- FUNCTION HWUALF(IOPT,SCALE) C----------------------------------------------------------------------- C STRONG COUPLING CONSTANT C IOPT.EQ.0 INITIALIZES C .EQ.1 TWO-LOOP, FLAVOUR THRESHOLDS C .EQ.2 RATIO OF ABOVE TO ONE-LOOP C WITH 5-FLAVOUR BETA, LAMBDA=QCDL3 C .EQ.3 ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3 C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35, & C45,C65,D35,RHO,RAT,RLF,DRH,EPS INTEGER IOPT,ITN SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35 SAVE EPS DATA EPS/1.D-6/ IF (IOPT.EQ.0) THEN C---INITIALIZE CONSTANTS CAFAC=FLOAT(NCOLO) CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC) B3=((11.*CAFAC)- 6.)/(12.*PIFAC) B4=((11.*CAFAC)- 8.)/(12.*PIFAC) B5=((11.*CAFAC)-10.)/(12.*PIFAC) B6=((11.*CAFAC)-12.)/(12.*PIFAC) BETAF=6.*PIFAC*B5 C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2 C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2 C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2 C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2 KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9. C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z C---QCDL5 IS 5-FLAVOUR LAMBDA-MC QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0) C---COMPUTE THRESHOLD MATCHING RHO=2.*LOG(RMASS(6)/QCDL5) RAT=LOG(RHO)/RHO C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO RHO=2.*LOG(RMASS(5)/QCDL5) RAT=LOG(RHO)/RHO C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO RHO=2.*LOG(RMASS(4)/QCDL5) RAT=LOG(RHO)/RHO C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45 C---FIND QCDL3 D35=-1./(B3*C35) DO 10 ITN=1,100 RAT=LOG(D35)/D35 RLF=B3*D35/(1.-C3*RAT) DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2) D35=D35-DRH IF (ABS(DRH).LT.EPS*D35) GOTO 20 10 CONTINUE 20 QCDL3=QCDL5*EXP(0.5*D35) ENDIF IF (SCALE.LE.QCDL5) THEN CALL HWWARN('HWUALF',51) GOTO 999 ENDIF RHO=2.*LOG(SCALE/QCDL5) IF (IOPT.EQ.3) THEN IF (RHO.LE.D35) THEN CALL HWWARN('HWUALF',52) GOTO 999 ENDIF HWUALF=1./(B5*(RHO-D35)) RETURN ENDIF RAT=LOG(RHO)/RHO IF (SCALE.GT.RMASS(6)) THEN RLF=B6*RHO/(1.-C6*RAT)+C65 ELSEIF (SCALE.GT.RMASS(5)) THEN RLF=B5*RHO/(1.-C5*RAT) ELSEIF (SCALE.GT.RMASS(4)) THEN RLF=B4*RHO/(1.-C4*RAT)+C45 ELSE RLF=B3*RHO/(1.-C3*RAT)+C35 ENDIF IF (RLF.LE.ZERO) THEN CALL HWWARN('HWUALF',53) GOTO 999 ENDIF IF (IOPT.EQ.1) THEN HWUALF=1./RLF ELSE HWUALF=B5*(RHO-D35)/RLF IF (HWUALF.GT.ONE) THEN CALL HWWARN('HWUALF',54) GOTO 999 ENDIF ENDIF RETURN 999 HWUALF=ZERO END CDECK ID>, HWUANT. *CMZ :- -27/07/99 13.33.03 by Mike Seymour *-- Author : Ian Knowles C----------------------------------------------------------------------- FUNCTION HWUANT(IPART) C----------------------------------------------------------------------- C Returns the antiparticle of IPART; uses HERWIG numbering C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR CHARACTER*8 CDUM OLDERR=IERROR IPDG=IDPDG(IPART) IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR. & IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR. & IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR. & IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR. & IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR. & IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR. & (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND. & MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND. & MOD(IPDG/10,10).NE.0)) THEN C Self-conjugate boson IANTI=IPART ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN C Fourth generation (anti-)quarks IANTI=IPART+6 ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN IANTI=IPART-6 ELSE C Non-zero charge particle CALL HWUIDT(1,-IPDG,IANTI,CDUM) ENDIF IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART) 10 FORMAT(1X,A8,' has no antiparticle'/) HWUANT=IANTI IERROR=OLDERR END CDECK ID>, HWUATS. *CMZ :- -07/07/99 17.42.00 by Kosuke Odagiri *-- Author : Kosuke Odagiri C----------------------------------------------------------------------- SUBROUTINE HWUATS C----------------------------------------------------------------------- C Replaces all &'s in TXNAME by backslashes C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J,L CHARACTER*1 Z Z=CHAR(92) L=LEN(TXNAME(1,1)) DO 1 I=0,NMXRES DO 2 J=1,L IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z 2 CONTINUE 1 CONTINUE END CDECK ID>, HWUBPR. *CMZ :- -26/04/91 10.18.58 by Bryan Webber *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWUBPR C----------------------------------------------------------------------- C PRINTS OUT DATA ON PARTON SHOWER C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' INTEGER I,J IF (PRVTX) THEN WRITE(6,10) INHAD,XFACT 10 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3, & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA', & ' ADA P-X P-Y P-Z ENERGY MASS', & ' V-X V-Y V-Z V-C*T') DO 20 J=1,NPAR 20 WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J), & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4) 30 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4) ELSE WRITE(6,40) INHAD,XFACT 40 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3, & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA', & ' ADA P-X P-Y P-Z ENERGY MASS') DO 50 J=1,NPAR 50 WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J), & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5) 60 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2) ENDIF END CDECK ID>, HWUBST. *CMZ :- -18/10/93 10.21.56 by Mike Seymour *-- Author : Mike Seymour C----------------------------------------------------------------------- SUBROUTINE HWUBST(IOPT) C----------------------------------------------------------------------- C BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS C CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION PBOOST(5),RBOOST(3,3) INTEGER IOPT,IHEP,BOOSTD,IHAD SAVE BOOSTD,PBOOST,RBOOST DATA BOOSTD/-1/ IF (IERROR.NE.0) RETURN IF (IOPT.EQ.1) THEN C---FIND FIRST INCOMING HADRON IHAD=1 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD) C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND. & PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN C---FIND AND APPLY BOOST CALL HWVEQU(5,PHEP(1,3),PBOOST) DO 100 IHEP=1,NHEP CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP)) 100 CONTINUE CALL HWULOF(PBOOST,VTXPIP,VTXPIP) C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST) DO 110 IHEP=1,NHEP CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP)) 110 CONTINUE CALL HWUROF(RBOOST,VTXPIP,VTXPIP) C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED C (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT) BOOSTD=NWGTS+1 ELSEIF (IOPT.EQ.0) THEN IF (BOOSTD.NE.NWGTS) RETURN C---UNDO ROTATION AND BOOST DO 200 IHEP=1,NHEP CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP)) CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP)) CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP)) 200 CONTINUE ENDIF END CDECK ID>, HWUCFF. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Bryan Webber and Ian Knowles C----------------------------------------------------------------------- SUBROUTINE HWUCFF(I,J,QSQ,CLF) C----------------------------------------------------------------------- C Calculates basic coefficients in cross-section formula for C ffbar --> f'fbar', at virtuality QSQ, I labels initial, J C labels final fermion; type given as: C I,J= 1- 6: d,u,s,c,b,t C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW, & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2, & XIM2,XSQ2,XRE12,XIM12 INTEGER I,J C Longitudinal Polarisation factors POL1=1.-EPOLN(3)*PPOLN(3) POL2=PPOLN(3)-EPOLN(3) C Standard model couplings QIF=QFCH(I)*QFCH(J) VI=VFCH(I,1) AI=AFCH(I,1) VF=VFCH(J,1) AF=AFCH(J,1) PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI C Z propagator factors DQM=QSQ-RMASS(200)**2 PMW=GAMZ*RMASS(200) DEN=QSQ/(DQM**2+PMW**2) XRE=DEN*DQM XIM=DEN*PMW XSQ=DEN*QSQ C Calculate cross-section coefficients CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF & +XSQ*PG*(VF**2+AF**2) CLF(2)=CLF(1)-2.*XSQ*PG*AF**2 CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF & +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF) IF (TPOL) THEN CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2) CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2 CLF(6)=XIM*2.*QIF*AI*VF CLF(7)=CLF(6) ENDIF IF (ZPRIME) THEN C Z' couplings: VI2=VFCH(I,2) AI2=AFCH(I,2) VF2=VFCH(J,2) AF2=AFCH(J,2) PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2 PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2) C Z' propagator factors DQM2=QSQ-RMASS(202)**2 PMW2=RMASS(202)*GAMZP DEN2=QSQ/(DQM2**2+PMW2**2) XRE2=DEN2*DQM2 XIM2=DEN2*PMW2 XSQ2=DEN2*QSQ XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2) XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW) C Additional contributions to cross-section coefficients CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2 & +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2) CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2) CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2 & +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2 & +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2)) & *(VF*VF2+AF*AF2)) IF (TPOL) THEN CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2 & +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2) & +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2) CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2 & +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2) CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2 & -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2)) CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2 ENDIF ENDIF END CDECK ID>, HWUCI2. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWUCI2(A,B,Y0) C----------------------------------------------------------------------- C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4 DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF EXTERNAL HWULI2 COMMON/SMALL/EPSI PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0) IF(B.EQ.ZERO)THEN HWUCI2=DCMPLX(ZERO,ZERO) ELSE Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B)) Y2=ONE-Y1 Z1=Y0/(Y0-Y1) Z2=(Y0-ONE)/(Y0-Y1) Z3=Y0/(Y0-Y2) Z4=(Y0-ONE)/(Y0-Y2) HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4) ENDIF END CDECK ID>, HWUDAT. *CMZ :- -26/04/91 10.18.58 by Bryan Webber *-- Author : Ian Knowles & Bryan Webber C----------------------------------------------------------------------- BLOCK DATA HWUDAT C----------------------------------------------------------------------- C Loads common blocks with particle properties data; for particle I: C RNAME(I) = Name C IDPDG(I) = PDG code C IFLAV(I) = HERWIG flavour code C ICHRG(I) = Electric charge (|e-|) (*3 for (di-)quarks) C RMASS(I) = Mass (GeV/c^2) C RLTIM(I) = Proper life time (s) C RSPIN(I) = Spin C QORQQB(I) = .TRUE. if it is a quark or an antidiquark C QBORQQ(I) = .TRUE. if it is an antiquark or a diquark C And stores the particle decay tables: call HWUDPR to print them C----------------------------------------------------------------------- INCLUDE 'HERWIG65.INC' COMMON/HWSEED/ISEED(2) INTEGER ISEED INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF c PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458) c PARAMETER (NREST=NMXRES-120) c DATA NRES/458/ PARAMETER (NLAST=458,NNEXT=NLAST+1,NLEFT=NMXRES-NLAST) PARAMETER (NREST=NMXRES-120) DATA NRES/NLAST/ C Don't forget to change the three occurances above as well DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/ DATA ISEED/12345,67890/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=0,16)/ & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'DQRK ', 1, 0,-1,0.3200D0,0.000D+00,0.5D0, & 'UQRK ', 2, 0,+2,0.3200D0,0.000D+00,0.5D0, & 'SQRK ', 3, 0,-1,0.5000D0,0.000D+00,0.5D0, & 'CQRK ', 4, 0,+2,1.5500D0,0.000D+00,0.5D0, & 'BQRK ', 5, 0,-1,4.9500D0,0.000D+00,0.5D0, & 'TQRK ', 6, 0,+2,174.30D0,4.000D-25,0.5D0, & 'DBAR ', -1, 0,+1,0.3200D0,0.000D+00,0.5D0, & 'UBAR ', -2, 0,-2,0.3200D0,0.000D+00,0.5D0, & 'SBAR ', -3, 0,+1,0.5000D0,0.000D+00,0.5D0, & 'CBAR ', -4, 0,-2,1.5500D0,0.000D+00,0.5D0, & 'BBAR ', -5, 0,+1,4.9500D0,0.000D+00,0.5D0, & 'TBAR ', -6, 0,-2,174.30D0,4.000D-25,0.5D0, & 'GLUON ', 21, 0, 0,0.7500D0,0.000D+00,1.0D0, & 'CMF ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'HARD ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'SOFT ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=17,32)/ & 'CONE ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'HEAVY ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'CLUS ', 91, 0, 0,0.0000D0,0.000D+00,0.0D0, & '**** ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'PI0 ', 111, 11, 0,.13498D0,8.400D-17,0.0D0, & 'ETA ', 221, 33, 0,.54730D0,0.000D+00,0.0D0, & 'RHO0 ', 113, 11, 0,.77000D0,0.000D+00,1.0D0, & 'OMEGA ', 223, 33, 0,.78194D0,0.000D+00,1.0D0, & 'ETAP ', 331, 33, 0,.95778D0,0.000D+00,0.0D0, & 'F_2 ', 225, 33, 0,1.2750D0,0.000D+00,2.0D0, & 'A_10 ', 20113, 11, 0,1.2300D0,0.000D+00,1.0D0, & 'FL_1 ', 20223, 33, 0,1.2819D0,0.000D+00,1.0D0, & 'A_20 ', 115, 11, 0,1.3181D0,0.000D+00,2.0D0, & 'PI- ', -211, 12,-1,.13957D0,2.603D-08,0.0D0, & 'RHO- ', -213, 12,-1,.77000D0,0.000D+00,1.0D0, & 'A_1- ', -20213, 12,-1,1.2300D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=33,48)/ & 'A_2- ', -215, 12,-1,1.3181D0,0.000D+00,2.0D0, & 'K- ', -321, 32,-1,.49368D0,1.237D-08,0.0D0, & 'K*- ', -323, 32,-1,.89166D0,0.000D+00,1.0D0, & 'KH_1- ', -20323, 32,-1,1.8500D0,0.000D+00,1.0D0, & 'K*_2- ', -325, 32,-1,1.4256D0,0.000D+00,2.0D0, & 'PI+ ', 211, 21,+1,.13957D0,2.603D-08,0.0D0, & 'RHO+ ', 213, 21,+1,.77000D0,0.000D+00,1.0D0, & 'A_1+ ', 20213, 21,+1,1.2300D0,0.000D+00,1.0D0, & 'A_2+ ', 215, 21,+1,1.3181D0,0.000D+00,2.0D0, & 'KBAR0 ', -311, 31, 0,.49767D0,0.000D+00,0.0D0, & 'K*BAR0 ', -313, 31, 0,.89610D0,0.000D+00,1.0D0, & 'KH_1BAR0', -20313, 31, 0,1.8500D0,0.000D+00,1.0D0, & 'K*_2BAR0', -315, 31, 0,1.4324D0,0.000D+00,2.0D0, & 'K+ ', 321, 23,+1,.49368D0,1.237D-08,0.0D0, & 'K*+ ', 323, 23,+1,.89166D0,0.000D+00,1.0D0, & 'KH_1+ ', 20323, 23,+1,1.8500D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=49,64)/ & 'K*_2+ ', 325, 23,+1,1.4256D0,0.000D+00,2.0D0, & 'K0 ', 311, 13, 0,.49767D0,0.000D+00,0.0D0, & 'K*0 ', 313, 13, 0,.89610D0,0.000D+00,1.0D0, & 'KH_10 ', 20313, 13, 0,1.8500D0,0.000D+00,1.0D0, & 'K*_20 ', 315, 13, 0,1.4324D0,0.000D+00,2.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'PHI ', 333, 33, 0,1.0194D0,0.000D+00,1.0D0, & 'FH_1 ', 20333, 33, 0,1.4262D0,0.000D+00,1.0D0, & 'FP_2 ', 335, 33, 0,1.5250D0,0.000D+00,2.0D0, & 'GAMMA ', 22, 0, 0,0.0000D0,1.000D+30,1.0D0, & 'K_S0 ', 310, 0, 0,.49767D0,8.926D-11,0.0D0, & 'K_L0 ', 130, 0, 0,.49767D0,5.170D-08,0.0D0, & 'A_0(H)0 ', 10111, 11, 0,1.4740D0,0.000D+00,0.0D0, & 'A_0(H)+ ', 10211, 21,+1,1.4740D0,0.000D+00,0.0D0, & 'A_0(H)- ', -10211, 12,-1,1.4740D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=65,80)/ & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'REMG ', 98, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'REMN ', 99, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'P ', 2212, 122,+1,.93827D0,1.000D+30,0.5D0, & 'DELTA+ ', 2214, 122,+1,1.2320D0,0.000D+00,1.5D0, & 'N ', 2112, 112, 0,.93957D0,8.870D+02,0.5D0, & 'DELTA0 ', 2114, 112, 0,1.2320D0,0.000D+00,1.5D0, & 'DELTA- ', 1114, 111,-1,1.2320D0,0.000D+00,1.5D0, & 'LAMBDA ', 3122, 123, 0,1.1157D0,2.632D-10,0.5D0, & 'SIGMA0 ', 3212, 123, 0,1.1926D0,7.400D-20,0.5D0, & 'SIGMA*0 ', 3214, 123, 0,1.3837D0,0.000D+00,1.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=81,96)/ & 'SIGMA- ', 3112, 113,-1,1.1974D0,1.479D-10,0.5D0, & 'SIGMA*- ', 3114, 113,-1,1.3872D0,0.000D+00,1.5D0, & 'XI- ', 3312, 133,-1,1.3213D0,1.639D-10,0.5D0, & 'XI*- ', 3314, 133,-1,1.5350D0,0.000D+00,1.5D0, & 'DELTA++ ', 2224, 222,+2,1.2320D0,0.000D+00,1.5D0, & 'SIGMA+ ', 3222, 223,+1,1.1894D0,7.990D-11,0.5D0, & 'SIGMA*+ ', 3224, 223,+1,1.3828D0,0.000D+00,1.5D0, & 'XI0 ', 3322, 233, 0,1.3149D0,2.900D-10,0.5D0, & 'XI*0 ', 3324, 233, 0,1.5318D0,0.000D+00,1.5D0, & 'OMEGA- ', 3334, 333,-1,1.6725D0,8.220D-11,1.5D0, & 'PBAR ', -2212,-122,-1,.93827D0,1.000D+30,0.5D0, & 'DELTABR-', -2214,-122,-1,1.2320D0,0.000D+00,1.5D0, & 'NBAR ', -2112,-112, 0,.93957D0,8.870D+02,0.5D0, & 'DELTABR0', -2114,-112, 0,1.2320D0,0.000D+00,1.5D0, & 'DELTABR+', -1114,-111,+1,1.2320D0,0.000D+00,1.5D0, & 'LAMBDABR', -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=97,112)/ & 'SIGMABR0', -3212,-123, 0,1.1926D0,7.400D-20,0.5D0, & 'SGMA*BR0', -3214,-123, 0,1.3837D0,0.000D+00,1.5D0, & 'SIGMABR+', -3112,-113,+1,1.1974D0,1.479D-10,0.5D0, & 'SGMA*BR+', -3114,-113,+1,1.3872D0,0.000D+00,1.5D0, & 'XIBAR+ ', -3312,-133,+1,1.3213D0,1.639D-10,0.5D0, & 'XI*BAR+ ', -3314,-133,+1,1.5350D0,0.000D+00,1.5D0, & 'DLTABR--', -2224,-222,-2,1.2320D0,0.000D+00,1.5D0, & 'SIGMABR-', -3222,-223,-1,1.1894D0,7.990D-11,0.5D0, & 'SGMA*BR-', -3224,-223,-1,1.3828D0,0.000D+00,1.5D0, & 'XIBAR0 ', -3322,-233, 0,1.3149D0,2.900D-10,0.5D0, & 'XI*BAR ', -3324,-233, 0,1.5318D0,0.000D+00,1.5D0, & 'OMEGABR+', -3334,-333,+1,1.6725D0,8.220D-11,1.5D0, & 'UU ', 2203, 0,+4,0.6400D0,0.000D+00,0.0D0, & 'UD ', 2101, 0,+1,0.6400D0,0.000D+00,0.0D0, & 'DD ', 1103, 0,-2,0.6400D0,0.000D+00,0.0D0, & 'US ', 3201, 0,+1,0.8200D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=113,128)/ & 'DS ', 3101, 0,-2,0.8200D0,0.000D+00,0.0D0, & 'SS ', 3303, 0,-2,1.0000D0,0.000D+00,0.0D0, & 'UBARUBAR', -2203, 0,-4,0.6400D0,0.000D+00,0.0D0, & 'UBARDBAR', -2101, 0,-1,0.6400D0,0.000D+00,0.0D0, & 'DBARDBAR', -1103, 0,+2,0.6400D0,0.000D+00,0.0D0, & 'UBARSBAR', -3201, 0,-1,0.8200D0,0.000D+00,0.0D0, & 'DBARSBAR', -3101, 0,+2,0.8200D0,0.000D+00,0.0D0, & 'SBARSBAR', -3303, 0,+2,1.0000D0,0.000D+00,0.0D0, & 'E- ', 11, 0,-1,5.11D-04,1.000D+30,0.5D0, & 'NU_E ', 12, 0, 0,0.0000D0,1.000D+30,0.5D0, & 'MU- ', 13, 0,-1,.10566D0,2.197D-06,0.5D0, & 'NU_MU ', 14, 0, 0,0.0000D0,1.000D+30,0.5D0, & 'TAU- ', 15, 0,-1,1.7771D0,2.916D-13,0.5D0, & 'NU_TAU ', 16, 0, 0,0.0000D0,1.000D+30,0.5D0, & 'E+ ', -11, 0,+1,5.11D-04,1.000D+30,0.5D0, & 'NU_EBAR ', -12, 0, 0,0.0000D0,1.000D+30,0.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=129,144)/ & 'MU+ ', -13, 0,+1,.10566D0,2.197D-06,0.5D0, & 'NU_MUBAR', -14, 0, 0,0.0000D0,1.000D+30,0.5D0, & 'TAU+ ', -15, 0,+1,1.7771D0,2.916D-13,0.5D0, & 'NU_TAUBR', -16, 0, 0,0.0000D0,1.000D+30,0.5D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'D+ ', 411, 41,+1,1.8693D0,1.057D-12,0.0D0, & 'D*+ ', 413, 41,+1,2.0100D0,0.000D+00,1.0D0, & 'DH_1+ ', 20413, 41,+1,2.4270D0,0.000D+00,1.0D0, & 'D*_2+ ', 415, 41,+1,2.4590D0,0.000D+00,2.0D0, & 'D0 ', 421, 42, 0,1.8646D0,4.150D-13,0.0D0, & 'D*0 ', 423, 42, 0,2.0067D0,0.000D+00,1.0D0, & 'DH_10 ', 20423, 42, 0,2.4222D0,0.000D+00,1.0D0, & 'D*_20 ', 425, 42, 0,2.4589D0,0.000D+00,2.0D0, & 'D_S+ ', 431, 43,+1,1.9685D0,4.670D-13,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=145,160)/ & 'D*_S+ ', 433, 43,+1,2.1124D0,0.000D+00,1.0D0, & 'DH_S1+ ', 20433, 43,+1,2.5354D0,0.000D+00,1.0D0, & 'D*_S2+ ', 435, 43,+1,2.5735D0,0.000D+00,2.0D0, & 'SGMA_C++', 4222, 224,+2,2.4528D0,0.000D+00,0.5D0, & 'SGM*_C++', 4224, 224,+2,2.5194D0,0.000D+00,1.5D0, & 'LMBDA_C+', 4122, 124,+1,2.2849D0,2.060D-13,0.5D0, & 'SIGMA_C+', 4212, 124,+1,2.4536D0,0.000D+00,0.5D0, & 'SGMA*_C+', 4214, 124,+1,2.5185D0,0.000D+00,1.5D0, & 'SIGMA_C0', 4112, 114, 0,2.4522D0,0.000D+00,0.5D0, & 'SGMA*_C0', 4114, 114, 0,2.5175D0,0.000D+00,1.5D0, & 'XI_C+ ', 4232, 234,+1,2.4656D0,3.500D-13,0.5D0, & 'XIP_C+ ', 4322, 234,+1,2.5750D0,0.000D+00,0.5D0, & 'XI*_C+ ', 4324, 234,+1,2.6446D0,0.000D+00,1.5D0, & 'XI_C0 ', 4132, 134, 0,2.4703D0,9.800D-14,0.5D0, & 'XIP_C0 ', 4312, 134, 0,2.5800D0,0.000D+00,0.5D0, & 'XI*_C0 ', 4314, 134, 0,2.6438D0,0.000D+00,1.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=161,176)/ & 'OMEGA_C0', 4332, 334, 0,2.7040D0,6.400D-14,0.5D0, & 'OMGA*_C0', 4334, 334, 0,2.7300D0,0.000D+00,1.5D0, & 'ETA_C ', 441, 44, 0,2.9798D0,0.000D+00,0.0D0, & 'JPSI ', 443, 44, 0,3.0969D0,0.000D+00,1.0D0, & 'CHI_C1 ', 10441, 44, 0,3.4173D0,0.000D+00,0.0D0, & 'PSI2S ', 100443, 44, 0,3.6860D0,0.000D+00,1.0D0, & 'PSID ', 30443, 44, 0,3.7699D0,0.000D+00,1.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'D- ', -411, 14,-1,1.8693D0,1.057D-12,0.0D0, & 'D*- ', -413, 14,-1,2.0100D0,0.000D+00,1.0D0, & 'DH_1- ', -20413, 14,-1,2.4270D0,0.000D+00,1.0D0, & 'D*_2- ', -415, 14,-1,2.4590D0,0.000D+00,2.0D0, & 'DBAR0 ', -421, 24, 0,1.8646D0,4.140D-13,0.0D0, & 'D*BAR0 ', -423, 24, 0,2.0067D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=177,192)/ & 'DH_1BAR0', -20423, 24, 0,2.4222D0,0.000D+00,1.0D0, & 'D*_2BAR0', -425, 24, 0,2.4589D0,0.000D+00,2.0D0, & 'D_S- ', -431, 34,-1,1.9685D0,4.670D-13,0.0D0, & 'D*_S- ', -433, 34,-1,2.1124D0,0.000D+00,1.0D0, & 'DH_S1- ', -20433, 34,-1,2.5354D0,0.000D+00,1.0D0, & 'D*_S2- ', -435, 34,-1,2.5735D0,0.000D+00,2.0D0, & 'SGMA_C--', -4222,-224,-2,2.4528D0,0.000D+00,0.5D0, & 'SGM*_C--', -4224,-224,-2,2.5194D0,0.000D+00,1.5D0, & 'LMBDA_C-', -4122,-124,-1,2.2849D0,2.060D-13,0.5D0, & 'SIGMA_C-', -4212,-124,-1,2.4536D0,0.000D+00,0.5D0, & 'SGMA*_C-', -4214,-124,-1,2.5185D0,0.000D+00,1.5D0, & 'SGM_CBR0', -4112,-114, 0,2.4522D0,0.000D+00,0.5D0, & 'SG*_CBR0', -4114,-114, 0,2.5175D0,0.000D+00,1.5D0, & 'XI_C- ', -4232,-234,-1,2.4656D0,3.500D-13,0.5D0, & 'XIP_C- ', -4322,-234,-1,2.5750D0,0.000D+00,0.5D0, & 'XI*_C- ', -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=193,208)/ & 'XI_CBAR0', -4132,-134, 0,2.4703D0,9.800D-14,0.5D0, & 'XIP_CBR0', -4312,-134, 0,2.5800D0,0.000D+00,0.5D0, & 'XI*_CBR0', -4314,-134, 0,2.6438D0,0.000D+00,1.5D0, & 'OMG_CBR0', -4332,-334, 0,2.7040D0,6.400D-14,0.5D0, & 'OM*_CBR0', -4334,-334, 0,2.7300D0,0.000D+00,1.5D0, & 'W+ ', 24, 0,+1,80.420D0,0.000D+00,1.0D0, & 'W- ', -24, 0,-1,80.420D0,0.000D+00,1.0D0, & 'Z0/GAMA*', 23, 0, 0,91.188D0,0.000D+00,1.0D0, & 'HIGGS ', 25, 0, 0,115.00D0,0.000D+00,0.0D0, & 'Z0P ', 32, 0, 0,500.00D0,0.000D+00,1.0D0, & 'HIGGSL0 ', 26, 0, 0,0.0000D0,1.000D+30,0.0D0, & 'HIGGSH0 ', 35, 0, 0,0.0000D0,1.000D+30,0.0D0, & 'HIGGSA0 ', 36, 0, 0,0.0000D0,1.000D+30,0.0D0, & 'HIGGS+ ', 37, 0,+1,0.0000D0,1.000D+30,0.0D0, & 'HIGGS- ', -37, 0,-1,0.0000D0,1.000D+30,0.0D0, & 'GRAVITON', 39, 0, 0,0.0000D0,1.000D+30,2.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=209,224)/ & 'VQRK ', 7, 0,-1,200.00D0,0.000D+00,0.5D0, & 'AQRK ', 8, 0,+2,400.00D0,0.000D+00,0.5D0, & 'HQRK ', 7, 0,-1,400.00D0,0.000D+00,0.5D0, & 'HPQK ', 8, 0,+2,600.00D0,0.000D+00,0.5D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'VBAR ', -7, 0,+1,200.00D0,0.000D+00,0.5D0, & 'ABAR ', -8, 0,-2,400.00D0,0.000D+00,0.5D0, & 'HBAR ', -7, 0,+1,400.00D0,0.000D+00,0.5D0, & 'HPBR ', -8, 0,-2,600.00D0,0.000D+00,0.5D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0, & 'B_DBAR0 ', -511, 51, 0,5.2792D0,1.614D-12,0.0D0, & 'B- ', -521, 52,-1,5.2789D0,1.652D-12,0.0D0, & 'B_SBAR0 ', -531, 53, 0,5.3693D0,1.540D-12,0.0D0, & 'SIGMA_B+', 5222, 225,+1,5.8200D0,1.070D-12,0.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=225,240)/ & 'LMBDA_B0', 5122, 125, 0,5.6240D0,1.070D-12,0.5D0, & 'SIGMA_B-', 5112, 115,-1,5.8200D0,1.070D-12,0.5D0, & 'XI_B0 ', 5232, 235, 0,5.8000D0,1.070D-12,0.5D0, & 'XI_B- ', 5132, 135,-1,5.8000D0,1.070D-12,0.5D0, & 'OMEGA_B-', 5332, 335,-1,6.0400D0,1.070D-12,0.5D0, & 'B_C- ', -541, 54,-1,6.2500D0,1.000D-12,0.5D0, & 'UPSLON1S', 553, 55, 0,9.4604D0,0.000D+00,1.0D0, & 'T_B- ', -651, 56,-1,0.0000D0,0.000D+00,0.0D0, & 'T+ ', 611, 61,+1,0.0000D0,0.000D+00,0.0D0, & 'T0 ', 621, 62, 0,0.0000D0,0.000D+00,0.0D0, & 'T_S+ ', 631, 63,+1,0.0000D0,0.000D+00,0.0D0, & 'SGMA_T++', 6222, 226,+2,0.0000D0,0.000D+00,0.5D0, & 'LMBDA_T0', 6122, 126,+1,0.0000D0,0.000D+00,0.5D0, & 'SIGMA_T0', 6112, 116, 0,0.0000D0,0.000D+00,0.5D0, & 'XI_T+ ', 6232, 236,+1,0.0000D0,0.000D+00,0.5D0, & 'XI_T0 ', 6132, 136, 0,0.0000D0,0.000D+00,0.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=241,256)/ & 'OMEGA_T0', 6332, 336, 0,0.0000D0,0.000D+00,0.5D0, & 'T_C0 ', 641, 64, 0,0.0000D0,0.000D+00,0.0D0, & 'T_B+ ', 651, 65,+1,0.0000D0,0.000D+00,0.0D0, & 'TOPONIUM', 663, 66, 0,0.0000D0,0.000D+00,1.0D0, & 'B_D0 ', 511, 15, 0,5.2792D0,1.614D-12,0.0D0, & 'B+ ', 521, 25,+1,5.2789D0,1.652D-12,0.0D0, & 'B_S0 ', 531, 35, 0,5.3693D0,1.540D-12,0.0D0, & 'SGM_BBR-', -5222,-225,-1,5.8200D0,1.070D-12,0.5D0, & 'LMD_BBR0', -5122,-125, 0,5.6240D0,1.070D-12,0.5D0, & 'SGM_BBR+', -5112,-115,+1,5.8200D0,1.070D-12,0.5D0, & 'XI_BBAR0', -5232,-235, 0,5.8000D0,1.070D-12,0.5D0, & 'XI_B+ ', -5132,-135,+1,5.8000D0,1.070D-12,0.5D0, & 'OMG_BBR+', -5332,-335,+1,6.0400D0,1.070D-12,0.5D0, & 'B_C+ ', 541, 45,+1,6.2500D0,1.000D-12,0.5D0, & 'T- ', -611, 16,-1,0.0000D0,0.000D+00,0.0D0, & 'TBAR0 ', -621, 26, 0,0.0000D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=257,272)/ & 'T_S- ', -631, 36,-1,0.0000D0,0.000D+00,0.0D0, & 'SGMA_T--', -6222,-226,-2,0.0000D0,0.000D+00,0.5D0, & 'LAMDA_T-', -6122,-126,-1,0.0000D0,0.000D+00,0.5D0, & 'SGM_TBR0', -6112,-116, 0,0.0000D0,0.000D+00,0.5D0, & 'XI_T- ', -6232,-236,-1,0.0000D0,0.000D+00,0.5D0, & 'XI_TBAR0', -6132,-136, 0,0.0000D0,0.000D+00,0.5D0, & 'OMG_TBR0', -6332,-336, 0,0.0000D0,0.000D+00,0.5D0, & 'T_CBAR0 ', -641, 46, 0,0.0000D0,0.000D+00,0.0D0, & 'B*BAR0 ', -513, 51, 0,5.3249D0,0.000D+00,1.0D0, & 'B*- ', -523, 52,-1,5.3249D0,0.000D+00,1.0D0, & 'B*_SBAR0', -533, 53, 0,5.4163D0,0.000D+00,1.0D0, & 'BH_1BAR0', -20513, 51, 0,5.7600D0,0.000D+00,1.0D0, & 'BH_1- ', -20523, 52,-1,5.7600D0,0.000D+00,1.0D0, & 'BH_S1BR0', -20533, 53, 0,5.8550D0,0.000D+00,1.0D0, & 'B*_2BAR0', -515, 51, 0,5.7700D0,0.000D+00,2.0D0, & 'B*_2- ', -525, 52,-1,5.7700D0,0.000D+00,2.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=273,288)/ & 'B*_S2BR0', -535, 53, 0,5.8650D0,0.000D+00,2.0D0, & 'B*0 ', 513, 15, 0,5.3249D0,0.000D+00,1.0D0, & 'B*+ ', 523, 25,+1,5.3249D0,0.000D+00,1.0D0, & 'B*_S0 ', 533, 35, 0,5.4163D0,0.000D+00,1.0D0, & 'BH_10 ', 20513, 15, 0,5.7600D0,0.000D+00,1.0D0, & 'BH_1+ ', 20523, 25,+1,5.7600D0,0.000D+00,1.0D0, & 'BH_S10 ', 20533, 35, 0,5.8550D0,0.000D+00,1.0D0, & 'B*_20 ', 515, 15, 0,5.7700D0,0.000D+00,2.0D0, & 'B*_2+ ', 525, 25,+1,5.7700D0,0.000D+00,2.0D0, & 'B*_S20 ', 535, 35, 0,5.8650D0,0.000D+00,2.0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0, & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0, & 'B_10 ', 10113, 11, 0,1.2295D0,0.000D+00,1.0D0, & 'B_1+ ', 10213, 21,+1,1.2295D0,0.000D+00,1.0D0, & 'B_1- ', -10213, 12,-1,1.2295D0,0.000D+00,1.0D0, & 'HL_10 ', 10223, 33, 0,1.1700D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=289,304)/ & 'HH_10 ', 10333, 33, 0,1.3950D0,0.000D+00,1.0D0, & 'A_00 ', 9000111, 11, 0,.99600D0,0.000D+00,0.0D0, & 'A_0+ ', 9000211, 21,+1,.99600D0,0.000D+00,0.0D0, & 'A_0- ',-9000211, 12,-1,.99600D0,0.000D+00,0.0D0, & 'F0P0 ', 9010221, 33, 0,.99600D0,0.000D+00,0.0D0, & 'FH_00 ', 10221, 33, 0,1.3500D0,0.000D+00,0.0D0, & 'B*_C+ ', 543, 45,+1,6.2950D0,0.000D+00,1.0D0, & 'B*_C- ', -543, 54,-1,6.2950D0,0.000D+00,1.0D0, & 'BH_C1+ ', 20543, 45,+1,6.7300D0,0.000D+00,1.0D0, & 'BH_C1- ', -20543, 54,-1,6.7300D0,0.000D+00,1.0D0, & 'B*_C2+ ', 545, 45,+1,6.7400D0,0.000D+00,2.0D0, & 'B*_C2- ', -545, 54,-1,6.7400D0,0.000D+00,2.0D0, & 'H_C ', 10443, 44, 0,3.5261D0,0.000D+00,1.0D0, & 'CHI_C0 ', 20443, 44, 0,3.5105D0,0.000D+00,0.0D0, & 'CHI_C2 ', 445, 44, 0,3.5562D0,0.000D+00,2.0D0, & 'ETA_B ', 551, 55, 0,9.0000D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=305,320)/ & 'H_B ', 10553, 55, 0,9.8880D0,0.000D+00,1.0D0, & 'CHI_B0 ', 10551, 55, 0,9.8598D0,0.000D+00,0.0D0, & 'CHI_B1 ', 20553, 55, 0,9.8919D0,0.000D+00,1.0D0, & 'CHI_B2 ', 555, 55, 0,9.9132D0,0.000D+00,2.0D0, & 'KL_10 ', 10313, 13, 0,1.5700D0,0.000D+00,1.0D0, & 'KL_1+ ', 10323, 23,+1,1.5700D0,0.000D+00,1.0D0, & 'KL_1BAR0', -10313, 31, 0,1.5700D0,0.000D+00,1.0D0, & 'KL_1- ', -10323, 32,-1,1.5700D0,0.000D+00,1.0D0, & 'DL_1+ ', 10413, 41,+1,2.4270D0,0.000D+00,1.0D0, & 'DL_10 ', 10423, 42, 0,2.4222D0,0.000D+00,1.0D0, & 'DL_S1+ ', 10433, 43,+1,2.5354D0,0.000D+00,1.0D0, & 'DL_1- ', -10413, 14,-1,2.4270D0,0.000D+00,1.0D0, & 'DL_1BAR0', -10423, 24, 0,2.4222D0,0.000D+00,1.0D0, & 'DL_S1- ', -10433, 34,-1,2.5354D0,0.000D+00,1.0D0, & 'BL_10 ', 10513, 15, 0,5.7600D0,0.000D+00,1.0D0, & 'BL_1+ ', 10523, 25,+1,5.7600D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=321,336)/ & 'BL_S10 ', 10533, 35, 0,5.8530D0,0.000D+00,1.0D0, & 'BL_C1+ ', 10543, 45,+1,6.7300D0,0.000D+00,1.0D0, & 'BL_1BAR0', -10513, 51, 0,5.7600D0,0.000D+00,1.0D0, & 'BL_1- ', -10523, 52,-1,5.7600D0,0.000D+00,1.0D0, & 'BL_S1BR0', -10533, 53, 0,5.8530D0,0.000D+00,1.0D0, & 'BL_C1- ', -10543, 54,-1,6.7300D0,0.000D+00,1.0D0, & 'K*_0+ ', 10321, 23,+1,1.4290D0,0.000D+00,0.0D0, & 'K*_00 ', 10311, 13, 0,1.4290D0,0.000D+00,0.0D0, & 'K*_0BAR0', -10311, 31, 0,1.4290D0,0.000D+00,0.0D0, & 'K*_0- ', -10321, 32,-1,1.4290D0,0.000D+00,0.0D0, & 'D*_0+ ', 10411, 41,+1,2.4230D0,0.000D+00,0.0D0, & 'D*_00 ', 10421, 42, 0,2.4230D0,0.000D+00,0.0D0, & 'D*_S0+ ', 10431, 43,+1,2.5250D0,0.000D+00,0.0D0, & 'D*_0- ', -10411, 14,-1,2.4230D0,0.000D+00,0.0D0, & 'D*_0BAR0', -10421, 24, 0,2.4230D0,0.000D+00,0.0D0, & 'D*_S0- ', -10431, 34,-1,2.5250D0,0.000D+00,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=337,352)/ & 'B*_00 ', 10511, 15, 0,5.7600D0,0.000D+00,0.0D0, & 'B*_0+ ', 10521, 25,+1,5.7600D0,0.000D+00,0.0D0, & 'B*_S00 ', 10531, 35, 0,5.8550D0,0.000D+00,0.0D0, & 'B*_C0+ ', 10541, 45,+1,6.7300D0,0.000D+00,0.0D0, & 'B*_0BAR0', -10511, 51, 0,5.7600D0,0.000D+00,0.0D0, & 'B*_0- ', -10521, 52,-1,5.7600D0,0.000D+00,0.0D0, & 'B*_S0BR0', -10531, 53, 0,5.8550D0,0.000D+00,0.0D0, & 'B*_C0- ', -10541, 54,-1,6.7300D0,0.000D+00,0.0D0, & 'SGMA*_B-', 5114, 115,-1,5.8400D0,0.000D+00,1.5D0, & 'SIGMA_B0', 5212, 125, 0,5.8200D0,0.000D+00,0.5D0, & 'SGMA*_B0', 5214, 125, 0,5.8400D0,0.000D+00,1.5D0, & 'SGMA*_B+', 5224, 225,+1,5.8400D0,0.000D+00,1.5D0, & 'XIP_B0 ', 5322, 235, 0,5.9450D0,0.000D+00,0.5D0, & 'XI*_B0 ', 5324, 235, 0,5.9450D0,0.000D+00,1.5D0, & 'XIP_B- ', 5312, 135,-1,5.9450D0,0.000D+00,0.5D0, & 'XI*_B- ', 5314, 135,-1,5.9450D0,0.000D+00,1.5D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=353,368)/ & '0MGA*_B-', 5334, 335,-1,6.0600D0,0.000D+00,1.5D0, & 'SG*_BBR+', -5114,-115,+1,5.8400D0,0.000D+00,1.5D0, & 'SGM_BBR0', -5212,-125, 0,5.8200D0,0.000D+00,0.5D0, & 'SG*_BBR0', -5214,-125, 0,5.8400D0,0.000D+00,1.5D0, & 'SG*_BBR-', -5224,-225,-1,5.8400D0,0.000D+00,1.5D0, & 'XIP_BBR0', -5322,-235, 0,5.9450D0,0.000D+00,0.5D0, & 'XI*_BBR0', -5324,-235, 0,5.9450D0,0.000D+00,1.5D0, & 'XIP_B+ ', -5312,-135,+1,5.9450D0,0.000D+00,0.5D0, & 'XI*_B+ ', -5314,-135,+1,5.9450D0,0.000D+00,1.5D0, & '0MGA*_B+', -5334,-335,+1,6.0600D0,0.000D+00,1.5D0, & 'KDL_2+ ', 10325, 23,+1,1.7730D0,0.000D+00,2.0D0, & 'KDL_20 ', 10315, 13, 0,1.7730D0,0.000D+00,2.0D0, & 'KDL_2BR0', -10315, 31, 0,1.7730D0,0.000D+00,2.0D0, & 'KDL_2- ', -10325, 32,-1,1.7730D0,0.000D+00,2.0D0, & 'KD*+ ', 30323, 23,+1,1.7170D0,0.000D+00,1.0D0, & 'KD*0 ', 30313, 13, 0,1.7170D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=369,384)/ & 'KD*BAR0 ', -30313, 31, 0,1.7170D0,0.000D+00,1.0D0, & 'KD*- ', -30323, 32,-1,1.7170D0,0.000D+00,1.0D0, & 'KDH_2+ ', 20325, 23,+1,1.8160D0,0.000D+00,2.0D0, & 'KDH_20 ', 20315, 13, 0,1.8160D0,0.000D+00,2.0D0, & 'KDH_2BR0', -20315, 31, 0,1.8160D0,0.000D+00,2.0D0, & 'KDH_2- ', -20325, 32,-1,1.8160D0,0.000D+00,2.0D0, & 'KD_3+ ', 327, 23,+1,1.7730D0,0.000D+00,3.0D0, & 'KD_30 ', 317, 13, 0,1.7730D0,0.000D+00,3.0D0, & 'KD_3BAR0', -317, 31, 0,1.7730D0,0.000D+00,3.0D0, & 'KD_3- ', -327, 32,-1,1.7730D0,0.000D+00,3.0D0, & 'PI_2+ ', 10215, 21,+1,1.6700D0,0.000D+00,2.0D0, & 'PI_20 ', 10115, 11, 0,1.6700D0,0.000D+00,2.0D0, & 'PI_2- ', -10215, 12,-1,1.6700D0,0.000D+00,2.0D0, & 'RHOD+ ', 30213, 21,+1,1.7000D0,0.000D+00,1.0D0, & 'RHOD0 ', 30113, 11, 0,1.7000D0,0.000D+00,1.0D0, & 'RHOD- ', -30213, 12,-1,1.7000D0,0.000D+00,1.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=385,400)/ & 'RHO_3+ ', 217, 21,+1,1.6910D0,0.000D+00,3.0D0, & 'RHO_30 ', 117, 11, 0,1.6910D0,0.000D+00,3.0D0, & 'RHO_3- ', -217, 12,-1,1.6910D0,0.000D+00,3.0D0, & 'UPSLON2S', 100553, 55, 0,10.023D0,0.000D+00,1.0D0, & 'CHI2P_B0', 110551, 55, 0,10.232D0,0.000D+00,0.0D0, & 'CHI2P_B1', 120553, 55, 0,10.255D0,0.000D+00,1.0D0, & 'CHI2P_B2', 100555, 55, 0,10.269D0,0.000D+00,2.0D0, & 'UPSLON3S', 200553, 55, 0,10.355D0,0.000D+00,1.0D0, & 'UPSLON4S', 300553, 55, 0,10.580D0,0.000D+00,1.0D0, & ' ', 0, 0, 0,0.0 D0, 0.0D+00, 0D0, & 'OMEGA_3 ', 227, 33, 0,1.6670D0,0.000D+00,3.0D0, & 'PHI_3 ', 337, 33, 0,1.8540D0,0.000D+00,3.0D0, & 'ETA_2(L)', 10225, 33, 0,1.6320D0,0.000D+00,2.0D0, & 'ETA_2(H)', 10335, 33, 0,1.8540D0,0.000D+00,2.0D0, & 'OMEGA(H)', 30223, 33, 0,1.6490D0,0.000D+00,1.0D0, & ' ', 0, 0, 0,0.0 D0,0.0D+00 , 0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=401,416)/ & 'SSDL ', 1000001, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSUL ', 1000002, 0,+2,0.00D0,1.000D+30,0.0D0, & 'SSSL ', 1000003, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSCL ', 1000004, 0,+2,0.00D0,1.000D+30,0.0D0, & 'SSB1 ', 1000005, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SST1 ', 1000006, 0,+2,0.00D0,1.000D+30,0.0D0, & 'SSDLBR ',-1000001, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSULBR ',-1000002, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSSLBR ',-1000003, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSCLBR ',-1000004, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSB1BR ',-1000005, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SST1BR ',-1000006, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSDR ', 2000001, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSUR ', 2000002, 0,+2,0.00D0,1.000D+30,0.0D0, & 'SSSR ', 2000003, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSCR ', 2000004, 0,+2,0.00D0,1.000D+30,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=417,432)/ & 'SSB2 ', 2000005, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SST2 ', 2000006, 0,+2,0.00D0,1.000D+30,0.0D0, & 'SSDRBR ',-2000001, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSURBR ',-2000002, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSSRBR ',-2000003, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSCRBR ',-2000004, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSB2BR ',-2000005, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SST2BR ',-2000006, 0,-2,0.00D0,1.000D+30,0.0D0, & 'SSEL- ', 1000011, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUEL ', 1000012, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSMUL- ', 1000013, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUMUL ', 1000014, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSTAU1- ', 1000015, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUTL ', 1000016, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSEL+ ',-1000011, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUELBR',-1000012, 0, 0,0.00D0,1.000D+30,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=433,448)/ & 'SSMUL+ ',-1000013, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUMLBR',-1000014, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSTAU1+ ',-1000015, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUTLBR',-1000016, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSER- ', 2000011, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUER ', 2000012, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSMUR- ', 2000013, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUMUR ', 2000014, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSTAU2- ', 2000015, 0,-1,0.00D0,1.000D+30,0.0D0, & 'SSNUTR ', 2000016, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSER+ ',-2000011, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUERBR',-2000012, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSMUR+ ',-2000013, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUMRBR',-2000014, 0, 0,0.00D0,1.000D+30,0.0D0, & 'SSTAU2+ ',-2000015, 0,+1,0.00D0,1.000D+30,0.0D0, & 'SSNUTRBR',-2000016, 0, 0,0.00D0,1.000D+30,0.0D0/ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I), & RSPIN(I),I=449,NLAST)/ & 'GLUINO ', 1000021, 0, 0,0.00D0,1.000D+30,0.5D0, & 'NTLINO1 ', 1000022, 0, 0,0.00D0,1.000D+30,0.5D0, & 'NTLINO2 ', 1000023, 0, 0,0.00D0,1.000D+30,0.5D0, & 'NTLINO3 ', 1000025, 0, 0,0.00D0,1.000D+30,0.5D0, & 'NTLINO4 ', 1000035, 0, 0,0.00D0,1.000D+30,0.5D0, & 'CHGINO1+', 1000024, 0,+1,0.00D0,1.000D+30,0.5D0, & 'CHGINO2+', 1000037, 0,+1,0.00D0,1.000D+30,0.5D0, & 'CHGINO1-',-1000024, 0,-1,0.00D0,1.000D+30,0.5D0, & 'CHGINO2-',-1000037, 0,-1,0.00D0,1.000D+30,0.5D0, & 'GRAVTINO', 1000039, 0, 0,0.00D0,1.000D+30,1.5D0/ C DATA QORQQB/.FALSE., & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./ DATA QBORQQ/.FALSE., & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./ C C In the character strings use an ampersand to represent a backslash C to avoid compiler problems with the C escape character DATA ((TXNAME(J,I),J=1,2),I=0,8)/ & ' ', & ' ', & ' d', & ' d', & ' u', & ' u', & ' s', & ' s', & ' c', & ' c', & ' b', & ' b', & ' t', & ' t', & ' $&bar{&rm d}$', & ' -d', & ' $&bar{&rm u}$', & ' -u'/ DATA ((TXNAME(J,I),J=1,2),I=9,16)/ & ' $&bar{&rm s}$', & ' -s', & ' $&bar{&rm c}$', & ' -c', & ' $&bar{&rm b}$', & ' -b', & ' $&bar{&rm t}$', & ' -t', & ' $g$', & ' g', & ' CoM', & ' CoM', & ' Hard', & ' Hard', & ' Soft', & ' Soft'/ DATA ((TXNAME(J,I),J=1,2),I=17,24)/ & ' Cone', & ' Cone', & ' Heavy', & ' Heavy', & ' Cluster', & ' Cluster', & ' $&star&star&star&star$', & ' ****', & ' $&pi^0$', & ' pi0', & ' $&eta$', & ' eta', & ' $&rho^0$', & ' rho0', & ' $&omega$', & ' omega'/ DATA ((TXNAME(J,I),J=1,2),I=25,32)/ & ' $&eta^&prime$', & ' eta''', & ' $f_2$', & ' f2', & ' $a^0_1$', & ' a10', & ' $f_1(L)$', & ' f1(L)', & ' $a^0_2$', & ' a20', & ' $&pi^-$', & ' pi-', & ' $&rho^-$', & ' rho-', & ' $a^-_1$', & ' a1-'/ DATA ((TXNAME(J,I),J=1,2),I=33,40)/ & ' $a^-_2$', & ' a2-', & ' K$^-$', & ' K-', & ' K$^{&star-}$', & ' K*-', & ' K$_1(H)^-$', & ' K1(H)-', & ' K$^{&star-}_2$', & ' K2*-', & ' $&pi^+$', & ' pi+', & ' $&rho^+$', & ' rho+', & ' $a^+_1$', & ' a1+'/ DATA ((TXNAME(J,I),J=1,2),I=41,48)/ & ' $a^+_2$', & ' a2+', & ' $&overline{&rm K}^0$', & ' -K0', & ' $&overline{&rm K}^{&star0}$', & ' -K*0', & ' $&overline{&rm K}_1(H)^0$', & ' -K1(H)0', & ' $&overline{&rm K}^{&star0}_2$', & ' -K2*0', & ' K$^+$', & ' K+', & ' K$^{&star+}$', & ' K*+', & ' K$_1(H)^+$', & ' K1(H)+'/ DATA ((TXNAME(J,I),J=1,2),I=49,56)/ & ' K$^{&star+}_2$', & ' K2(H)*+', & ' K$^0$', & ' K0', & ' K$^{&star0}$', & ' K*-', & ' K$_1(H)^0$', & ' K1(H)0', & ' K$^{&star0}_2$', & ' K2*0', & ' ', & ' ', & ' ', & ' ', & ' $&phi$', & ' phi'/ DATA ((TXNAME(J,I),J=1,2),I=57,64)/ & ' $f_1(1420)$', & ' f1(1420)', & ' $f^&prime_2$', & ' f''2', & ' $&gamma$', & ' gamma', & ' K$^0_{&rm S}$', & ' KS0', & ' K$^0_{&rm L}$', & ' KL0', & ' $a_0(1450)^0$', & ' a0(1450)0', & ' $a_0(1450)^+$', & ' a0(1450)+', & ' $a_0(1450)^-$', & ' a0(1450)-'/ DATA ((TXNAME(J,I),J=1,2),I=65,72)/ & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' $&gamma$-remnant', & ' gamma-remnant', & ' $N$-remnant', & ' N-remnant'/ DATA ((TXNAME(J,I),J=1,2),I=73,80)/ & ' p', & ' p', & ' $&Delta^+$', & ' Delta+', & ' n', & ' n', & ' $&Delta^0$', & ' Delta0', & ' $&Delta^-$', & ' Delta-', & ' $&Lambda$', & ' Lambda', & ' $&Sigma^0$', & ' Sigma0', & ' $&Sigma^{&star0}$', & ' Sigma*0'/ DATA ((TXNAME(J,I),J=1,2),I=81,88)/ & ' $&Sigma^-$', & ' Sigma-', & ' $&Sigma^{&star-}$', & ' Sigma*-', & ' $&Xi^-$', & ' Xi-', & ' $&Xi^{&star-}$', & ' Xi*-', & ' $&Delta^{++}$', & ' Delta++', & ' $&Sigma^+$', & ' Sigma+', & ' $&Sigma^{&star+}$', & ' Sigma*+', & ' $&Xi^0$', & ' Xi0'/ DATA ((TXNAME(J,I),J=1,2),I=89,96)/ & ' $&Xi^{&star0}$', & ' Xi*0', & ' $&Omega^-$', & ' Omega-', & ' $&bar{&rm p}$', & ' -p', & ' $&overline{&Delta}^-$', & ' -Delta-', & ' $&bar{&rm n}$', & ' -n', & ' $&overline{&Delta}^0$', & ' -Delta0', & ' $&overline{&Delta}^+$', & ' -Delta+', & ' $&overline{&Lambda}$', & ' -Lambda'/ DATA ((TXNAME(J,I),J=1,2),I=97,104)/ & ' $&overline{&Sigma}^0$', & ' -Sigma0', & ' $&overline{&Sigma}^{&star0}$', & ' -Sigma*0', & ' $&overline{&Sigma}^+$', & ' -Sigma+', & ' $&overline{&Sigma}^{&star+}$', & ' -Sigma*+', & ' $&overline{&Xi}^+$', & ' -Xi+', & ' $&overline{&Xi}^{&star+}$', & ' -Xi*+', & ' $&overline{&Delta}^{--}$', & ' -Delta--', & ' $&overline{&Sigma}^-$', & ' -Sigma-'/ DATA ((TXNAME(J,I),J=1,2),I=105,112)/ & ' $&overline{&Sigma}^{&star-}$', & ' -Sigma*-', & ' $&overline{&Xi}^0$', & ' -Xi0', & ' $&overline&Xi^{&star0}$', & ' -Xi*0', & ' $&overline{&Omega}^+$', & ' -Omega+', & ' uu', & ' uu', & ' ud', & ' ud', & ' dd', & ' dd', & ' us', & ' us'/ DATA ((TXNAME(J,I),J=1,2),I=113,120)/ & ' ds', & ' ds', & ' ss', & ' ss', & ' $&bar{&rm u}&bar{&rm u}$', & ' -uu', & ' $&bar{&rm u}&bar{&rm d}$', & ' -ud', & ' $&bar{&rm d}&bar{&rm d}$', & ' -dd', & ' $&bar{&rm u}&bar{&rm s}$', & ' -us', & ' $&bar{&rm d}&bar{&rm s}$', & ' -ds', & ' $&bar{&rm s}&bar{&rm s}$', & ' -ss'/ DATA ((TXNAME(J,I),J=1,2),I=121,128)/ & ' e$^-$', & ' e-', & ' $&nu_{&rm e}$', & ' nue', & ' $&mu^-$', & ' mu-', & ' $&nu_&mu$', & ' numu', & ' $&tau^-$', & ' tau-', & ' $&nu_&tau$', & ' nutau', & ' e$^+$', & ' e+', & ' $&bar{&nu}_{&rm e}$', & ' -nue'/ DATA ((TXNAME(J,I),J=1,2),I=129,136)/ & ' $&mu^+$', & ' mu+', & ' $&bar{&nu}_&mu$', & ' -numu', & ' $&tau^+$', & ' tau+', & ' $&bar{&nu}_&tau$', & ' -nutau', & ' ', & ' ', & ' ', & ' ', & ' ', & ' ', & ' D$^+$', & ' D+'/ DATA ((TXNAME(J,I),J=1,2),I=137,144)/ & ' D$^{&star+}$', & ' D*+', & ' D$_1(H)^+$', & ' D1(H)+', & ' D$_2^{&star+}$', & ' D2*+', & ' D$^0$', & ' D0', & ' D$^{&star0}$', & ' D*0', & ' D$_1(H)^0$', & ' D1(H)0', & ' D$_2^{&star0}$', & ' D2*0', & ' D$_{&rm s}^+$', & ' Ds+'/ DATA ((TXNAME(J,I),J=1,2),I=145,152)/ & ' D$_{&rm s}^{&star+}$', & ' Ds*+', & ' D$_{&rm s1}(H)^+$', & ' Ds1(H)+', & ' D$^{&star+}_{&rm s2}$', & ' Ds1(H)*+', & ' $&Sigma_{&rm c}^{++}$', & ' Sigmac++', & ' $&Sigma_{&rm c}^{&star++}$', & ' Sigmac*++', & ' $&Lambda_{&rm c}^+$', & ' Lambdac+', & ' $&Sigma_{&rm c}^+$', & ' Sigmac+', & ' $&Sigma_{&rm c}^{&star+}$', & ' Sigmac*+'/ DATA ((TXNAME(J,I),J=1,2),I=153,160)/ & ' $&Sigma_{&rm c}^0$', & ' Sigmac0', & ' $&Sigma_{&rm c}^{&star0}$', & ' Sigmac*0', & ' $&Xi_{&rm c}^+$', & ' Xic+', & ' $&Xi_{&rm c}^{&prime+}$', & ' Xic''+', & ' $&Xi_{&rm c}^{&star+}$', & ' Xic*+', & ' $&Xi_{&rm c}^0$', & ' Xic0', & ' $&Xi_{&rm c}^{&prime0}$', & ' Xic''0', & ' $&Xi_{&rm c}^{&star0}$', & ' Xic*0'/ DATA ((TXNAME(J,I),J=1,2),I=161,168)/ & ' $&Omega_{&rm c}^0$', & ' Omegac0', & ' $&Omega_{&rm c}^{&star0}$', & ' Omegac*0', & ' $&eta_{&rm c}(1S)$', & ' etac(1S)', & ' J/$&psi$', & ' J/psi', & ' $&chi_{&rm c0}(1P)$', & ' chic0(1P)', & ' $&psi(2S)$', & ' psi(2S)', & ' $&psi(1D)$', & ' psi(1D)', & ' ', & ' '/ DATA ((TXNAME(J,I),J=1,2),I=169,176)/ & ' ', & ' ', & ' ', & ' ', & ' D$^-$', & ' D-', & ' D$^{&star-}$', & ' D*-', & ' D$_1(H)^-$', & ' D1(H)-', & ' D$_2^{&star-}$', & ' D2*-', & ' $&overline{&rm D}^0$', & ' -D0', & ' $&overline{&rm D}^{&star0}$', & ' -D*0'/ DATA ((TXNAME(J,I),J=1,2),I=177,184)/ & ' $&overline{&rm D}_1(H)^0$', & ' -D1(H)0', & ' $&overline{&rm D}_2^{&star0}$', & ' -D2*0', & ' D$_{&rm s}^-$', & ' Ds-', & ' D$_{&rm s}^{&star-}$', & ' Ds*-', & ' D$_{&rm s1}(H)^-$', & ' Ds1(H)-', & ' D$_{&rm s2}^{&star-}$', & ' Ds1(H)*-', & ' $&overline{&Sigma}_{&rm c}^{--}$', & ' -Sigmac--', & '$&overline{&Sigma}_{&rm c}^{&star--}$', & ' -Sigmac*--'/ DATA ((TXNAME(J,I),J=1,2),I=185,192)/ & ' $&overline{&Lambda}_{&rm c}^-$', & ' -Lambdac-', & ' $&overline{&Sigma}_{&rm c}^-$', & ' -Sigmac-', & ' $&overline{&Sigma}_{&rm c}^{&star-}$', & ' -Sigmac*-', & ' $&overline{&Sigma}_{&rm c}^0$', & ' -Sigmac0', & ' $&overline{&Sigma}_{&rm c}^{&star0}$', & ' -Sigmac*0', & ' $&overline{&Xi}_{&rm c}^-$', & ' -Xic-', & ' $&overline{&Xi}_{&rm c}^{&prime-}$', & ' -Xic''-', & ' $&overline{&Xi}_{&rm c}^{&star-}$', & ' -Xic*-'/ DATA ((TXNAME(J,I),J=1,2),I=193,200)/ & ' $&overline{&Xi}_{&rm c}^0$', & ' -Xic0', & ' $&overline{&Xi}_{&rm c}^{&prime0}$', & ' -Xic''0', & ' $&overline{&Xi}_{&rm c}^{&star0}$', & ' -Xic*0', & ' $&overline{&Omega}_{&rm c}^0$', & ' -Omegac0', & ' $&overline{&Omega}_{&rm c}^{&star0}$', & ' -Omegac*0', & ' W$^+$', & ' W+', & ' W$^-$', & ' W-', & ' Z$^0/&gamma^&star$', & ' Z0/gamma*'/ DATA ((TXNAME(J,I),J=1,2),I=201,208)/ & ' $H^0_{&rm SM}$', & ' H0SM', & ' Z$^{&prime0}$', & ' Z''0', & ' $h^0$', & ' h0', & ' $H^0$', & ' H0', & ' $A^0$', & ' A0', & ' $H^+$', & ' H+', & ' $H^-$', & ' H-', & ' $G$', & ' G'/ DATA ((TXNAME(J,I),J=1,2),I=209,216)/ & ' V-quark', & ' V-quark', & ' A-quark', & ' A-quark', & ' H-quark', & ' H-quark', & ' H$^&prime$-quark', & ' H''-quark', & ' ', & ' ', & ' ', & ' ', & ' $&overline{&rm V}$-quark', & ' -V-quark', & ' $&overline{&rm A}$-quark', & ' -A-quark'/ DATA ((TXNAME(J,I),J=1,2),I=217,224)/ & ' $&overline{&rm H}$-quark', & ' -H-quark', & ' $&overline{&rm H}^&prime$-quark', & ' -H''-quark', & ' ', & ' ', & ' ', & ' ', & ' $&overline{&rm B}_{&rm d}^0$', & ' -Bd0', & ' B$^-$', & ' B-', & ' $&overline{&rm B}_{&rm s}^0$', & ' -Bs0', & ' $&Sigma_{&rm b}^+$', & ' Sigmab+'/ DATA ((TXNAME(J,I),J=1,2),I=225,232)/ & ' $&Lambda_{&rm b}^0$', & ' Lambdab0', & ' $&Sigma_{&rm b}^-$', & ' Sigmab-', & ' $&Xi_{&rm b}^0$', & ' Xib0', & ' $&Xi_{&rm b}^-$', & ' Xib-', & ' $&Omega_{&rm b}^-$', & ' Omegab-', & ' B$_{&rm c}^-$', & ' Bc-', & ' $&Upsilon(1S)$', & ' Upsilon(1S)', & ' T$_{&rm b}^-$', & ' Tb-'/ DATA ((TXNAME(J,I),J=1,2),I=233,240)/ & ' T$^+$', & ' T+', & ' T$^0$', & ' T0', & ' T$_{&rm s}^+$', & ' Ts+', & ' $&Sigma_{&rm t}^{++}$', & ' Sigmat++', & ' $&Lambda_{&rm t}^0$', & ' Lambdat0', & ' $&Sigma_{&rm t}^0$', & ' Sigmat0', & ' $&chi_{&rm t}^+$', & ' Xit+', & ' $&chi_{&rm t}^0$', & ' Xit0'/ DATA ((TXNAME(J,I),J=1,2),I=241,248)/ & ' $&Omega_{&rm t}^0$', & ' Omegat0', & ' T$_{&rm c}^0$', & ' Tc0', & ' T$_{&rm b}^+$', & ' Tb+', & ' Toponium', & ' Toponium', & ' B$_{&rm d}^0$', & ' Bd0', & ' B$^+$', & ' B+', & ' B$_{&rm s}^0$', & ' Bs0', & ' $&overline{&Sigma}_{&rm b}^-$', & ' -Sigmab-'/ DATA ((TXNAME(J,I),J=1,2),I=249,256)/ & ' $&overline{&Lambda}_{&rm b}^-$', & ' -Lambdab-', & ' $&overline{&Sigma}_{&rm b}^+$', & ' -Sigmab+', & ' $&overline{&Xi}_{&rm b}^0$', & ' -Xib0', & ' $&Xi_{&rm b}^+$', & ' Xib+', & ' $&overline{&Omega}_{&rm b}^+$', & ' -Omegab+', & ' B$_{&rm c}^+$', & ' Bc+', & ' T$^-$', & ' T-', & ' $&overline{&rm T}^0$', & ' T0'/ DATA ((TXNAME(J,I),J=1,2),I=257,264)/ & ' T$_{&rm s}^-$', & ' Ts-', & ' $&overline{&Sigma}_{&rm t}^{--}$', & ' Sigmat--', & ' $&overline{&Lambda}_{&rm t}^-$', & ' -Lambdat-', & ' $&overline{&Sigma}_{&rm t}^0$', & ' -Sigmat0', & ' $&overline{&Xi}_{&rm t}^-$', & ' -Xit-', & ' $&overline{&Xi}_{&rm t}^0$', & ' -Xit0', & ' $&overline{&Omega}_{&rm t}^0$', & ' -Omegat0', & ' $&overline{&rm T}_{&rm c}^0$', & ' Tc0'/ DATA ((TXNAME(J,I),J=1,2),I=265,272)/ & ' $&overline{&rm B}^{&star0}$', & ' -B*0', & ' B$^{&star-}$', & ' B*-', & ' $&overline{&rm B}_{&rm s}^{&star0}$', & ' -Bs*0', & ' $&overline{&rm B}_1(H)^0$', & ' -B1(H)0', & ' B$_1(H)^-$', & ' B1(H)-', & ' $&overline{&rm B}_{&rm s1}(H)^0$', & ' -Bs1(H)0', & ' $&overline{&rm B}_2^{&star0}$', & ' -B2*0', & ' B$_2^{&star-}$', & ' B2*-'/ DATA ((TXNAME(J,I),J=1,2),I=273,280)/ & ' B$_{&rm s2}^{&star0}$', & ' Bs2*0', & ' B$^{&star0}$', & ' B*0', & ' B$^{&star+}$', & ' B*+', & ' B$_{&rm s}^{&star0}$', & ' Bs*0', & ' B$_1(H)^0$', & ' B1(H)0', & ' B$_1(H)^+$', & ' B1(H)+', & ' B$_{&rm s1}(H)^0$', & ' Bs1(H)0', & ' B$_2^{&star0}$', & ' B2*0'/ DATA ((TXNAME(J,I),J=1,2),I=281,288)/ & ' B$_2^{&star+}$', & ' B2*+', & ' B$_{&rm s2}^{&star0}$', & ' Bs2*0', & ' ', & ' ', & ' ', & ' ', & ' b$_1^0$', & ' b10', & ' b$_1^+$', & ' b1+', & ' b$_1^-$', & ' b1-', & ' h$_1(L)^0$', & ' h1(L)0'/ DATA ((TXNAME(J,I),J=1,2),I=289,296)/ & ' h$_1(H)^0$', & ' h1(H)0', & ' a$_0(980)^0$', & ' a0(980)0', & ' a$_0(980)^+$', & ' a0(980)+', & ' a$_0(980)^-$', & ' a0(980)-', & ' f$_0(980)$', & ' f0(980)', & ' f$_0(1370)$', & ' f0(1370)', & ' B$_{&rm c}^{&star+}$', & ' Bc*+', & ' B$_{&rm c}^{&star-}$', & ' Bc*-'/ DATA ((TXNAME(J,I),J=1,2),I=297,304)/ & ' B$_{&rm c1}(H)^+$', & ' Bc1(H)+', & ' B$_{&rm c1}(H)^-$', & ' Bc1(H)-', & ' B$_{&rm c2}^{&star+}$', & ' Bc2*+', & ' B$_{&rm c2}^{&star-}$', & ' Bc2*-', & ' h$_{&rm c}(1P)$', & ' hc(1P)', & ' $&chi_{&rm c0}(1P)$', & ' chic0(1P)', & ' $&chi_{&rm c2}(1P)$', & ' chic2(1P)', & ' $&eta_{&rm b}(1S)$', & ' etab(1S)'/ DATA ((TXNAME(J,I),J=1,2),I=305,312)/ & ' h$_{&rm b}(1P)$', & ' hb(1P)', & ' $&chi_{&rm b0}(1P)$', & ' chib0(1P)', & ' $&chi_{&rm b1}(1P)$', & ' chib1(1P)', & ' $&chi_{&rm b2}(1P)$', & ' chib2(1P)', & ' K$_1(L)^0$', & ' K1(L)0', & ' K$_1(L)^+$', & ' K1(L)+', & ' $&overline{&rm K}_1(L)^0$', & ' -K1(L)0', & ' K$_1(L)^-$', & ' K1(L)-'/ DATA ((TXNAME(J,I),J=1,2),I=313,320)/ & ' D$_1(L)^+$', & ' D1(L)+', & ' D$_1(L)^0$', & ' D1(L)0', & ' D$_{&rm s1}(L)^+$', & ' Ds1(L)+', & ' D$_1(L)^-$', & ' D1(L)-', & ' $&overline{&rm D}_1(L)^0$', & ' D1(L)0', & ' D$_{&rm s1}(L)^-$', & ' Ds1(L)-', & ' B$_1(L)^0$', & ' B1(L)0', & ' B$_1(L)^+$', & ' B1(L)+'/ DATA ((TXNAME(J,I),J=1,2),I=321,328)/ & ' B$_{&rm s1}(L)^0$', & ' Bs1(L)0', & ' B$_{&rm c1}(L)^+$', & ' Bc1(L)+', & ' $&overline{&rm B}_1(L)^0$', & ' -B1(L)0', & ' B$_1(L)^-$', & ' B1(L)-', & ' $&overline{&rm B}_{&rm s1}(L)^0$', & ' -Bs1(L)0', & ' B$_{&rm c1}(L)^-$', & ' Bc1(L)-', & ' K$_0^{&star+}$', & ' K0*+', & ' K$_0^{&star0}$', & ' K0*0'/ DATA ((TXNAME(J,I),J=1,2),I=329,336)/ & ' $&overline{&rm K}_0^{&star0}$', & ' -K0*0', & ' K$_0^{&star-}$', & ' K0*-', & ' D$_0^{&star+}$', & ' D0*+', & ' D$_0^{&star0}$', & ' D0*0', & ' D$_{&rm s0}^{&star+}$', & ' Ds0*+', & ' D$_0^{&star-}$', & ' D0*-', & ' $&overline{&rm D}_0^{&star0}$', & ' -D0*0', & ' D$_{&rm s0}^{&star-}$', & ' Ds0*-'/ DATA ((TXNAME(J,I),J=1,2),I=337,344)/ & ' B$_0^{&star0}$', & ' B0*0', & ' B$_0^{&star+}$', & ' B0*+', & ' B$_{&rm s0}^{&star0}$', & ' Bs0*0', & ' B$_{&rm c0}^{&star+}$', & ' Bc0*+', & ' $&overline{&rm B}_0^{&star0}$', & ' -B0*0', & ' B$_0^{&star-}$', & ' B0*-', & ' $&overline{&rm B}_{&rm s0}^{&star0}$', & ' -Bs0*0', & ' B$_{&rm c0}^{&star-}$', & ' Bc0*-'/ DATA ((TXNAME(J,I),J=1,2),I=345,352)/ & ' $&Sigma_{&rm b}^0$', & ' Sigmab0', & ' $&Sigma_{&rm b}^{&star-}$', & ' Sigmab*-', & ' $&Sigma_{&rm b}^{&star0}$', & ' Sigmab*0', & ' $&Sigma_{&rm b}^{&star+}$', & ' Sigmab*+', & ' $&Xi_{&rm b}^{&prime0}$', & ' Xib''0', & ' $&Xi_{&rm b}^{&star0}$', & ' Xib*0', & ' $&Xi_{&rm b}^{&prime-}$', & ' Xib''-', & ' $&Xi_{&rm b}^{&star-}$', & ' Xib*-'/ DATA ((TXNAME(J,I),J=1,2),I=353,360)/ & ' $&Omega_{&rm b}^{&star-}$', & ' -Omegab*-', & ' $&overline{&Sigma}_{&rm b}^{&star+}$', & ' Sigmab*+', & ' $&overline{&Sigma}_{&rm b}^0$', & ' -Sigmab0', & ' $&overline{&Sigma}_{&rm b}^{&star0}$', & ' -Sigmab*0', & ' $&overline{&Sigma}_{&rm b}^{&star-}$', & ' -Sigmab*-', & ' $&overline{&Xi}_{&rm b}^{&prime0}$', & ' -Xib''0', & ' $&overline{&Xi}_{&rm b}^{&star0}$', & ' -Xib*0', & ' $&overline{&Xi}_{&rm b}^{&prime+}$', & ' -Xib''+'/ DATA ((TXNAME(J,I),J=1,2),I=361,368)/ & ' $&overline{&Xi}_{&rm b}^{&star+}$', & ' -Xib*+', & ' $&Omega_{&rm b}^{&star+}$', & ' Omegab*+', & ' K$(DL)_2^+$', & ' K(DL)2+', & ' K$(DL)_2^0$', & ' K(DL)20', & ' $&overline{&rm K}(DL)_2^0$', & ' -K(DL)20', & ' K$(DL)_2^-$', & ' K(DL)2-', & ' K$(D)^{&star+}$', & ' K(D)*+', & ' K$(D)^{&star0}$', & ' K(D)*0'/ DATA ((TXNAME(J,I),J=1,2),I=369,376)/ & ' $&overline{&rm K}(D)^{&star0}$', & ' -K(D)*0', & ' K$(D)^{&star-}$', & ' K(D)*-', & ' K$(DH)_2^+$', & ' K(DH)2+', & ' K$(DH)_2^0$', & ' K(DH)20', & ' $&overline{&rm K}(DH)_2^0$', & ' -K(DH)20', & ' K$(DH)_2^-$', & ' K(DH)2-', & ' K$(D)_3^+$', & ' K(D)3+', & ' K$(D)_3^0$', & ' K(D)30'/ DATA ((TXNAME(J,I),J=1,2),I=377,384)/ & ' $&overline{&rm K}(D)_3^0$', & ' -K(D)30', & ' K$(D)_3^-$', & ' K(D)3-', & ' $&pi_2^+$', & ' pi2+', & ' $&pi_2^0$', & ' pi20', & ' $&pi_2^-$', & ' pi2-', & ' $&rho(D)^+$', & ' rho(D)+', & ' $&rho(D)^0$', & ' rho(D)0', & ' $&rho(D)^-$', & ' rho(D)-'/ DATA ((TXNAME(J,I),J=1,2),I=385,392)/ & ' $&rho_3^+$', & ' rho3+', & ' $&rho_3^0$', & ' rho30', & ' $&rho_3^-$', & ' rho3-', & ' $&Upsilon(2S)$', & ' Upsilon(2S)', & ' $&chi_{&rm b0}(2P)$', & ' Chib0(2P)', & ' $&chi_{&rm b1}(2P)$', & ' Chib1(2P)', & ' $&chi_{&rm b2}(2P)$', & ' Chib2(2P)', & ' $&Upsilon(3S)$', & ' Upsilon(3S)'/ DATA ((TXNAME(J,I),J=1,2),I=393,400)/ & ' $&Upsilon(4S)$', & ' Upsilon(4S)', & ' ', & ' ', & ' $&omega_3$', & ' omega3', & ' $&phi_3$', & ' phi3', & ' $&eta_2(L)$', & ' eta2(L)', & ' $&eta_2(H)$', & ' eta2(H)', & ' $&omega(H)$', & ' omega(H)', & ' ', & ' '/ DATA ((TXNAME(J,I),J=1,2),I=401,408)/ & ' $&tilde{&rm d}_{&rm L}$', & ' ~dL', & ' $&tilde{&rm u}_{&rm L}$', & ' ~uL', & ' $&tilde{&rm s}_{&rm L}$', & ' ~sL', & ' $&tilde{&rm c}_{&rm L}$', & ' ~cL', & ' $&tilde{&rm b}_1$', & ' ~b1', & ' $&tilde{&rm t}_1$', & ' ~t1', & ' $&overline{&tilde{&rm d}}_{&rm L}$', & ' -~dL', & ' $&overline{&tilde{&rm u}}_{&rm L}$', & ' -~uL'/ DATA ((TXNAME(J,I),J=1,2),I=409,416)/ & ' $&overline{&tilde{&rm s}}_{&rm L}$', & ' -~sL', & ' $&overline{&tilde{&rm c}}_{&rm L}$', & ' -~cL', & ' $&overline{&tilde{&rm b}}_1$', & ' -~b1', & ' $&overline{&tilde{&rm t}}_1$', & ' -~t1', & ' $&tilde{&rm d}_{&rm R}$', & ' ~dR', & ' $&tilde{&rm u}_{&rm R}$', & ' ~uR', & ' $&tilde{&rm s}_{&rm R}$', & ' ~sR', & ' $&tilde{&rm c}_{&rm R}$', & ' ~cR'/ DATA ((TXNAME(J,I),J=1,2),I=417,424)/ & ' $&tilde{&rm b}_2$', & ' ~b2', & ' $&tilde{&rm t}_2$', & ' ~t2', & ' $&overline{&tilde{&rm d}}_{&rm R}$', & ' -~dR', & ' $&overline{&tilde{&rm u}}_{&rm R}$', & ' -~uR', & ' $&overline{&tilde{&rm s}}_{&rm R}$', & ' -~sR', & ' $&overline{&tilde{&rm c}}_{&rm R}$', & ' -~cR', & ' $&overline{&tilde{&rm b}}_2$', & ' -~b2', & ' $&overline{&tilde{&rm t}}_2$', & ' -~t2'/ DATA ((TXNAME(J,I),J=1,2),I=425,432)/ & ' $&tilde{&rm e}^-_{&rm L}$', & ' ~e-L', & ' $&tilde{&nu}_{&rm e}$', & ' ~nue L', & ' $&tilde{&mu}^-_{&rm L}$', & ' ~mu-L', & ' $&tilde{&nu}_&mu$', & ' ~numu L', & ' $&tilde{&tau}^-_1$', & ' ~tau-1', & ' $&tilde{&nu}_&tau$', & ' ~nutau L', & ' $&tilde{&rm e}^+_{&rm L}$', & ' ~e+L', & ' $&overline{&tilde{&nu}}_{&rm eL}$', & ' -~nueL'/ DATA ((TXNAME(J,I),J=1,2),I=433,440)/ & ' $&tilde{&mu}^+_{&rm L}$', & ' ~mu+L', & ' $&overline{&tilde{&nu}}_{&rm&mu L}$', & ' -~numu L', & ' $&tilde{&tau}^+_1$', & ' ~tau+1', & ' $&overline{&tilde{&nu}}_{&rm&tau L}$', & ' -~nutau L', & ' $&tilde{&rm e}^-_{&rm R}$', & ' ~e-R', & ' $&tilde{&nu}_{&rm eR}$', & ' ~nue R', & ' $&tilde{&mu}^-_{&rm R}$', & ' ~mu-R', & ' $&tilde{&nu}_{&mu{&rm R}}$', & ' ~numu R'/ DATA ((TXNAME(J,I),J=1,2),I=441,448)/ & ' $&tilde{&tau}^-_2$', & ' ~tau-2', & ' $&tilde{&nu}_{&tau{&rm R}}$', & ' ~nutau R', & ' $&tilde{&rm e}^+_{&rm R}$', & ' ~e+R', & ' $&overline{&tilde{&nu}}_{&rm eR}$', & ' -~nue R', & ' $&tilde{&mu}^+_{&rm R}$', & ' ~mu+R', & ' $&overline{&tilde{&nu}}_{&rm&mu R}$', & ' -~numu R', & ' $&tilde{&tau}^+_2$', & ' ~tau+2', & ' $&overline{&tilde{&nu}}_{&rm&tau R}$', & ' -~nutau R'/ DATA ((TXNAME(J,I),J=1,2),I=449,456)/ & ' $&tilde{g}$', & ' ~g', & ' $&tilde{&chi}^0_1$', & ' ~chi01', & ' $&tilde{&chi}^0_2$', & ' ~chi02', & ' $&tilde{&chi}^0_3$', & ' ~chi03', & ' $&tilde{&chi}^0_4$', & ' ~chi04', & ' $&tilde{&chi}^+_1$', & ' ~chi+1', & ' $&tilde{&chi}^+_2$', & ' ~chi+2', & ' $&tilde{&chi}^-_1$', & ' ~chi-1'/ DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/ & ' $&tilde{&chi}^-_2$', & ' ~chi-2', & ' $&tilde{G}$', & ' ~G'/ C DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*' '/ DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/ DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/ DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000D0/ DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/ DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/ DATA (TXNAME(1,I),I=NNEXT,NMXRES)/ & NLEFT*' '/ DATA (TXNAME(2,I),I=NNEXT,NMXRES)/ & NLEFT*' '/ C DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./ DATA DKPSET/.FALSE./ C DATA NDKYS/2263/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 1, 19)/ & 6,0.334D0,100, 2, 7, 5, 0, 0, & 6,0.333D0,100, 4, 9, 5, 0, 0, & 6,0.111D0,100,122,127, 5, 0, 0, & 6,0.111D0,100,124,129, 5, 0, 0, & 6,0.111D0,100,126,131, 5, 0, 0, & 12,0.334D0,100, 8, 1, 11, 0, 0, & 12,0.333D0,100, 10, 3, 11, 0, 0, & 12,0.111D0,100,128,121, 11, 0, 0, & 12,0.111D0,100,130,123, 11, 0, 0, & 12,0.111D0,100,132,125, 11, 0, 0, & 21,0.988D0, 0, 59, 59, 0, 0, 0, & 21,0.012D0, 0,127,121, 59, 0, 0, & 22,0.388D0, 0, 59, 59, 0, 0, 0, & 22,0.319D0, 0, 21, 21, 21, 0, 0, & 22,0.001D0, 0, 21, 59, 59, 0, 0, & 22,0.236D0, 0, 38, 30, 21, 0, 0, & 22,0.049D0, 0, 38, 30, 59, 0, 0, & 22,0.005D0, 0,127,121, 59, 0, 0, & 22,0.002D0, 0, 38, 30,127,121, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 20, 38)/ & 23,0.989D0, 0, 38, 30, 0, 0, 0, & 23,0.010D0, 0, 38, 30, 59, 0, 0, & 23,0.001D0, 0, 21, 59, 0, 0, 0, & 24,0.888D0, 0, 38, 30, 21, 0, 0, & 24,0.085D0, 0, 21, 59, 0, 0, 0, & 24,0.022D0, 0, 38, 30, 0, 0, 0, & 24,0.001D0, 0, 22, 59, 0, 0, 0, & 24,0.001D0, 0, 21,127,121, 0, 0, & 24,0.003D0, 0, 38, 30, 21, 21, 0, & 25,0.437D0, 0, 38, 30, 22, 0, 0, & 25,0.302D0, 0, 23, 59, 0, 0, 0, & 25,0.208D0, 0, 21, 21, 22, 0, 0, & 25,0.030D0, 0, 24, 59, 0, 0, 0, & 25,0.021D0, 0, 59, 59, 0, 0, 0, & 25,0.002D0, 0, 21, 21, 21, 0, 0, & 26,0.566D0, 0, 38, 30, 0, 0, 0, & 26,0.283D0, 0, 21, 21, 0, 0, 0, & 26,0.069D0, 0, 38, 30, 21, 21, 0, & 26,0.023D0, 0, 46, 34, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 39, 57)/ & 26,0.023D0, 0, 50, 42, 0, 0, 0, & 26,0.028D0, 0, 38, 38, 30, 30, 0, & 26,0.005D0, 0, 22, 22, 0, 0, 0, & 26,0.003D0, 0, 21, 21, 21, 21, 0, & 27,0.499D0, 0, 39, 30, 0, 0, 0, & 27,0.499D0, 0, 31, 38, 0, 0, 0, & 27,0.002D0, 0, 21, 59, 59, 0, 0, & 28,0.148D0, 0, 21, 21, 38, 30, 0, & 28,0.148D0, 0, 23, 38, 30, 0, 0, & 28,0.147D0, 0,291, 30, 0, 0, 0, & 28,0.147D0, 0,290, 21, 0, 0, 0, & 28,0.147D0, 0,292, 38, 0, 0, 0, & 28,0.067D0, 0, 22, 38, 30, 0, 0, & 28,0.033D0, 0, 22, 21, 21, 0, 0, & 28,0.032D0, 0, 46, 42, 30, 0, 0, & 28,0.016D0, 0, 46, 34, 21, 0, 0, & 28,0.016D0, 0, 50, 42, 21, 0, 0, & 28,0.032D0, 0, 50, 34, 38, 0, 0, & 28,0.066D0, 0, 59, 23, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 58, 76)/ & 28,0.001D0, 0, 56, 59, 0, 0, 0, & 29,0.349D0, 0, 39, 30, 0, 0, 0, & 29,0.349D0, 0, 31, 38, 0, 0, 0, & 29,0.144D0, 0, 22, 21, 0, 0, 0, & 29,0.104D0, 0, 24, 38, 30, 0, 0, & 29,0.024D0, 0, 46, 34, 0, 0, 0, & 29,0.024D0, 0, 50, 42, 0, 0, 0, & 29,0.006D0, 0, 25, 21, 0, 0, 0, & 30,1.000D0, 0,123,130, 0, 0, 0, & 31,1.000D0, 0, 30, 21, 0, 0, 0, & 32,0.499D0, 0, 31, 21, 0, 0, 0, & 32,0.499D0, 0, 23, 30, 0, 0, 0, & 32,0.002D0, 0, 30, 59, 0, 0, 0, & 33,0.349D0, 0, 31, 21, 0, 0, 0, & 33,0.349D0, 0, 23, 30, 0, 0, 0, & 33,0.144D0, 0, 22, 30, 0, 0, 0, & 33,0.101D0, 0, 24, 30, 21, 0, 0, & 33,0.048D0, 0, 50, 34, 0, 0, 0, & 33,0.006D0, 0, 25, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 77, 95)/ & 33,0.003D0, 0, 30, 59, 0, 0, 0, & 34,0.629D0, 0,123,130, 0, 0, 0, & 34,0.212D0, 0, 30, 21, 0, 0, 0, & 34,0.056D0, 0, 30, 38, 30, 0, 0, & 34,0.017D0, 0, 30, 21, 21, 0, 0, & 34,0.048D0,101,121,128, 21, 0, 0, & 34,0.032D0,101,123,130, 21, 0, 0, & 34,0.006D0, 0,123,130, 59, 0, 0, & 35,0.666D0, 0, 42, 30, 0, 0, 0, & 35,0.333D0, 0, 34, 21, 0, 0, 0, & 35,0.001D0, 0, 34, 59, 0, 0, 0, & 36,0.627D0, 0, 43, 30, 0, 0, 0, & 36,0.313D0, 0, 35, 21, 0, 0, 0, & 36,0.020D0, 0, 42, 31, 0, 0, 0, & 36,0.010D0, 0, 34, 23, 0, 0, 0, & 36,0.020D0, 0, 34,294, 0, 0, 0, & 36,0.010D0, 0, 34, 24, 0, 0, 0, & 37,0.331D0, 0, 42, 30, 0, 0, 0, & 37,0.166D0, 0, 34, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 96, 114)/ & 37,0.168D0, 0, 43, 30, 0, 0, 0, & 37,0.084D0, 0, 35, 21, 0, 0, 0, & 37,0.087D0, 0, 35, 38, 30, 0, 0, & 37,0.044D0, 0, 35, 21, 21, 0, 0, & 37,0.059D0, 0, 42, 31, 0, 0, 0, & 37,0.029D0, 0, 34, 23, 0, 0, 0, & 37,0.029D0, 0, 34, 24, 0, 0, 0, & 37,0.002D0, 0, 34, 59, 0, 0, 0, & 37,0.001D0, 0, 34, 22, 0, 0, 0, & 38,1.000D0, 0,129,124, 0, 0, 0, & 39,1.000D0, 0, 38, 21, 0, 0, 0, & 40,0.499D0, 0, 39, 21, 0, 0, 0, & 40,0.499D0, 0, 23, 38, 0, 0, 0, & 40,0.002D0, 0, 38, 59, 0, 0, 0, & 41,0.349D0, 0, 39, 21, 0, 0, 0, & 41,0.349D0, 0, 23, 38, 0, 0, 0, & 41,0.144D0, 0, 22, 38, 0, 0, 0, & 41,0.101D0, 0, 24, 38, 21, 0, 0, & 41,0.048D0, 0, 46, 42, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/ & 41,0.006D0, 0, 25, 38, 0, 0, 0, & 41,0.003D0, 0, 38, 59, 0, 0, 0, & 42,0.500D0, 0, 60, 0, 0, 0, 0, & 42,0.500D0, 0, 61, 0, 0, 0, 0, & 43,0.665D0, 0, 34, 38, 0, 0, 0, & 43,0.333D0, 0, 42, 21, 0, 0, 0, & 43,0.002D0, 0, 42, 59, 0, 0, 0, & 44,0.627D0, 0, 35, 38, 0, 0, 0, & 44,0.313D0, 0, 43, 21, 0, 0, 0, & 44,0.020D0, 0, 34, 39, 0, 0, 0, & 44,0.010D0, 0, 42, 23, 0, 0, 0, & 44,0.020D0, 0, 42,294, 0, 0, 0, & 44,0.010D0, 0, 42, 24, 0, 0, 0, & 45,0.331D0, 0, 34, 38, 0, 0, 0, & 45,0.166D0, 0, 42, 21, 0, 0, 0, & 45,0.168D0, 0, 35, 38, 0, 0, 0, & 45,0.084D0, 0, 43, 21, 0, 0, 0, & 45,0.089D0, 0, 42, 38, 30, 0, 0, & 45,0.044D0, 0, 42, 21, 21, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/ & 45,0.059D0, 0, 34, 39, 0, 0, 0, & 45,0.029D0, 0, 42, 23, 0, 0, 0, & 45,0.029D0, 0, 42, 24, 0, 0, 0, & 45,0.001D0, 0, 42, 22, 0, 0, 0, & 46,0.629D0, 0,129,124, 0, 0, 0, & 46,0.212D0, 0, 38, 21, 0, 0, 0, & 46,0.056D0, 0, 38, 38, 30, 0, 0, & 46,0.017D0, 0, 38, 21, 21, 0, 0, & 46,0.032D0,101,129,124, 21, 0, 0, & 46,0.048D0,101,127,122, 21, 0, 0, & 46,0.006D0, 0,129,124, 59, 0, 0, & 47,0.666D0, 0, 50, 38, 0, 0, 0, & 47,0.333D0, 0, 46, 21, 0, 0, 0, & 47,0.001D0, 0, 46, 59, 0, 0, 0, & 48,0.627D0, 0, 51, 38, 0, 0, 0, & 48,0.313D0, 0, 47, 21, 0, 0, 0, & 48,0.020D0, 0, 50, 39, 0, 0, 0, & 48,0.010D0, 0, 46, 23, 0, 0, 0, & 48,0.020D0, 0, 46,294, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/ & 48,0.010D0, 0, 46, 24, 0, 0, 0, & 49,0.331D0, 0, 50, 38, 0, 0, 0, & 49,0.166D0, 0, 46, 21, 0, 0, 0, & 49,0.168D0, 0, 51, 38, 0, 0, 0, & 49,0.084D0, 0, 47, 21, 0, 0, 0, & 49,0.087D0, 0, 47, 38, 30, 0, 0, & 49,0.044D0, 0, 47, 21, 21, 0, 0, & 49,0.059D0, 0, 50, 39, 0, 0, 0, & 49,0.029D0, 0, 46, 23, 0, 0, 0, & 49,0.029D0, 0, 46, 24, 0, 0, 0, & 49,0.002D0, 0, 46, 59, 0, 0, 0, & 49,0.001D0, 0, 46, 22, 0, 0, 0, & 50,0.500D0, 0, 60, 0, 0, 0, 0, & 50,0.500D0, 0, 61, 0, 0, 0, 0, & 51,0.665D0, 0, 46, 30, 0, 0, 0, & 51,0.333D0, 0, 50, 21, 0, 0, 0, & 51,0.002D0, 0, 50, 59, 0, 0, 0, & 52,0.627D0, 0, 47, 30, 0, 0, 0, & 52,0.313D0, 0, 51, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/ & 52,0.020D0, 0, 46, 31, 0, 0, 0, & 52,0.010D0, 0, 50, 23, 0, 0, 0, & 52,0.020D0, 0, 50,294, 0, 0, 0, & 52,0.010D0, 0, 50, 24, 0, 0, 0, & 53,0.331D0, 0, 46, 30, 0, 0, 0, & 53,0.166D0, 0, 50, 21, 0, 0, 0, & 53,0.168D0, 0, 47, 30, 0, 0, 0, & 53,0.084D0, 0, 51, 21, 0, 0, 0, & 53,0.089D0, 0, 50, 38, 30, 0, 0, & 53,0.044D0, 0, 50, 21, 21, 0, 0, & 53,0.059D0, 0, 46, 31, 0, 0, 0, & 53,0.029D0, 0, 50, 23, 0, 0, 0, & 53,0.029D0, 0, 50, 24, 0, 0, 0, & 53,0.001D0, 0, 50, 22, 0, 0, 0, & 56,0.490D0, 0, 46, 34, 0, 0, 0, & 56,0.342D0, 0, 61, 60, 0, 0, 0, & 56,0.043D0, 0, 39, 30, 0, 0, 0, & 56,0.043D0, 0, 23, 21, 0, 0, 0, & 56,0.043D0, 0, 31, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/ & 56,0.025D0, 0, 38, 30, 21, 0, 0, & 56,0.013D0, 0, 22, 59, 0, 0, 0, & 56,0.001D0, 0, 21, 59, 0, 0, 0, & 57,0.250D0, 0, 50, 43, 0, 0, 0, & 57,0.250D0, 0, 34, 47, 0, 0, 0, & 57,0.250D0, 0, 42, 51, 0, 0, 0, & 57,0.250D0, 0, 46, 35, 0, 0, 0, & 58,0.356D0, 0, 46, 34, 0, 0, 0, & 58,0.356D0, 0, 50, 42, 0, 0, 0, & 58,0.279D0, 0, 22, 22, 0, 0, 0, & 58,0.006D0, 0, 38, 30, 0, 0, 0, & 58,0.003D0, 0, 21, 21, 0, 0, 0, & 60,0.684D0, 0, 38, 30, 0, 0, 0, & 60,0.314D0, 0, 21, 21, 0, 0, 0, & 60,0.002D0, 0, 38, 30, 59, 0, 0, & 61,0.216D0, 0, 21, 21, 21, 0, 0, & 61,0.124D0, 0, 38, 30, 21, 0, 0, & 61,0.135D0,101,123,130, 38, 0, 0, & 61,0.135D0,101,124,129, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/ & 61,0.187D0,101,121,128, 38, 0, 0, & 61,0.187D0,101,122,127, 30, 0, 0, & 61,0.006D0, 0,121,128, 38, 59, 0, & 61,0.006D0, 0,122,127, 30, 59, 0, & 61,0.002D0, 0, 38, 30, 0, 0, 0, & 61,0.001D0, 0, 21, 21, 0, 0, 0, & 61,0.001D0, 0, 59, 59, 0, 0, 0, & 74,0.663D0, 0, 73, 21, 0, 0, 0, & 74,0.331D0, 0, 75, 38, 0, 0, 0, & 74,0.006D0, 0, 73, 59, 0, 0, 0, & 75,1.000D0,101,121,128, 73, 0, 0, & 76,0.663D0, 0, 75, 21, 0, 0, 0, & 76,0.331D0, 0, 73, 30, 0, 0, 0, & 76,0.006D0, 0, 75, 59, 0, 0, 0, & 77,1.000D0, 0, 75, 30, 0, 0, 0, & 78,0.638D0, 0, 73, 30, 0, 0, 0, & 78,0.358D0, 0, 75, 21, 0, 0, 0, & 78,0.002D0, 0, 75, 59, 0, 0, 0, & 78,0.001D0, 0, 73, 30, 59, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/ & 78,0.001D0,101,121,128, 73, 0, 0, & 79,0.995D0, 0, 78, 59, 0, 0, 0, & 79,0.005D0, 0, 78,127,121, 0, 0, & 80,0.880D0, 0, 78, 21, 0, 0, 0, & 80,0.060D0, 0, 86, 30, 0, 0, 0, & 80,0.060D0, 0, 81, 38, 0, 0, 0, & 81,0.998D0, 0, 75, 30, 0, 0, 0, & 81,0.001D0, 0, 75, 30, 59, 0, 0, & 81,0.001D0,101,121,128, 75, 0, 0, & 82,0.880D0, 0, 78, 30, 0, 0, 0, & 82,0.060D0, 0, 79, 30, 0, 0, 0, & 82,0.060D0, 0, 81, 21, 0, 0, 0, & 83,0.999D0, 0, 78, 30, 0, 0, 0, & 83,0.001D0,101,121,128, 78, 0, 0, & 84,0.667D0, 0, 88, 30, 0, 0, 0, & 84,0.333D0, 0, 83, 21, 0, 0, 0, & 85,1.000D0, 0, 73, 38, 0, 0, 0, & 86,0.516D0, 0, 73, 21, 0, 0, 0, & 86,0.483D0, 0, 75, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/ & 86,0.001D0, 0, 73, 59, 0, 0, 0, & 87,0.880D0, 0, 78, 38, 0, 0, 0, & 87,0.060D0, 0, 86, 21, 0, 0, 0, & 87,0.060D0, 0, 79, 38, 0, 0, 0, & 88,0.995D0, 0, 78, 21, 0, 0, 0, & 88,0.001D0, 0, 78, 59, 0, 0, 0, & 88,0.004D0, 0, 79, 59, 0, 0, 0, & 89,0.667D0, 0, 83, 38, 0, 0, 0, & 89,0.333D0, 0, 88, 21, 0, 0, 0, & 90,0.675D0, 0, 78, 34, 0, 0, 0, & 90,0.233D0, 0, 88, 30, 0, 0, 0, & 90,0.086D0, 0, 83, 21, 0, 0, 0, & 90,0.006D0,101,121,128, 88, 0, 0, & 92,0.663D0, 0, 91, 21, 0, 0, 0, & 92,0.331D0, 0, 93, 30, 0, 0, 0, & 92,0.006D0, 0, 91, 59, 0, 0, 0, & 93,1.000D0,101,127,122, 91, 0, 0, & 94,0.663D0, 0, 93, 21, 0, 0, 0, & 94,0.331D0, 0, 91, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/ & 94,0.006D0, 0, 93, 59, 0, 0, 0, & 95,1.000D0, 0, 93, 38, 0, 0, 0, & 96,0.638D0, 0, 91, 38, 0, 0, 0, & 96,0.358D0, 0, 93, 21, 0, 0, 0, & 96,0.002D0, 0, 93, 59, 0, 0, 0, & 96,0.001D0, 0, 91, 38, 59, 0, 0, & 96,0.001D0,101,127,122, 91, 0, 0, & 97,0.995D0, 0, 96, 59, 0, 0, 0, & 97,0.005D0, 0, 96,127,121, 0, 0, & 98,0.880D0, 0, 96, 21, 0, 0, 0, & 98,0.060D0, 0,104, 38, 0, 0, 0, & 98,0.060D0, 0, 99, 30, 0, 0, 0, & 99,0.998D0, 0, 93, 38, 0, 0, 0, & 99,0.001D0, 0, 93, 38, 59, 0, 0, & 99,0.001D0,101,127,122, 93, 0, 0, & 100,0.880D0, 0, 96, 38, 0, 0, 0, & 100,0.060D0, 0, 97, 38, 0, 0, 0, & 100,0.060D0, 0, 99, 21, 0, 0, 0, & 101,0.999D0, 0, 96, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/ & 101,0.001D0,101,127,122, 96, 0, 0, & 102,0.667D0, 0,106, 38, 0, 0, 0, & 102,0.333D0, 0,101, 21, 0, 0, 0, & 103,1.000D0, 0, 91, 30, 0, 0, 0, & 104,0.516D0, 0, 91, 21, 0, 0, 0, & 104,0.483D0, 0, 93, 30, 0, 0, 0, & 104,0.001D0, 0, 91, 59, 0, 0, 0, & 105,0.880D0, 0, 96, 30, 0, 0, 0, & 105,0.060D0, 0,104, 21, 0, 0, 0, & 105,0.060D0, 0, 97, 30, 0, 0, 0, & 106,0.995D0, 0, 96, 21, 0, 0, 0, & 106,0.001D0, 0, 96, 59, 0, 0, 0, & 106,0.004D0, 0, 97, 59, 0, 0, 0, & 107,0.667D0, 0,101, 30, 0, 0, 0, & 107,0.333D0, 0,106, 21, 0, 0, 0, & 108,0.675D0, 0, 96, 46, 0, 0, 0, & 108,0.233D0, 0,106, 38, 0, 0, 0, & 108,0.086D0, 0,101, 21, 0, 0, 0, & 108,0.006D0,101,127,122,106, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/ & 123,0.986D0,100,121,128,124, 0, 0, & 123,0.014D0, 0,121,128,124, 59, 0, & 125,0.178D0,100,121,128,126, 0, 0, & 125,0.171D0,100,123,130,126, 0, 0, & 125,0.002D0, 0,123,130, 59,126, 0, & 125,0.111D0, 0, 30,126, 0, 0, 0, & 125,0.253D0, 0, 31,126, 0, 0, 0, & 125,0.181D0, 0, 32,126, 0, 0, 0, & 125,0.002D0, 0, 30, 22, 21,126, 0, & 125,0.018D0, 0, 30, 24,126, 0, 0, & 125,0.004D0, 0, 30, 24, 21,126, 0, & 125,0.015D0, 0, 31, 23,126, 0, 0, & 125,0.001D0, 0, 31, 24, 21,126, 0, & 125,0.024D0, 0, 32, 21,126, 0, 0, & 125,0.002D0, 0, 32, 38, 30,126, 0, & 125,0.007D0, 0, 34,126, 0, 0, 0, & 125,0.014D0, 0, 35,126, 0, 0, 0, & 125,0.003D0, 0, 35, 21,126, 0, 0, & 125,0.001D0, 0, 34, 38, 30,126, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/ & 125,0.004D0, 0, 30, 43,126, 0, 0, & 125,0.003D0, 0, 34, 50,126, 0, 0, & 125,0.003D0, 0, 34, 51,126, 0, 0, & 125,0.003D0, 0, 30, 50, 42,126, 0, & 129,0.986D0,100,127,122,130, 0, 0, & 129,0.014D0, 0,127,122,130, 59, 0, & 131,0.178D0,100,127,122,132, 0, 0, & 131,0.171D0,100,129,124,132, 0, 0, & 131,0.002D0, 0,129,124, 59,132, 0, & 131,0.111D0, 0, 38,132, 0, 0, 0, & 131,0.253D0, 0, 39,132, 0, 0, 0, & 131,0.181D0, 0, 40,132, 0, 0, 0, & 131,0.002D0, 0, 38, 22, 21,132, 0, & 131,0.018D0, 0, 38, 24,132, 0, 0, & 131,0.004D0, 0, 38, 24, 21,132, 0, & 131,0.015D0, 0, 39, 23,132, 0, 0, & 131,0.001D0, 0, 39, 24, 21,132, 0, & 131,0.024D0, 0, 40, 21,132, 0, 0, & 131,0.002D0, 0, 40, 38, 30,132, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/ & 131,0.007D0, 0, 46,132, 0, 0, 0, & 131,0.014D0, 0, 47,132, 0, 0, 0, & 131,0.003D0, 0, 47, 21,132, 0, 0, & 131,0.001D0, 0, 46, 38, 30,132, 0, & 131,0.004D0, 0, 38, 51,132, 0, 0, & 131,0.003D0, 0, 46, 42,132, 0, 0, & 131,0.003D0, 0, 46, 43,132, 0, 0, & 131,0.003D0, 0, 38, 50, 42,132, 0, & 136,0.067D0,101,122,127, 42, 0, 0, & 136,0.067D0,101,124,129, 42, 0, 0, & 136,0.048D0,101,122,127, 43, 0, 0, & 136,0.048D0,101,124,129, 43, 0, 0, & 136,0.003D0, 0, 34, 38,122,127, 0, & 136,0.003D0, 0, 34, 38,124,129, 0, & 136,0.006D0,101,122,127, 21, 0, 0, & 136,0.006D0,101,124,129, 21, 0, 0, & 136,0.002D0,101,122,127, 23, 0, 0, & 136,0.002D0,101,124,129, 23, 0, 0, & 136,0.055D0, 0, 34, 38, 38, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/ & 136,0.031D0, 0, 34, 39, 38, 0, 0, & 136,0.042D0, 0, 34, 38, 38, 21, 21, & 136,0.002D0, 0, 34, 38, 38, 38, 31, & 136,0.021D0, 0, 35, 38, 38, 0, 0, & 136,0.027D0, 0, 42, 38, 0, 0, 0, & 136,0.066D0, 0, 42, 39, 0, 0, 0, & 136,0.081D0, 0, 42, 40, 0, 0, 0, & 136,0.024D0, 0, 42, 38, 21, 0, 0, & 136,0.004D0, 0, 42, 38, 23, 0, 0, & 136,0.069D0, 0, 42, 38, 38, 30, 21, & 136,0.001D0, 0, 42, 38, 38, 30, 23, & 136,0.022D0, 0, 43, 38, 0, 0, 0, & 136,0.021D0, 0, 43, 39, 0, 0, 0, & 136,0.042D0, 0, 43, 38, 21, 0, 0, & 136,0.008D0, 0, 43, 38, 23, 0, 0, & 136,0.010D0, 0, 43, 38, 38, 30, 0, & 136,0.050D0, 0,311, 38, 0, 0, 0, & 136,0.034D0, 0,329, 38, 0, 0, 0, & 136,0.010D0, 0,369, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/ & 136,0.031D0, 0, 46, 42, 42, 0, 0, & 136,0.003D0, 0, 38, 21, 0, 0, 0, & 136,0.001D0, 0, 38, 23, 0, 0, 0, & 136,0.002D0, 0, 38, 38, 30, 0, 0, & 136,0.008D0, 0, 38, 22, 0, 0, 0, & 136,0.001D0, 0, 38, 38, 38, 30, 30, & 136,0.003D0, 0, 38, 38, 38, 30, 31, & 136,0.008D0, 0, 46, 42, 0, 0, 0, & 136,0.005D0, 0, 46, 43, 0, 0, 0, & 136,0.026D0, 0, 47, 43, 0, 0, 0, & 136,0.005D0, 0, 46, 34, 38, 0, 0, & 136,0.007D0, 0, 38, 56, 0, 0, 0, & 136,0.023D0, 0, 38, 56, 21, 0, 0, & 136,0.005D0, 0, 46, 46, 34, 0, 0, & 137,0.683D0, 0,140, 38, 0, 0, 0, & 137,0.306D0, 0,136, 21, 0, 0, 0, & 137,0.011D0, 0,136, 59, 0, 0, 0, & 138,0.667D0, 0,141, 38, 0, 0, 0, & 138,0.333D0, 0,137, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/ & 139,0.220D0, 0,140, 38, 0, 0, 0, & 139,0.110D0, 0,136, 21, 0, 0, 0, & 139,0.380D0, 0,141, 38, 0, 0, 0, & 139,0.190D0, 0,137, 21, 0, 0, 0, & 139,0.004D0, 0,136, 22, 0, 0, 0, & 139,0.064D0, 0,141, 38, 21, 0, 0, & 139,0.032D0, 0,137, 38, 30, 0, 0, & 140,0.037D0,101,122,127, 34, 0, 0, & 140,0.037D0,101,124,129, 34, 0, 0, & 140,0.016D0,101,122,127, 35, 0, 0, & 140,0.016D0,101,124,129, 35, 0, 0, & 140,0.013D0, 0, 34, 21,122,127, 0, & 140,0.013D0, 0, 34, 21,124,129, 0, & 140,0.012D0, 0, 42, 30,122,127, 0, & 140,0.012D0, 0, 42, 30,124,129, 0, & 140,0.003D0,101,122,127, 30, 0, 0, & 140,0.003D0,101,124,129, 30, 0, 0, & 140,0.039D0, 0, 34, 38, 0, 0, 0, & 140,0.091D0, 0, 34, 39, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/ & 140,0.067D0, 0, 34, 40, 0, 0, 0, & 140,0.004D0, 0, 34, 38, 21, 0, 0, & 140,0.100D0, 0, 34, 38, 21, 21, 0, & 140,0.058D0, 0, 34, 38, 23, 0, 0, & 140,0.020D0, 0, 34, 38, 24, 0, 0, & 140,0.006D0, 0, 34, 38, 25, 0, 0, & 140,0.043D0, 0, 35, 38, 0, 0, 0, & 140,0.035D0, 0, 35, 39, 0, 0, 0, & 140,0.007D0, 0,312, 38, 0, 0, 0, & 140,0.007D0, 0,330, 38, 0, 0, 0, & 140,0.020D0, 0, 42, 21, 0, 0, 0, & 140,0.006D0, 0, 42, 22, 0, 0, 0, & 140,0.009D0, 0, 42, 23, 0, 0, 0, & 140,0.016D0, 0, 42, 24, 0, 0, 0, & 140,0.014D0, 0, 42, 25, 0, 0, 0, & 140,0.003D0, 0, 42,293, 0, 0, 0, & 140,0.007D0, 0, 42, 56, 0, 0, 0, & 140,0.003D0, 0, 42, 26, 0, 0, 0, & 140,0.004D0, 0, 42,294, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/ & 140,0.006D0, 0, 42, 21, 21, 0, 0, & 140,0.042D0, 0, 42, 38, 30, 21, 0, & 140,0.004D0, 0, 42, 38, 38, 30, 30, & 140,0.076D0, 0, 42, 38, 30, 21, 21, & 140,0.026D0, 0, 43, 21, 0, 0, 0, & 140,0.014D0, 0, 43, 22, 0, 0, 0, & 140,0.014D0, 0, 43, 23, 0, 0, 0, & 140,0.011D0, 0, 43, 24, 0, 0, 0, & 140,0.018D0, 0, 43, 38, 30, 0, 0, & 140,0.004D0, 0, 42, 46, 34, 0, 0, & 140,0.004D0, 0, 42, 46, 34, 21, 0, & 140,0.005D0, 0, 42, 42, 50, 0, 0, & 140,0.002D0, 0, 38, 30, 0, 0, 0, & 140,0.001D0, 0, 21, 21, 0, 0, 0, & 140,0.008D0, 0, 38, 30, 21, 0, 0, & 140,0.007D0, 0, 38, 38, 30, 30, 0, & 140,0.015D0, 0, 38, 38, 30, 30, 21, & 140,0.004D0, 0, 46, 34, 0, 0, 0, & 140,0.003D0, 0, 47, 34, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/ & 140,0.002D0, 0, 46, 35, 0, 0, 0, & 140,0.001D0, 0, 50, 42, 0, 0, 0, & 140,0.002D0, 0, 51, 43, 0, 0, 0, & 140,0.003D0, 0, 50, 34, 38, 0, 0, & 140,0.003D0, 0, 42, 46, 30, 0, 0, & 140,0.001D0, 0, 46, 34, 38, 30, 21, & 140,0.002D0, 0, 56, 23, 0, 0, 0, & 140,0.001D0, 0, 56, 38, 30, 0, 0, & 141,0.636D0, 0,140, 21, 0, 0, 0, & 141,0.364D0, 0,140, 59, 0, 0, 0, & 142,0.667D0, 0,137, 30, 0, 0, 0, & 142,0.333D0, 0,141, 21, 0, 0, 0, & 143,0.220D0, 0,136, 30, 0, 0, 0, & 143,0.110D0, 0,140, 21, 0, 0, 0, & 143,0.380D0, 0,137, 30, 0, 0, 0, & 143,0.190D0, 0,141, 21, 0, 0, 0, & 143,0.004D0, 0,140, 22, 0, 0, 0, & 143,0.064D0, 0,137, 30, 21, 0, 0, & 143,0.032D0, 0,141, 38, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/ & 144,0.009D0, 0,124,129, 0, 0, 0, & 144,0.019D0,101,122,127, 56, 0, 0, & 144,0.019D0,101,124,129, 56, 0, 0, & 144,0.025D0,101,122,127, 22, 0, 0, & 144,0.025D0,101,124,129, 22, 0, 0, & 144,0.009D0,101,122,127, 25, 0, 0, & 144,0.009D0,101,124,129, 25, 0, 0, & 144,0.036D0, 0, 46, 42, 0, 0, 0, & 144,0.034D0, 0, 46, 43, 0, 0, 0, & 144,0.007D0, 0, 46,329, 0, 0, 0, & 144,0.043D0, 0, 47, 42, 0, 0, 0, & 144,0.058D0, 0, 47, 43, 0, 0, 0, & 144,0.011D0, 0, 46, 34, 38, 0, 0, & 144,0.055D0, 0, 46, 34, 38, 21, 0, & 144,0.003D0, 0, 46, 34, 38, 38, 30, & 144,0.014D0, 0, 46, 42, 38, 30, 0, & 144,0.017D0, 0, 50, 34, 38, 38, 0, & 144,0.036D0, 0, 56, 38, 0, 0, 0, & 144,0.067D0, 0, 56, 39, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/ & 144,0.023D0, 0, 56, 38, 21, 0, 0, & 144,0.018D0, 0, 56, 38, 38, 30, 0, & 144,0.020D0, 0, 22, 38, 0, 0, 0, & 144,0.001D0, 0, 23, 38, 0, 0, 0, & 144,0.009D0, 0, 24, 38, 0, 0, 0, & 144,0.049D0, 0, 25, 38, 0, 0, 0, & 144,0.011D0, 0,293, 38, 0, 0, 0, & 144,0.015D0, 0, 22, 38, 21, 0, 0, & 144,0.016D0, 0, 25, 38, 21, 0, 0, & 144,0.103D0, 0, 22, 39, 0, 0, 0, & 144,0.120D0, 0, 25, 39, 0, 0, 0, & 144,0.010D0, 0, 38, 38, 30, 0, 0, & 144,0.046D0, 0, 38, 38, 30, 21, 0, & 144,0.003D0, 0, 38, 38, 38, 30, 30, & 144,0.042D0, 0, 38, 30, 30, 38, 39, & 144,0.001D0, 0, 46, 23, 0, 0, 0, & 144,0.005D0, 0, 46, 38, 30, 0, 0, & 144,0.001D0, 0, 46, 56, 0, 0, 0, & 144,0.004D0, 0, 50, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/ & 144,0.007D0, 0, 51, 38, 0, 0, 0, & 145,0.900D0, 0,144, 59, 0, 0, 0, & 145,0.100D0, 0,144, 21, 0, 0, 0, & 146,0.500D0, 0,137, 50, 0, 0, 0, & 146,0.500D0, 0,141, 46, 0, 0, 0, & 147,0.440D0, 0,136, 50, 0, 0, 0, & 147,0.440D0, 0,140, 46, 0, 0, 0, & 147,0.055D0, 0,137, 50, 0, 0, 0, & 147,0.055D0, 0,141, 46, 0, 0, 0, & 147,0.010D0, 0,144, 22, 0, 0, 0, & 148,1.000D0, 0,150, 38, 0, 0, 0, & 149,1.000D0, 0,150, 38, 0, 0, 0, & 150,0.028D0,101,122,127, 78, 0, 0, & 150,0.010D0,101,122,127, 80, 0, 0, & 150,0.028D0,101,124,129, 78, 0, 0, & 150,0.010D0,101,124,129, 80, 0, 0, & 150,0.026D0, 0, 73, 42, 0, 0, 0, & 150,0.030D0, 0, 73, 42, 21, 0, 0, & 150,0.029D0, 0, 73, 42, 38, 30, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/ & 150,0.014D0, 0, 73, 42, 22, 0, 0, & 150,0.020D0, 0, 73, 43, 0, 0, 0, & 150,0.029D0, 0, 73, 34, 38, 0, 0, & 150,0.039D0, 0, 73, 34, 38, 21, 0, & 150,0.002D0, 0, 73, 34, 38, 38, 30, & 150,0.010D0, 0, 73, 34, 38, 21, 21, & 150,0.014D0, 0, 73, 35, 38, 0, 0, & 150,0.010D0, 0, 74, 42, 0, 0, 0, & 150,0.020D0, 0, 74, 43, 0, 0, 0, & 150,0.010D0, 0, 74, 43, 21, 0, 0, & 150,0.007D0, 0, 85, 34, 0, 0, 0, & 150,0.014D0, 0, 85, 35, 0, 0, 0, & 150,0.004D0, 0, 73,293, 0, 0, 0, & 150,0.003D0, 0, 73, 38, 30, 0, 0, & 150,0.003D0, 0, 73, 38, 30, 38, 30, & 150,0.001D0, 0, 73, 56, 0, 0, 0, & 150,0.002D0, 0, 73, 46, 34, 0, 0, & 150,0.010D0, 0, 78, 38, 0, 0, 0, & 150,0.020D0, 0, 78, 39, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/ & 150,0.030D0, 0, 78, 38, 21, 0, 0, & 150,0.010D0, 0, 78, 38, 22, 0, 0, & 150,0.020D0, 0, 78, 38, 24, 0, 0, & 150,0.035D0, 0, 78, 38, 38, 30, 0, & 150,0.020D0, 0, 78, 38, 21, 21, 0, & 150,0.010D0, 0, 78, 38, 38, 30, 21, & 150,0.010D0, 0, 78, 38, 21, 21, 21, & 150,0.007D0, 0, 78, 46, 42, 0, 0, & 150,0.011D0, 0, 79, 38, 0, 0, 0, & 150,0.022D0, 0, 79, 38, 21, 0, 0, & 150,0.013D0, 0, 79, 38, 38, 30, 0, & 150,0.010D0, 0, 79, 38, 21, 21, 0, & 150,0.007D0, 0, 79, 38, 38, 30, 21, & 150,0.005D0, 0, 79, 38, 21, 21, 21, & 150,0.005D0, 0, 80, 38, 0, 0, 0, & 150,0.015D0, 0, 80, 39, 0, 0, 0, & 150,0.011D0, 0, 86, 21, 0, 0, 0, & 150,0.007D0, 0, 86, 22, 0, 0, 0, & 150,0.010D0, 0, 86, 23, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/ & 150,0.031D0, 0, 86, 24, 0, 0, 0, & 150,0.010D0, 0, 86, 25, 0, 0, 0, & 150,0.004D0, 0, 86, 56, 0, 0, 0, & 150,0.026D0, 0, 86, 38, 30, 0, 0, & 150,0.005D0, 0, 86, 38, 38, 30, 30, & 150,0.005D0, 0, 86, 38, 30, 21, 21, & 150,0.005D0, 0, 87, 21, 0, 0, 0, & 150,0.006D0, 0, 87, 23, 0, 0, 0, & 150,0.004D0, 0, 86, 46, 34, 0, 0, & 150,0.002D0, 0, 86, 46, 30, 0, 0, & 150,0.001D0, 0, 86, 46, 30, 21, 0, & 150,0.016D0, 0, 81, 38, 38, 0, 0, & 150,0.003D0, 0, 88, 46, 0, 0, 0, & 150,0.002D0, 0, 89, 46, 0, 0, 0, & 150,0.003D0, 0, 83, 46, 38, 0, 0, & 150,0.040D0, 0, 75, 46, 21, 0, 0, & 150,0.040D0, 0, 75, 46, 38, 30, 0, & 150,0.020D0, 0, 75, 46, 21, 21, 0, & 150,0.010D0, 0, 75, 46, 38, 30, 21/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/ & 150,0.010D0, 0, 75, 46, 21, 21, 21, & 150,0.020D0, 0, 75, 47, 21, 0, 0, & 150,0.040D0, 0, 75, 42, 38, 0, 0, & 150,0.020D0, 0, 75, 42, 39, 0, 0, & 150,0.010D0, 0, 75, 42, 38, 38, 30, & 150,0.010D0, 0, 75, 42, 38, 21, 21, & 150,0.006D0, 0, 75, 43, 38, 0, 0, & 151,1.000D0, 0,150, 21, 0, 0, 0, & 152,1.000D0, 0,150, 21, 0, 0, 0, & 153,1.000D0, 0,150, 30, 0, 0, 0, & 154,1.000D0, 0,150, 30, 0, 0, 0, & 155,0.045D0,101,122,127, 88, 0, 0, & 155,0.005D0,101,122,127, 89, 0, 0, & 155,0.045D0,101,124,129, 88, 0, 0, & 155,0.005D0,101,124,129, 89, 0, 0, & 155,0.021D0, 0, 86, 42, 0, 0, 0, & 155,0.032D0, 0, 87, 42, 0, 0, 0, & 155,0.032D0, 0, 79, 38, 42, 0, 0, & 155,0.045D0, 0, 86, 43, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/ & 155,0.065D0, 0, 87, 43, 0, 0, 0, & 155,0.065D0, 0, 79, 38, 43, 0, 0, & 155,0.055D0, 0, 88, 38, 0, 0, 0, & 155,0.160D0, 0, 88, 39, 0, 0, 0, & 155,0.105D0, 0, 89, 38, 0, 0, 0, & 155,0.320D0, 0, 89, 39, 0, 0, 0, & 156,1.000D0, 0,155, 59, 0, 0, 0, & 157,0.667D0, 0,158, 38, 0, 0, 0, & 157,0.333D0, 0,155, 21, 0, 0, 0, & 158,0.045D0,101,122,127, 83, 0, 0, & 158,0.045D0,101,124,129, 83, 0, 0, & 158,0.005D0,101,122,127, 84, 0, 0, & 158,0.005D0,101,124,129, 84, 0, 0, & 158,0.020D0, 0, 79, 42, 0, 0, 0, & 158,0.020D0, 0, 79, 21, 42, 0, 0, & 158,0.020D0, 0, 80, 42, 0, 0, 0, & 158,0.060D0, 0, 79, 43, 0, 0, 0, & 158,0.060D0, 0, 79, 21, 43, 0, 0, & 158,0.060D0, 0, 80, 43, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/ & 158,0.020D0, 0, 86, 34, 0, 0, 0, & 158,0.060D0, 0, 86, 35, 0, 0, 0, & 158,0.040D0, 0, 87, 34, 0, 0, 0, & 158,0.120D0, 0, 87, 35, 0, 0, 0, & 158,0.020D0, 0, 83, 38, 0, 0, 0, & 158,0.060D0, 0, 83, 39, 0, 0, 0, & 158,0.040D0, 0, 84, 38, 0, 0, 0, & 158,0.120D0, 0, 84, 39, 0, 0, 0, & 158,0.010D0, 0, 88, 21, 0, 0, 0, & 158,0.030D0, 0, 88, 23, 0, 0, 0, & 158,0.020D0, 0, 89, 21, 0, 0, 0, & 158,0.060D0, 0, 89, 23, 0, 0, 0, & 158,0.030D0, 0, 88, 56, 0, 0, 0, & 158,0.030D0, 0, 90, 46, 0, 0, 0, & 159,1.000D0, 0,158, 59, 0, 0, 0, & 160,0.670D0, 0,155, 30, 0, 0, 0, & 160,0.330D0, 0,158, 21, 0, 0, 0, & 161,0.050D0,101,122,127, 90, 0, 0, & 161,0.050D0,101,124,129, 90, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/ & 161,0.075D0, 0, 88, 42, 0, 0, 0, & 161,0.225D0, 0, 88, 43, 0, 0, 0, & 161,0.150D0, 0, 89, 42, 0, 0, 0, & 161,0.450D0, 0, 89, 43, 0, 0, 0, & 162,1.000D0, 0,161, 59, 0, 0, 0, & 163,0.028D0, 0, 25, 38, 30, 0, 0, & 163,0.014D0, 0, 25, 21, 21, 0, 0, & 163,0.018D0, 0, 39, 31, 0, 0, 0, & 163,0.009D0, 0, 23, 23, 0, 0, 0, & 163,0.010D0, 0, 51, 34, 38, 0, 0, & 163,0.010D0, 0, 43, 47, 30, 0, 0, & 163,0.004D0, 0, 51, 43, 0, 0, 0, & 163,0.004D0, 0, 47, 35, 0, 0, 0, & 163,0.007D0, 0, 56, 56, 0, 0, 0, & 163,0.022D0, 0, 46, 42, 30, 0, 0, & 163,0.011D0, 0, 46, 34, 21, 0, 0, & 163,0.011D0, 0, 50, 42, 21, 0, 0, & 163,0.022D0, 0, 50, 34, 38, 0, 0, & 163,0.032D0, 0, 22, 38, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/ & 163,0.016D0, 0, 22, 21, 21, 0, 0, & 163,0.020D0, 0, 38, 30, 46, 34, 0, & 163,0.012D0, 0, 38, 30, 38, 30, 0, & 163,0.001D0, 0, 73, 91, 0, 0, 0, & 163,0.001D0, 0, 59, 59, 0, 0, 0, & 163,0.748D0, 0, 13, 13, 0, 0, 0, & 164,0.060D0, 0,121,127, 0, 0, 0, & 164,0.060D0, 0,123,129, 0, 0, 0, & 164,0.004D0, 0, 39, 30, 0, 0, 0, & 164,0.004D0, 0, 23, 21, 0, 0, 0, & 164,0.004D0, 0, 31, 38, 0, 0, 0, & 164,0.003D0, 0, 41, 31, 0, 0, 0, & 164,0.003D0, 0, 29, 23, 0, 0, 0, & 164,0.003D0, 0, 33, 39, 0, 0, 0, & 164,0.009D0, 0, 24, 38, 38, 30, 30, & 164,0.007D0, 0, 24, 38, 30, 0, 0, & 164,0.003D0, 0, 51, 45, 0, 0, 0, & 164,0.003D0, 0, 43, 53, 0, 0, 0, & 164,0.003D0, 0, 24, 51, 42, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/ & 164,0.003D0, 0, 24, 43, 50, 0, 0, & 164,0.004D0, 0, 24, 26, 0, 0, 0, & 164,0.003D0, 0, 46, 35, 0, 0, 0, & 164,0.003D0, 0, 34, 47, 0, 0, 0, & 164,0.002D0, 0, 50, 43, 0, 0, 0, & 164,0.002D0, 0, 42, 51, 0, 0, 0, & 164,0.003D0, 0, 24, 21, 21, 0, 0, & 164,0.002D0, 0,286, 30, 0, 0, 0, & 164,0.002D0, 0,287, 38, 0, 0, 0, & 164,0.003D0, 0, 24, 46, 42, 30, 0, & 164,0.003D0, 0, 24, 34, 50, 38, 0, & 164,0.002D0, 0,285, 21, 0, 0, 0, & 164,0.001D0, 0, 56, 51, 42, 0, 0, & 164,0.001D0, 0, 56, 43, 50, 0, 0, & 164,0.001D0, 0, 24, 50, 42, 0, 0, & 164,0.001D0, 0, 24, 46, 34, 0, 0, & 164,0.002D0, 0, 56, 38, 30, 38, 30, & 164,0.002D0, 0, 85, 91, 30, 0, 0, & 164,0.002D0, 0,103, 73, 38, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/ & 164,0.002D0, 0, 24, 22, 0, 0, 0, & 164,0.001D0, 0, 56, 50, 42, 0, 0, & 164,0.001D0, 0, 56, 46, 34, 0, 0, & 164,0.001D0, 0, 73, 91, 24, 0, 0, & 164,0.001D0, 0, 85,103, 0, 0, 0, & 164,0.001D0, 0, 82,100, 0, 0, 0, & 164,0.001D0, 0, 87,105, 0, 0, 0, & 164,0.001D0, 0, 73, 91, 25, 0, 0, & 164,0.001D0, 0, 56, 58, 0, 0, 0, & 164,0.001D0, 0, 56, 38, 30, 0, 0, & 164,0.001D0, 0, 56, 46, 42, 30, 0, & 164,0.001D0, 0, 56, 34, 50, 38, 0, & 164,0.001D0, 0, 56, 22, 0, 0, 0, & 164,0.001D0, 0, 84,102, 0, 0, 0, & 164,0.001D0, 0, 73, 34, 98, 0, 0, & 164,0.001D0, 0, 91, 46, 80, 0, 0, & 164,0.034D0, 0, 38, 38, 30, 30, 21, & 164,0.029D0, 0, 23, 23, 23, 21, 0, & 164,0.015D0, 0, 38, 30, 21, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/ & 164,0.012D0, 0, 38, 30, 21, 34, 46, & 164,0.009D0, 0, 23, 23, 23, 24, 0, & 164,0.007D0, 0, 38, 30, 34, 46, 0, & 164,0.002D0, 0, 46, 42, 30, 0, 0, & 164,0.001D0, 0, 46, 34, 21, 0, 0, & 164,0.001D0, 0, 50, 42, 21, 0, 0, & 164,0.002D0, 0, 50, 34, 38, 0, 0, & 164,0.006D0, 0, 73, 91, 38, 30, 0, & 164,0.004D0, 0, 38, 30, 38, 30, 0, & 164,0.004D0, 0, 38, 30, 38, 30, 23, & 164,0.004D0, 0, 75, 93, 38, 30, 0, & 164,0.001D0, 0, 86,104, 0, 0, 0, & 164,0.001D0, 0, 79, 97, 0, 0, 0, & 164,0.001D0, 0, 81, 99, 0, 0, 0, & 164,0.003D0, 0, 23, 23, 34, 46, 0, & 164,0.002D0, 0, 73, 91, 38, 30, 21, & 164,0.002D0, 0, 73, 91, 0, 0, 0, & 164,0.002D0, 0, 73, 91, 22, 0, 0, & 164,0.002D0, 0, 73, 93, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/ & 164,0.002D0, 0, 75, 93, 0, 0, 0, & 164,0.001D0, 0, 83,102, 0, 0, 0, & 164,0.001D0, 0, 88,106, 0, 0, 0, & 164,0.001D0, 0, 78, 96, 0, 0, 0, & 164,0.001D0, 0, 73, 91, 21, 0, 0, & 164,0.001D0, 0, 78,104, 38, 0, 0, & 164,0.001D0, 0, 96, 86, 30, 0, 0, & 164,0.001D0, 0, 73, 34, 96, 0, 0, & 164,0.001D0, 0, 91, 46, 78, 0, 0, & 164,0.001D0, 0, 46, 34, 46, 34, 0, & 164,0.013D0, 0, 59,163, 0, 0, 0, & 164,0.008D0, 0, 59, 38, 30, 21, 21, & 164,0.004D0, 0, 59, 22, 38, 30, 0, & 164,0.002D0, 0, 59, 22, 21, 21, 0, & 164,0.003D0, 0, 59, 39, 31, 0, 0, & 164,0.002D0, 0, 59, 23, 23, 0, 0, & 164,0.004D0, 0, 59, 25, 0, 0, 0, & 164,0.003D0, 0, 59, 38, 30, 38, 30, & 164,0.002D0, 0, 59, 24, 24, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/ & 164,0.001D0, 0, 59, 26, 0, 0, 0, & 164,0.001D0, 0, 59, 22, 0, 0, 0, & 164,0.001D0, 0, 59, 28, 0, 0, 0, & 164,0.001D0, 0, 59, 58, 0, 0, 0, & 164,0.020D0, 0, 1, 7, 0, 0, 0, & 164,0.080D0, 0, 2, 8, 0, 0, 0, & 164,0.020D0, 0, 3, 9, 0, 0, 0, & 164,0.364D0,130, 13, 13, 13, 0, 0, & 164,0.091D0,130, 13, 13, 59, 0, 0, & 165,0.037D0, 0, 38, 30, 38, 30, 0, & 165,0.030D0, 0, 38, 30, 46, 34, 0, & 165,0.016D0, 0, 23, 38, 30, 0, 0, & 165,0.015D0, 0, 23, 38, 30, 38, 30, & 165,0.004D0, 0, 46, 43, 30, 0, 0, & 165,0.002D0, 0, 46, 35, 21, 0, 0, & 165,0.002D0, 0, 51, 43, 21, 0, 0, & 165,0.004D0, 0, 51, 35, 38, 0, 0, & 165,0.008D0, 0, 38, 30, 0, 0, 0, & 165,0.007D0, 0, 46, 34, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/ & 165,0.005D0, 0, 38, 30, 73, 91, 0, & 165,0.003D0, 0, 21, 21, 0, 0, 0, & 165,0.003D0, 0, 22, 22, 0, 0, 0, & 165,0.007D0, 0, 59,164, 0, 0, 0, & 165,0.857D0, 0, 13, 13, 0, 0, 0, & 166,0.008D0, 0,121,127, 0, 0, 0, & 166,0.008D0, 0,123,129, 0, 0, 0, & 166,0.001D0, 0,125,131, 0, 0, 0, & 166,0.338D0, 0,164, 38, 30, 0, 0, & 166,0.169D0, 0,164, 21, 21, 0, 0, & 166,0.027D0, 0,164, 22, 0, 0, 0, & 166,0.001D0, 0,164, 21, 0, 0, 0, & 166,0.004D0, 0, 23, 23, 23, 21, 0, & 166,0.003D0, 0, 23, 23, 21, 0, 0, & 166,0.002D0, 0, 38, 30, 46, 34, 0, & 166,0.001D0, 0, 38, 30, 73, 91, 0, & 166,0.093D0, 0, 59,165, 0, 0, 0, & 166,0.087D0, 0, 59,302, 0, 0, 0, & 166,0.078D0, 0, 59,303, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/ & 166,0.003D0, 0, 59,163, 0, 0, 0, & 166,0.003D0, 0, 1, 7, 0, 0, 0, & 166,0.012D0, 0, 2, 8, 0, 0, 0, & 166,0.003D0, 0, 3, 9, 0, 0, 0, & 166,0.127D0,130, 13, 13, 13, 0, 0, & 166,0.032D0,130, 13, 13, 59, 0, 0, & 167,0.500D0, 0,136,171, 0, 0, 0, & 167,0.500D0, 0,140,175, 0, 0, 0, & 171,0.067D0,101,128,121, 50, 0, 0, & 171,0.067D0,101,130,123, 50, 0, 0, & 171,0.048D0,101,128,121, 51, 0, 0, & 171,0.048D0,101,130,123, 51, 0, 0, & 171,0.003D0, 0,128,121, 46, 30, 0, & 171,0.003D0, 0,130,123, 46, 30, 0, & 171,0.006D0,101,128,121, 21, 0, 0, & 171,0.006D0,101,130,123, 21, 0, 0, & 171,0.002D0,101,128,121, 23, 0, 0, & 171,0.002D0,101,130,123, 23, 0, 0, & 171,0.055D0, 0, 46, 30, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/ & 171,0.031D0, 0, 46, 31, 30, 0, 0, & 171,0.042D0, 0, 46, 30, 30, 21, 21, & 171,0.002D0, 0, 46, 30, 30, 30, 39, & 171,0.021D0, 0, 47, 30, 30, 0, 0, & 171,0.027D0, 0, 50, 30, 0, 0, 0, & 171,0.066D0, 0, 50, 31, 0, 0, 0, & 171,0.081D0, 0, 50, 32, 0, 0, 0, & 171,0.024D0, 0, 50, 30, 21, 0, 0, & 171,0.004D0, 0, 50, 30, 23, 0, 0, & 171,0.069D0, 0, 50, 30, 30, 38, 21, & 171,0.001D0, 0, 50, 30, 30, 38, 23, & 171,0.022D0, 0, 51, 30, 0, 0, 0, & 171,0.021D0, 0, 51, 31, 0, 0, 0, & 171,0.042D0, 0, 51, 30, 21, 0, 0, & 171,0.008D0, 0, 51, 30, 23, 0, 0, & 171,0.010D0, 0, 51, 30, 30, 38, 0, & 171,0.050D0, 0,309, 30, 0, 0, 0, & 171,0.034D0, 0,328, 30, 0, 0, 0, & 171,0.010D0, 0,368, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/ & 171,0.031D0, 0, 34, 50, 50, 0, 0, & 171,0.003D0, 0, 30, 21, 0, 0, 0, & 171,0.001D0, 0, 30, 23, 0, 0, 0, & 171,0.002D0, 0, 30, 30, 38, 0, 0, & 171,0.008D0, 0, 30, 22, 0, 0, 0, & 171,0.001D0, 0, 30, 30, 30, 38, 38, & 171,0.003D0, 0, 30, 30, 30, 38, 39, & 171,0.008D0, 0, 34, 50, 0, 0, 0, & 171,0.005D0, 0, 34, 51, 0, 0, 0, & 171,0.026D0, 0, 35, 51, 0, 0, 0, & 171,0.005D0, 0, 34, 46, 30, 0, 0, & 171,0.007D0, 0, 30, 56, 0, 0, 0, & 171,0.023D0, 0, 30, 56, 21, 0, 0, & 171,0.005D0, 0, 34, 34, 46, 0, 0, & 172,0.683D0, 0,175, 30, 0, 0, 0, & 172,0.306D0, 0,171, 21, 0, 0, 0, & 172,0.011D0, 0,171, 59, 0, 0, 0, & 173,0.667D0, 0,176, 30, 0, 0, 0, & 173,0.333D0, 0,172, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/ & 174,0.220D0, 0,175, 30, 0, 0, 0, & 174,0.110D0, 0,171, 21, 0, 0, 0, & 174,0.380D0, 0,176, 30, 0, 0, 0, & 174,0.190D0, 0,172, 21, 0, 0, 0, & 174,0.004D0, 0,171, 22, 0, 0, 0, & 174,0.064D0, 0,176, 30, 21, 0, 0, & 174,0.032D0, 0,172, 38, 30, 0, 0, & 175,0.037D0,101,128,121, 46, 0, 0, & 175,0.037D0,101,130,123, 46, 0, 0, & 175,0.016D0,101,128,121, 47, 0, 0, & 175,0.016D0,101,130,123, 47, 0, 0, & 175,0.013D0, 0,128,121, 46, 21, 0, & 175,0.013D0, 0,130,123, 46, 21, 0, & 175,0.012D0, 0,128,121, 50, 38, 0, & 175,0.012D0, 0,130,123, 50, 38, 0, & 175,0.003D0,101,128,121, 38, 0, 0, & 175,0.003D0,101,130,123, 38, 0, 0, & 175,0.039D0, 0, 46, 30, 0, 0, 0, & 175,0.091D0, 0, 46, 31, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/ & 175,0.067D0, 0, 46, 32, 0, 0, 0, & 175,0.004D0, 0, 46, 30, 21, 0, 0, & 175,0.100D0, 0, 46, 30, 21, 21, 0, & 175,0.058D0, 0, 46, 30, 23, 0, 0, & 175,0.020D0, 0, 46, 30, 24, 0, 0, & 175,0.006D0, 0, 46, 30, 25, 0, 0, & 175,0.043D0, 0, 47, 30, 0, 0, 0, & 175,0.035D0, 0, 47, 31, 0, 0, 0, & 175,0.007D0, 0,310, 30, 0, 0, 0, & 175,0.007D0, 0,327, 30, 0, 0, 0, & 175,0.020D0, 0, 50, 21, 0, 0, 0, & 175,0.006D0, 0, 50, 22, 0, 0, 0, & 175,0.009D0, 0, 50, 23, 0, 0, 0, & 175,0.016D0, 0, 50, 24, 0, 0, 0, & 175,0.014D0, 0, 50, 25, 0, 0, 0, & 175,0.003D0, 0, 50,293, 0, 0, 0, & 175,0.007D0, 0, 50, 56, 0, 0, 0, & 175,0.003D0, 0, 50, 26, 0, 0, 0, & 175,0.004D0, 0, 50,294, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/ & 175,0.006D0, 0, 50, 21, 21, 0, 0, & 175,0.042D0, 0, 50, 30, 38, 21, 0, & 175,0.004D0, 0, 50, 30, 30, 38, 38, & 175,0.076D0, 0, 50, 30, 38, 21, 21, & 175,0.026D0, 0, 51, 21, 0, 0, 0, & 175,0.014D0, 0, 51, 22, 0, 0, 0, & 175,0.014D0, 0, 51, 23, 0, 0, 0, & 175,0.011D0, 0, 51, 24, 0, 0, 0, & 175,0.018D0, 0, 51, 30, 38, 0, 0, & 175,0.004D0, 0, 50, 34, 46, 0, 0, & 175,0.004D0, 0, 50, 34, 46, 21, 0, & 175,0.005D0, 0, 50, 50, 42, 0, 0, & 175,0.002D0, 0, 30, 38, 0, 0, 0, & 175,0.001D0, 0, 21, 21, 0, 0, 0, & 175,0.008D0, 0, 30, 38, 21, 0, 0, & 175,0.007D0, 0, 30, 30, 38, 38, 0, & 175,0.015D0, 0, 30, 30, 38, 38, 21, & 175,0.004D0, 0, 34, 46, 0, 0, 0, & 175,0.003D0, 0, 35, 46, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/ & 175,0.002D0, 0, 34, 47, 0, 0, 0, & 175,0.001D0, 0, 42, 50, 0, 0, 0, & 175,0.002D0, 0, 43, 51, 0, 0, 0, & 175,0.003D0, 0, 42, 46, 30, 0, 0, & 175,0.003D0, 0, 50, 34, 38, 0, 0, & 175,0.001D0, 0, 34, 46, 30, 38, 21, & 175,0.002D0, 0, 56, 23, 0, 0, 0, & 175,0.001D0, 0, 56, 30, 38, 0, 0, & 176,0.636D0, 0,175, 21, 0, 0, 0, & 176,0.364D0, 0,175, 59, 0, 0, 0, & 177,0.667D0, 0,172, 38, 0, 0, 0, & 177,0.333D0, 0,176, 21, 0, 0, 0, & 178,0.220D0, 0,171, 38, 0, 0, 0, & 178,0.110D0, 0,175, 21, 0, 0, 0, & 178,0.380D0, 0,172, 38, 0, 0, 0, & 178,0.190D0, 0,176, 21, 0, 0, 0, & 178,0.004D0, 0,175, 22, 0, 0, 0, & 178,0.064D0, 0,172, 38, 21, 0, 0, & 178,0.032D0, 0,176, 38, 30, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/ & 179,0.009D0, 0,130,123, 0, 0, 0, & 179,0.019D0,101,128,121, 56, 0, 0, & 179,0.019D0,101,130,123, 56, 0, 0, & 179,0.025D0,101,128,121, 22, 0, 0, & 179,0.025D0,101,130,123, 22, 0, 0, & 179,0.009D0,101,128,121, 25, 0, 0, & 179,0.009D0,101,130,123, 25, 0, 0, & 179,0.036D0, 0, 34, 50, 0, 0, 0, & 179,0.034D0, 0, 34, 51, 0, 0, 0, & 179,0.007D0, 0, 34,328, 0, 0, 0, & 179,0.043D0, 0, 35, 50, 0, 0, 0, & 179,0.058D0, 0, 35, 51, 0, 0, 0, & 179,0.011D0, 0, 34, 46, 30, 0, 0, & 179,0.055D0, 0, 34, 46, 30, 21, 0, & 179,0.003D0, 0, 34, 46, 30, 38, 30, & 179,0.014D0, 0, 34, 50, 38, 30, 0, & 179,0.017D0, 0, 42, 46, 30, 30, 0, & 179,0.036D0, 0, 56, 30, 0, 0, 0, & 179,0.067D0, 0, 56, 31, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/ & 179,0.023D0, 0, 56, 30, 21, 0, 0, & 179,0.018D0, 0, 56, 30, 38, 30, 0, & 179,0.020D0, 0, 22, 30, 0, 0, 0, & 179,0.001D0, 0, 23, 30, 0, 0, 0, & 179,0.009D0, 0, 24, 30, 0, 0, 0, & 179,0.049D0, 0, 25, 30, 0, 0, 0, & 179,0.011D0, 0,293, 30, 0, 0, 0, & 179,0.015D0, 0, 22, 30, 21, 0, 0, & 179,0.016D0, 0, 25, 30, 21, 0, 0, & 179,0.103D0, 0, 22, 31, 0, 0, 0, & 179,0.120D0, 0, 25, 31, 0, 0, 0, & 179,0.010D0, 0, 30, 38, 30, 0, 0, & 179,0.046D0, 0, 30, 38, 30, 21, 0, & 179,0.003D0, 0, 30, 38, 38, 30, 30, & 179,0.042D0, 0, 30, 38, 38, 30, 31, & 179,0.001D0, 0, 34, 23, 0, 0, 0, & 179,0.005D0, 0, 34, 38, 30, 0, 0, & 179,0.001D0, 0, 34, 56, 0, 0, 0, & 179,0.004D0, 0, 42, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/ & 179,0.007D0, 0, 43, 30, 0, 0, 0, & 180,0.900D0, 0,179, 59, 0, 0, 0, & 180,0.100D0, 0,179, 21, 0, 0, 0, & 181,0.500D0, 0,172, 42, 0, 0, 0, & 181,0.500D0, 0,176, 34, 0, 0, 0, & 182,0.440D0, 0,171, 42, 0, 0, 0, & 182,0.440D0, 0,175, 34, 0, 0, 0, & 182,0.055D0, 0,172, 42, 0, 0, 0, & 182,0.055D0, 0,176, 34, 0, 0, 0, & 182,0.010D0, 0,179, 22, 0, 0, 0, & 183,1.000D0, 0,185, 30, 0, 0, 0, & 184,1.000D0, 0,185, 30, 0, 0, 0, & 185,0.028D0,101,128,121, 96, 0, 0, & 185,0.010D0,101,128,121, 98, 0, 0, & 185,0.028D0,101,130,123, 96, 0, 0, & 185,0.010D0,101,130,123, 98, 0, 0, & 185,0.026D0, 0, 91, 50, 0, 0, 0, & 185,0.030D0, 0, 91, 50, 21, 0, 0, & 185,0.029D0, 0, 91, 50, 38, 30, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/ & 185,0.014D0, 0, 91, 50, 22, 0, 0, & 185,0.020D0, 0, 91, 51, 0, 0, 0, & 185,0.029D0, 0, 91, 46, 30, 0, 0, & 185,0.039D0, 0, 91, 46, 30, 21, 0, & 185,0.002D0, 0, 91, 46, 30, 30, 38, & 185,0.010D0, 0, 91, 46, 30, 21, 21, & 185,0.014D0, 0, 91, 47, 30, 0, 0, & 185,0.010D0, 0, 92, 50, 0, 0, 0, & 185,0.020D0, 0, 92, 51, 0, 0, 0, & 185,0.010D0, 0, 92, 51, 21, 0, 0, & 185,0.007D0, 0,103, 46, 0, 0, 0, & 185,0.014D0, 0,103, 47, 0, 0, 0, & 185,0.004D0, 0, 91,293, 0, 0, 0, & 185,0.003D0, 0, 91, 38, 30, 0, 0, & 185,0.003D0, 0, 91, 38, 30, 38, 30, & 185,0.001D0, 0, 91, 56, 0, 0, 0, & 185,0.002D0, 0, 91, 46, 34, 0, 0, & 185,0.010D0, 0, 96, 30, 0, 0, 0, & 185,0.020D0, 0, 96, 31, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/ & 185,0.030D0, 0, 96, 30, 21, 0, 0, & 185,0.010D0, 0, 96, 30, 22, 0, 0, & 185,0.020D0, 0, 96, 30, 24, 0, 0, & 185,0.035D0, 0, 96, 30, 30, 38, 0, & 185,0.020D0, 0, 96, 30, 21, 21, 0, & 185,0.010D0, 0, 96, 30, 38, 30, 21, & 185,0.010D0, 0, 96, 30, 21, 21, 21, & 185,0.007D0, 0, 96, 34, 50, 0, 0, & 185,0.011D0, 0, 97, 30, 0, 0, 0, & 185,0.022D0, 0, 97, 30, 21, 0, 0, & 185,0.013D0, 0, 97, 30, 38, 30, 0, & 185,0.010D0, 0, 97, 30, 21, 21, 0, & 185,0.007D0, 0, 97, 30, 38, 30, 21, & 185,0.005D0, 0, 97, 30, 21, 21, 21, & 185,0.005D0, 0, 98, 30, 0, 0, 0, & 185,0.015D0, 0, 98, 31, 0, 0, 0, & 185,0.011D0, 0,104, 21, 0, 0, 0, & 185,0.007D0, 0,104, 22, 0, 0, 0, & 185,0.010D0, 0,104, 23, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/ & 185,0.031D0, 0,104, 24, 0, 0, 0, & 185,0.010D0, 0,104, 25, 0, 0, 0, & 185,0.004D0, 0,104, 56, 0, 0, 0, & 185,0.026D0, 0,104, 38, 30, 0, 0, & 185,0.005D0, 0,104, 38, 38, 30, 30, & 185,0.005D0, 0,104, 38, 30, 21, 21, & 185,0.005D0, 0,105, 21, 0, 0, 0, & 185,0.006D0, 0,105, 23, 0, 0, 0, & 185,0.004D0, 0,104, 46, 34, 0, 0, & 185,0.002D0, 0,104, 34, 38, 0, 0, & 185,0.001D0, 0,104, 34, 38, 21, 0, & 185,0.016D0, 0, 99, 30, 30, 0, 0, & 185,0.003D0, 0,106, 34, 0, 0, 0, & 185,0.002D0, 0,107, 34, 0, 0, 0, & 185,0.003D0, 0,101, 34, 30, 0, 0, & 185,0.040D0, 0, 93, 34, 21, 0, 0, & 185,0.040D0, 0, 93, 34, 38, 30, 0, & 185,0.020D0, 0, 93, 34, 21, 21, 0, & 185,0.010D0, 0, 93, 34, 38, 30, 21/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/ & 185,0.010D0, 0, 93, 34, 21, 21, 21, & 185,0.020D0, 0, 93, 35, 21, 0, 0, & 185,0.040D0, 0, 93, 50, 30, 0, 0, & 185,0.020D0, 0, 93, 50, 31, 0, 0, & 185,0.010D0, 0, 93, 50, 30, 38, 30, & 185,0.010D0, 0, 93, 50, 30, 21, 21, & 185,0.006D0, 0, 93, 51, 30, 0, 0, & 186,1.000D0, 0,185, 21, 0, 0, 0, & 187,1.000D0, 0,185, 21, 0, 0, 0, & 188,1.000D0, 0,185, 38, 0, 0, 0, & 189,1.000D0, 0,185, 38, 0, 0, 0, & 190,0.045D0,101,128,121,106, 0, 0, & 190,0.005D0,101,128,121,107, 0, 0, & 190,0.045D0,101,130,123,106, 0, 0, & 190,0.005D0,101,130,123,107, 0, 0, & 190,0.021D0, 0,104, 50, 0, 0, 0, & 190,0.032D0, 0,105, 50, 0, 0, 0, & 190,0.032D0, 0, 97, 30, 50, 0, 0, & 190,0.045D0, 0,104, 51, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/ & 190,0.065D0, 0,105, 51, 0, 0, 0, & 190,0.065D0, 0, 97, 30, 51, 0, 0, & 190,0.055D0, 0,106, 30, 0, 0, 0, & 190,0.160D0, 0,106, 31, 0, 0, 0, & 190,0.105D0, 0,107, 30, 0, 0, 0, & 190,0.320D0, 0,107, 31, 0, 0, 0, & 191,1.000D0, 0,190, 59, 0, 0, 0, & 192,0.667D0, 0,193, 30, 0, 0, 0, & 192,0.333D0, 0,190, 21, 0, 0, 0, & 193,0.045D0,101,128,121,101, 0, 0, & 193,0.045D0,101,130,123,101, 0, 0, & 193,0.005D0,101,128,121,102, 0, 0, & 193,0.005D0,101,130,123,102, 0, 0, & 193,0.020D0, 0, 97, 50, 0, 0, 0, & 193,0.020D0, 0, 97, 21, 50, 0, 0, & 193,0.020D0, 0, 98, 50, 0, 0, 0, & 193,0.060D0, 0, 97, 51, 0, 0, 0, & 193,0.060D0, 0, 97, 21, 51, 0, 0, & 193,0.060D0, 0, 98, 51, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/ & 193,0.020D0, 0,104, 46, 0, 0, 0, & 193,0.060D0, 0,104, 47, 0, 0, 0, & 193,0.040D0, 0,105, 46, 0, 0, 0, & 193,0.120D0, 0,105, 47, 0, 0, 0, & 193,0.020D0, 0,101, 30, 0, 0, 0, & 193,0.060D0, 0,101, 31, 0, 0, 0, & 193,0.040D0, 0,102, 30, 0, 0, 0, & 193,0.120D0, 0,102, 31, 0, 0, 0, & 193,0.010D0, 0,106, 21, 0, 0, 0, & 193,0.030D0, 0,106, 23, 0, 0, 0, & 193,0.020D0, 0,107, 21, 0, 0, 0, & 193,0.060D0, 0,107, 23, 0, 0, 0, & 193,0.030D0, 0,106, 56, 0, 0, 0, & 193,0.030D0, 0,108, 34, 0, 0, 0, & 194,1.000D0, 0,193, 59, 0, 0, 0, & 195,0.670D0, 0,190, 38, 0, 0, 0, & 195,0.330D0, 0,193, 21, 0, 0, 0, & 196,0.050D0,101,128,121,108, 0, 0, & 196,0.050D0,101,130,123,108, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/ & 196,0.075D0, 0,106, 50, 0, 0, 0, & 196,0.225D0, 0,106, 51, 0, 0, 0, & 196,0.150D0, 0,107, 50, 0, 0, 0, & 196,0.450D0, 0,107, 51, 0, 0, 0, & 197,1.000D0, 0,196, 59, 0, 0, 0, & 209,0.250D0,100, 1, 8, 4, 0, 0, & 209,0.250D0,100, 3, 10, 4, 0, 0, & 209,0.250D0,100, 5, 12, 4, 0, 0, & 209,0.085D0,100,121,128, 4, 0, 0, & 209,0.085D0,100,123,130, 4, 0, 0, & 209,0.080D0,100,125,132, 4, 0, 0, & 210,0.250D0,100, 2, 7,209, 0, 0, & 210,0.250D0,100, 4, 9,209, 0, 0, & 210,0.250D0,100, 6, 11,209, 0, 0, & 210,0.085D0,100,122,127,209, 0, 0, & 210,0.085D0,100,124,129,209, 0, 0, & 210,0.080D0,100,126,131,209, 0, 0, & 211,0.250D0,100, 1, 8, 6, 0, 0, & 211,0.250D0,100, 3, 10, 6, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/ & 211,0.250D0,100, 5, 12, 6, 0, 0, & 211,0.085D0,100,121,128, 6, 0, 0, & 211,0.085D0,100,123,130, 6, 0, 0, & 211,0.080D0,100,125,132, 6, 0, 0, & 212,0.250D0,100, 2, 7,211, 0, 0, & 212,0.250D0,100, 4, 9,211, 0, 0, & 212,0.250D0,100, 6, 11,211, 0, 0, & 212,0.085D0,100,122,127,211, 0, 0, & 212,0.085D0,100,124,129,211, 0, 0, & 212,0.080D0,100,126,131,211, 0, 0, & 215,0.250D0,100, 7, 2, 10, 0, 0, & 215,0.250D0,100, 9, 4, 10, 0, 0, & 215,0.250D0,100, 11, 6, 10, 0, 0, & 215,0.085D0,100,127,122, 10, 0, 0, & 215,0.085D0,100,129,124, 10, 0, 0, & 215,0.080D0,100,131,126, 10, 0, 0, & 216,0.250D0,100, 8, 1,215, 0, 0, & 216,0.250D0,100, 10, 3,215, 0, 0, & 216,0.250D0,100, 12, 5,215, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/ & 216,0.085D0,100,128,121,215, 0, 0, & 216,0.085D0,100,130,123,215, 0, 0, & 216,0.080D0,100,132,125,215, 0, 0, & 217,0.250D0,100, 7, 2, 12, 0, 0, & 217,0.250D0,100, 9, 4, 12, 0, 0, & 217,0.250D0,100, 11, 6, 12, 0, 0, & 217,0.085D0,100,127,122, 12, 0, 0, & 217,0.085D0,100,129,124, 12, 0, 0, & 217,0.080D0,100,131,126, 12, 0, 0, & 218,0.250D0,100, 8, 1,217, 0, 0, & 218,0.250D0,100, 10, 3,217, 0, 0, & 218,0.250D0,100, 12, 5,217, 0, 0, & 218,0.085D0,100,128,121,217, 0, 0, & 218,0.085D0,100,130,123,217, 0, 0, & 218,0.080D0,100,132,125,217, 0, 0, & 221,0.016D0,101,121,128,136, 0, 0, & 221,0.016D0,101,123,130,136, 0, 0, & 221,0.008D0,101,125,132,136, 0, 0, & 221,0.048D0,101,121,128,137, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/ & 221,0.048D0,101,123,130,137, 0, 0, & 221,0.022D0,101,125,132,137, 0, 0, & 221,0.003D0,101,121,128,331, 0, 0, & 221,0.003D0,101,123,130,331, 0, 0, & 221,0.001D0,101,125,132,331, 0, 0, & 221,0.008D0,101,121,128,138, 0, 0, & 221,0.008D0,101,123,130,138, 0, 0, & 221,0.004D0,101,125,132,138, 0, 0, & 221,0.008D0,101,121,128,313, 0, 0, & 221,0.008D0,101,123,130,313, 0, 0, & 221,0.004D0,101,125,132,313, 0, 0, & 221,0.013D0,101,121,128,139, 0, 0, & 221,0.013D0,101,123,130,139, 0, 0, & 221,0.006D0,101,125,132,139, 0, 0, & 221,0.004D0, 0,136, 30, 0, 0, 0, & 221,0.010D0, 0,136, 31, 0, 0, 0, & 221,0.006D0, 0,136, 32, 0, 0, 0, & 221,0.003D0, 0,137, 30, 0, 0, 0, & 221,0.009D0, 0,137, 31, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/ & 221,0.017D0, 0,137, 32, 0, 0, 0, & 221,0.011D0, 0,136,179, 0, 0, 0, & 221,0.015D0, 0,136,180, 0, 0, 0, & 221,0.011D0, 0,137,179, 0, 0, 0, & 221,0.022D0, 0,137,180, 0, 0, 0, & 221,0.001D0, 0,164, 42, 0, 0, 0, & 221,0.002D0, 0,164, 43, 0, 0, 0, & 221,0.001D0, 0,165, 42, 0, 0, 0, & 221,0.001D0, 0,165, 43, 0, 0, 0, & 221,0.001D0, 0,166, 42, 0, 0, 0, & 221,0.001D0, 0,166, 43, 0, 0, 0, & 221,0.207D0,100, 1, 8, 4, 7, 0, & 221,0.207D0,100, 3, 10, 4, 7, 0, & 221,0.024D0,100, 1, 8, 2, 7, 0, & 221,0.024D0,100, 3, 10, 2, 7, 0, & 221,0.012D0,100, 3, 8, 4, 7, 0, & 221,0.012D0,100, 1, 10, 4, 7, 0, & 221,0.069D0,100, 4, 8, 1, 7, 0, & 221,0.069D0,100, 4, 10, 3, 7, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/ & 221,0.008D0,100, 2, 8, 1, 7, 0, & 221,0.008D0,100, 2, 10, 3, 7, 0, & 221,0.004D0,100, 4, 8, 3, 7, 0, & 221,0.004D0,100, 4, 10, 1, 7, 0, & 222,0.016D0,101,121,128,140, 0, 0, & 222,0.016D0,101,123,130,140, 0, 0, & 222,0.008D0,101,125,132,140, 0, 0, & 222,0.048D0,101,121,128,141, 0, 0, & 222,0.048D0,101,123,130,141, 0, 0, & 222,0.022D0,101,125,132,141, 0, 0, & 222,0.003D0,101,121,128,332, 0, 0, & 222,0.003D0,101,123,130,332, 0, 0, & 222,0.001D0,101,125,132,332, 0, 0, & 222,0.008D0,101,121,128,142, 0, 0, & 222,0.008D0,101,123,130,142, 0, 0, & 222,0.004D0,101,125,132,142, 0, 0, & 222,0.008D0,101,121,128,314, 0, 0, & 222,0.008D0,101,123,130,314, 0, 0, & 222,0.004D0,101,125,132,314, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/ & 222,0.013D0,101,121,128,143, 0, 0, & 222,0.013D0,101,123,130,143, 0, 0, & 222,0.006D0,101,125,132,143, 0, 0, & 222,0.004D0, 0,140, 30, 0, 0, 0, & 222,0.010D0, 0,140, 31, 0, 0, 0, & 222,0.006D0, 0,140, 32, 0, 0, 0, & 222,0.003D0, 0,141, 30, 0, 0, 0, & 222,0.009D0, 0,141, 31, 0, 0, 0, & 222,0.017D0, 0,141, 32, 0, 0, 0, & 222,0.011D0, 0,140,179, 0, 0, 0, & 222,0.015D0, 0,140,180, 0, 0, 0, & 222,0.011D0, 0,141,179, 0, 0, 0, & 222,0.022D0, 0,141,180, 0, 0, 0, & 222,0.001D0, 0,164, 34, 0, 0, 0, & 222,0.002D0, 0,164, 35, 0, 0, 0, & 222,0.001D0, 0,165, 34, 0, 0, 0, & 222,0.001D0, 0,165, 35, 0, 0, 0, & 222,0.001D0, 0,166, 34, 0, 0, 0, & 222,0.001D0, 0,166, 35, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/ & 222,0.207D0,100, 1, 8, 4, 8, 0, & 222,0.207D0,100, 3, 10, 4, 8, 0, & 222,0.024D0,100, 1, 8, 2, 8, 0, & 222,0.024D0,100, 3, 10, 2, 8, 0, & 222,0.012D0,100, 3, 8, 4, 8, 0, & 222,0.012D0,100, 1, 10, 4, 8, 0, & 222,0.069D0,100, 4, 8, 1, 8, 0, & 222,0.069D0,100, 4, 10, 3, 8, 0, & 222,0.008D0,100, 2, 8, 1, 8, 0, & 222,0.008D0,100, 2, 10, 3, 8, 0, & 222,0.004D0,100, 4, 8, 3, 8, 0, & 222,0.004D0,100, 4, 10, 1, 8, 0, & 223,0.016D0,101,121,128,144, 0, 0, & 223,0.016D0,101,123,130,144, 0, 0, & 223,0.008D0,101,125,132,144, 0, 0, & 223,0.048D0,101,121,128,145, 0, 0, & 223,0.048D0,101,123,130,145, 0, 0, & 223,0.022D0,101,125,132,145, 0, 0, & 223,0.003D0,101,121,128,333, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/ & 223,0.003D0,101,123,130,333, 0, 0, & 223,0.001D0,101,125,132,333, 0, 0, & 223,0.008D0,101,121,128,146, 0, 0, & 223,0.008D0,101,123,130,146, 0, 0, & 223,0.004D0,101,125,132,146, 0, 0, & 223,0.008D0,101,121,128,315, 0, 0, & 223,0.008D0,101,123,130,315, 0, 0, & 223,0.004D0,101,125,132,315, 0, 0, & 223,0.013D0,101,121,128,147, 0, 0, & 223,0.013D0,101,123,130,147, 0, 0, & 223,0.006D0,101,125,132,147, 0, 0, & 223,0.004D0, 0,144, 30, 0, 0, 0, & 223,0.010D0, 0,144, 31, 0, 0, 0, & 223,0.006D0, 0,144, 32, 0, 0, 0, & 223,0.003D0, 0,145, 30, 0, 0, 0, & 223,0.009D0, 0,145, 31, 0, 0, 0, & 223,0.017D0, 0,145, 32, 0, 0, 0, & 223,0.011D0, 0,144,179, 0, 0, 0, & 223,0.015D0, 0,144,180, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/ & 223,0.011D0, 0,145,179, 0, 0, 0, & 223,0.022D0, 0,145,180, 0, 0, 0, & 223,0.001D0, 0,164, 25, 0, 0, 0, & 223,0.002D0, 0,164, 56, 0, 0, 0, & 223,0.001D0, 0,165, 25, 0, 0, 0, & 223,0.001D0, 0,165, 56, 0, 0, 0, & 223,0.001D0, 0,166, 25, 0, 0, 0, & 223,0.001D0, 0,166, 56, 0, 0, 0, & 223,0.207D0,100, 1, 8, 4, 9, 0, & 223,0.207D0,100, 3, 10, 4, 9, 0, & 223,0.024D0,100, 1, 8, 2, 9, 0, & 223,0.024D0,100, 3, 10, 2, 9, 0, & 223,0.012D0,100, 3, 8, 4, 9, 0, & 223,0.012D0,100, 1, 10, 4, 9, 0, & 223,0.069D0,100, 4, 8, 1, 9, 0, & 223,0.069D0,100, 4, 10, 3, 9, 0, & 223,0.008D0,100, 2, 8, 1, 9, 0, & 223,0.008D0,100, 2, 10, 3, 9, 0, & 223,0.004D0,100, 4, 8, 3, 9, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/ & 223,0.004D0,100, 4, 10, 1, 9, 0, & 224,0.090D0,100,121,128, 4,109, 0, & 224,0.090D0,100,123,130, 4,109, 0, & 224,0.045D0,100,125,132, 4,109, 0, & 224,0.010D0,100,121,128, 2,109, 0, & 224,0.010D0,100,123,130, 2,109, 0, & 224,0.005D0,100,125,132, 2,109, 0, & 224,0.242D0,100, 1, 8, 4,109, 0, & 224,0.242D0,100, 3, 10, 4,109, 0, & 224,0.027D0,100, 1, 8, 2,109, 0, & 224,0.027D0,100, 3, 10, 2,109, 0, & 224,0.012D0,100, 3, 8, 4,109, 0, & 224,0.012D0,100, 1, 10, 4,109, 0, & 224,0.081D0,100, 4, 8, 1,109, 0, & 224,0.081D0,100, 4, 10, 3,109, 0, & 224,0.009D0,100, 2, 8, 1,109, 0, & 224,0.009D0,100, 2, 10, 3,109, 0, & 224,0.004D0,100, 4, 8, 3,109, 0, & 224,0.004D0,100, 4, 10, 1,109, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/ & 225,0.090D0,100,121,128, 4,110, 0, & 225,0.090D0,100,123,130, 4,110, 0, & 225,0.045D0,100,125,132, 4,110, 0, & 225,0.010D0,100,121,128, 2,110, 0, & 225,0.010D0,100,123,130, 2,110, 0, & 225,0.005D0,100,125,132, 2,110, 0, & 225,0.242D0,100, 1, 8, 4,110, 0, & 225,0.242D0,100, 3, 10, 4,110, 0, & 225,0.027D0,100, 1, 8, 2,110, 0, & 225,0.027D0,100, 3, 10, 2,110, 0, & 225,0.012D0,100, 3, 8, 4,110, 0, & 225,0.012D0,100, 1, 10, 4,110, 0, & 225,0.081D0,100, 4, 8, 1,110, 0, & 225,0.081D0,100, 4, 10, 3,110, 0, & 225,0.009D0,100, 2, 8, 1,110, 0, & 225,0.009D0,100, 2, 10, 3,110, 0, & 225,0.004D0,100, 4, 8, 3,110, 0, & 225,0.004D0,100, 4, 10, 1,110, 0, & 226,0.090D0,100,121,128, 4,111, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/ & 226,0.090D0,100,123,130, 4,111, 0, & 226,0.045D0,100,125,132, 4,111, 0, & 226,0.010D0,100,121,128, 2,111, 0, & 226,0.010D0,100,123,130, 2,111, 0, & 226,0.005D0,100,125,132, 2,111, 0, & 226,0.242D0,100, 1, 8, 4,111, 0, & 226,0.242D0,100, 3, 10, 4,111, 0, & 226,0.027D0,100, 1, 8, 2,111, 0, & 226,0.027D0,100, 3, 10, 2,111, 0, & 226,0.012D0,100, 3, 8, 4,111, 0, & 226,0.012D0,100, 1, 10, 4,111, 0, & 226,0.081D0,100, 4, 8, 1,111, 0, & 226,0.081D0,100, 4, 10, 3,111, 0, & 226,0.009D0,100, 2, 8, 1,111, 0, & 226,0.009D0,100, 2, 10, 3,111, 0, & 226,0.004D0,100, 4, 8, 3,111, 0, & 226,0.004D0,100, 4, 10, 1,111, 0, & 227,0.090D0,100,121,128, 4,112, 0, & 227,0.090D0,100,123,130, 4,112, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/ & 227,0.045D0,100,125,132, 4,112, 0, & 227,0.010D0,100,121,128, 2,112, 0, & 227,0.010D0,100,123,130, 2,112, 0, & 227,0.005D0,100,125,132, 2,112, 0, & 227,0.242D0,100, 1, 8, 4,112, 0, & 227,0.242D0,100, 3, 10, 4,112, 0, & 227,0.027D0,100, 1, 8, 2,112, 0, & 227,0.027D0,100, 3, 10, 2,112, 0, & 227,0.012D0,100, 3, 8, 4,112, 0, & 227,0.012D0,100, 1, 10, 4,112, 0, & 227,0.081D0,100, 4, 8, 1,112, 0, & 227,0.081D0,100, 4, 10, 3,112, 0, & 227,0.009D0,100, 2, 8, 1,112, 0, & 227,0.009D0,100, 2, 10, 3,112, 0, & 227,0.004D0,100, 4, 8, 3,112, 0, & 227,0.004D0,100, 4, 10, 1,112, 0, & 228,0.090D0,100,121,128, 4,113, 0, & 228,0.090D0,100,123,130, 4,113, 0, & 228,0.045D0,100,125,132, 4,113, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/ & 228,0.010D0,100,121,128, 2,113, 0, & 228,0.010D0,100,123,130, 2,113, 0, & 228,0.005D0,100,125,132, 2,113, 0, & 228,0.242D0,100, 1, 8, 4,113, 0, & 228,0.242D0,100, 3, 10, 4,113, 0, & 228,0.027D0,100, 1, 8, 2,113, 0, & 228,0.027D0,100, 3, 10, 2,113, 0, & 228,0.012D0,100, 3, 8, 4,113, 0, & 228,0.012D0,100, 1, 10, 4,113, 0, & 228,0.081D0,100, 4, 8, 1,113, 0, & 228,0.081D0,100, 4, 10, 3,113, 0, & 228,0.009D0,100, 2, 8, 1,113, 0, & 228,0.009D0,100, 2, 10, 3,113, 0, & 228,0.004D0,100, 4, 8, 3,113, 0, & 228,0.004D0,100, 4, 10, 1,113, 0, & 229,0.090D0,100,121,128, 4,114, 0, & 229,0.090D0,100,123,130, 4,114, 0, & 229,0.045D0,100,125,132, 4,114, 0, & 229,0.010D0,100,121,128, 2,114, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/ & 229,0.010D0,100,123,130, 2,114, 0, & 229,0.005D0,100,125,132, 2,114, 0, & 229,0.242D0,100, 1, 8, 4,114, 0, & 229,0.242D0,100, 3, 10, 4,114, 0, & 229,0.027D0,100, 1, 8, 2,114, 0, & 229,0.027D0,100, 3, 10, 2,114, 0, & 229,0.012D0,100, 3, 8, 4,114, 0, & 229,0.012D0,100, 1, 10, 4,114, 0, & 229,0.081D0,100, 4, 8, 1,114, 0, & 229,0.081D0,100, 4, 10, 3,114, 0, & 229,0.009D0,100, 2, 8, 1,114, 0, & 229,0.009D0,100, 2, 10, 3,114, 0, & 229,0.004D0,100, 4, 8, 3,114, 0, & 229,0.004D0,100, 4, 10, 1,114, 0, & 230,0.080D0,100,121,128, 4, 10, 0, & 230,0.080D0,100,123,130, 4, 10, 0, & 230,0.040D0,100,125,132, 4, 10, 0, & 230,0.080D0,100,121,128, 9, 5, 0, & 230,0.080D0,100,123,130, 9, 5, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/ & 230,0.228D0,100, 1, 8, 4, 10, 0, & 230,0.228D0,100, 3, 10, 4, 10, 0, & 230,0.012D0,100, 3, 8, 4, 10, 0, & 230,0.012D0,100, 1, 10, 4, 10, 0, & 230,0.076D0,100, 4, 8, 1, 10, 0, & 230,0.076D0,100, 4, 10, 3, 10, 0, & 230,0.004D0,100, 4, 8, 3, 10, 0, & 230,0.004D0,100, 4, 10, 1, 10, 0, & 231,0.025D0, 0,121,127, 0, 0, 0, & 231,0.025D0, 0,123,129, 0, 0, 0, & 231,0.025D0, 0,125,131, 0, 0, 0, & 231,0.008D0, 0, 1, 7, 0, 0, 0, & 231,0.033D0, 0, 2, 8, 0, 0, 0, & 231,0.008D0, 0, 3, 9, 0, 0, 0, & 231,0.033D0, 0, 4, 10, 0, 0, 0, & 231,0.801D0,130, 13, 13, 13, 0, 0, & 231,0.042D0,130, 13, 13, 59, 0, 0, & 245,0.016D0,101,127,122,171, 0, 0, & 245,0.016D0,101,129,124,171, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/ & 245,0.008D0,101,131,126,171, 0, 0, & 245,0.048D0,101,127,122,172, 0, 0, & 245,0.048D0,101,129,124,172, 0, 0, & 245,0.022D0,101,131,126,172, 0, 0, & 245,0.003D0,101,127,122,334, 0, 0, & 245,0.003D0,101,129,124,334, 0, 0, & 245,0.001D0,101,131,126,334, 0, 0, & 245,0.008D0,101,127,122,173, 0, 0, & 245,0.008D0,101,129,124,173, 0, 0, & 245,0.004D0,101,131,126,173, 0, 0, & 245,0.008D0,101,127,122,316, 0, 0, & 245,0.008D0,101,129,124,316, 0, 0, & 245,0.004D0,101,131,126,316, 0, 0, & 245,0.013D0,101,127,122,174, 0, 0, & 245,0.013D0,101,129,124,174, 0, 0, & 245,0.006D0,101,131,126,174, 0, 0, & 245,0.004D0, 0,171, 38, 0, 0, 0, & 245,0.010D0, 0,171, 39, 0, 0, 0, & 245,0.006D0, 0,171, 40, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/ & 245,0.003D0, 0,172, 38, 0, 0, 0, & 245,0.009D0, 0,172, 39, 0, 0, 0, & 245,0.017D0, 0,172, 40, 0, 0, 0, & 245,0.011D0, 0,171,144, 0, 0, 0, & 245,0.015D0, 0,171,145, 0, 0, 0, & 245,0.011D0, 0,172,144, 0, 0, 0, & 245,0.022D0, 0,172,145, 0, 0, 0, & 245,0.001D0, 0,164, 50, 0, 0, 0, & 245,0.002D0, 0,164, 51, 0, 0, 0, & 245,0.001D0, 0,165, 50, 0, 0, 0, & 245,0.001D0, 0,165, 51, 0, 0, 0, & 245,0.001D0, 0,166, 50, 0, 0, 0, & 245,0.001D0, 0,166, 51, 0, 0, 0, & 245,0.207D0,100, 7, 2, 10, 1, 0, & 245,0.207D0,100, 9, 4, 10, 1, 0, & 245,0.024D0,100, 7, 2, 8, 1, 0, & 245,0.024D0,100, 9, 4, 8, 1, 0, & 245,0.012D0,100, 9, 2, 10, 1, 0, & 245,0.012D0,100, 7, 4, 10, 1, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/ & 245,0.069D0,100, 10, 2, 7, 1, 0, & 245,0.069D0,100, 10, 4, 9, 1, 0, & 245,0.008D0,100, 8, 2, 7, 1, 0, & 245,0.008D0,100, 8, 4, 9, 1, 0, & 245,0.004D0,100, 10, 2, 9, 1, 0, & 245,0.004D0,100, 10, 4, 7, 1, 0, & 246,0.016D0,101,127,122,175, 0, 0, & 246,0.016D0,101,129,124,175, 0, 0, & 246,0.008D0,101,131,126,175, 0, 0, & 246,0.048D0,101,127,122,176, 0, 0, & 246,0.048D0,101,129,124,176, 0, 0, & 246,0.022D0,101,131,126,176, 0, 0, & 246,0.003D0,101,127,122,335, 0, 0, & 246,0.003D0,101,129,124,335, 0, 0, & 246,0.001D0,101,131,126,335, 0, 0, & 246,0.008D0,101,127,122,177, 0, 0, & 246,0.008D0,101,129,124,177, 0, 0, & 246,0.004D0,101,131,126,177, 0, 0, & 246,0.008D0,101,127,122,317, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/ & 246,0.008D0,101,129,124,317, 0, 0, & 246,0.004D0,101,131,126,317, 0, 0, & 246,0.013D0,101,127,122,178, 0, 0, & 246,0.013D0,101,129,124,178, 0, 0, & 246,0.006D0,101,131,126,178, 0, 0, & 246,0.004D0, 0,175, 38, 0, 0, 0, & 246,0.010D0, 0,175, 39, 0, 0, 0, & 246,0.006D0, 0,175, 40, 0, 0, 0, & 246,0.003D0, 0,176, 38, 0, 0, 0, & 246,0.009D0, 0,176, 39, 0, 0, 0, & 246,0.017D0, 0,176, 40, 0, 0, 0, & 246,0.011D0, 0,175,144, 0, 0, 0, & 246,0.015D0, 0,175,145, 0, 0, 0, & 246,0.011D0, 0,176,144, 0, 0, 0, & 246,0.022D0, 0,176,145, 0, 0, 0, & 246,0.001D0, 0,164, 46, 0, 0, 0, & 246,0.002D0, 0,164, 47, 0, 0, 0, & 246,0.001D0, 0,165, 46, 0, 0, 0, & 246,0.001D0, 0,165, 47, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/ & 246,0.001D0, 0,166, 46, 0, 0, 0, & 246,0.001D0, 0,166, 47, 0, 0, 0, & 246,0.207D0,100, 7, 2, 10, 2, 0, & 246,0.207D0,100, 9, 4, 10, 2, 0, & 246,0.024D0,100, 7, 2, 8, 2, 0, & 246,0.024D0,100, 9, 4, 8, 2, 0, & 246,0.012D0,100, 9, 2, 10, 2, 0, & 246,0.012D0,100, 7, 4, 10, 2, 0, & 246,0.069D0,100, 10, 2, 7, 2, 0, & 246,0.069D0,100, 10, 4, 9, 2, 0, & 246,0.008D0,100, 8, 2, 7, 2, 0, & 246,0.008D0,100, 8, 4, 9, 2, 0, & 246,0.004D0,100, 10, 2, 9, 2, 0, & 246,0.004D0,100, 10, 4, 7, 2, 0, & 247,0.016D0,101,127,122,179, 0, 0, & 247,0.016D0,101,129,124,179, 0, 0, & 247,0.008D0,101,131,126,179, 0, 0, & 247,0.048D0,101,127,122,180, 0, 0, & 247,0.048D0,101,129,124,180, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/ & 247,0.022D0,101,131,126,180, 0, 0, & 247,0.003D0,101,127,122,336, 0, 0, & 247,0.003D0,101,129,124,336, 0, 0, & 247,0.001D0,101,131,126,336, 0, 0, & 247,0.008D0,101,127,122,181, 0, 0, & 247,0.008D0,101,129,124,181, 0, 0, & 247,0.004D0,101,131,126,181, 0, 0, & 247,0.008D0,101,127,122,318, 0, 0, & 247,0.008D0,101,129,124,318, 0, 0, & 247,0.004D0,101,131,126,318, 0, 0, & 247,0.013D0,101,127,122,182, 0, 0, & 247,0.013D0,101,129,124,182, 0, 0, & 247,0.006D0,101,131,126,182, 0, 0, & 247,0.004D0, 0,179, 38, 0, 0, 0, & 247,0.010D0, 0,179, 39, 0, 0, 0, & 247,0.006D0, 0,179, 40, 0, 0, 0, & 247,0.003D0, 0,180, 38, 0, 0, 0, & 247,0.009D0, 0,180, 39, 0, 0, 0, & 247,0.017D0, 0,180, 40, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/ & 247,0.011D0, 0,179,144, 0, 0, 0, & 247,0.015D0, 0,179,145, 0, 0, 0, & 247,0.011D0, 0,180,144, 0, 0, 0, & 247,0.022D0, 0,180,145, 0, 0, 0, & 247,0.001D0, 0,164, 25, 0, 0, 0, & 247,0.002D0, 0,164, 56, 0, 0, 0, & 247,0.001D0, 0,165, 25, 0, 0, 0, & 247,0.001D0, 0,165, 56, 0, 0, 0, & 247,0.001D0, 0,166, 25, 0, 0, 0, & 247,0.001D0, 0,166, 56, 0, 0, 0, & 247,0.207D0,100, 7, 2, 10, 3, 0, & 247,0.207D0,100, 9, 4, 10, 3, 0, & 247,0.024D0,100, 7, 2, 8, 3, 0, & 247,0.024D0,100, 9, 4, 8, 3, 0, & 247,0.012D0,100, 9, 2, 10, 3, 0, & 247,0.012D0,100, 7, 4, 10, 3, 0, & 247,0.069D0,100, 10, 2, 7, 3, 0, & 247,0.069D0,100, 10, 4, 9, 3, 0, & 247,0.008D0,100, 8, 2, 7, 3, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/ & 247,0.008D0,100, 8, 4, 9, 3, 0, & 247,0.004D0,100, 10, 2, 9, 3, 0, & 247,0.004D0,100, 10, 4, 7, 3, 0, & 248,0.090D0,100,127,122, 10,115, 0, & 248,0.090D0,100,129,124, 10,115, 0, & 248,0.045D0,100,131,126, 10,115, 0, & 248,0.010D0,100,127,122, 8,115, 0, & 248,0.010D0,100,129,124, 8,115, 0, & 248,0.005D0,100,131,126, 8,115, 0, & 248,0.242D0,100, 7, 2, 10,115, 0, & 248,0.242D0,100, 9, 4, 10,115, 0, & 248,0.027D0,100, 7, 2, 8,115, 0, & 248,0.027D0,100, 9, 4, 8,115, 0, & 248,0.012D0,100, 9, 2, 10,115, 0, & 248,0.012D0,100, 7, 4, 10,115, 0, & 248,0.081D0,100, 10, 2, 7,115, 0, & 248,0.081D0,100, 10, 4, 9,115, 0, & 248,0.009D0,100, 8, 2, 7,115, 0, & 248,0.009D0,100, 8, 4, 9,115, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/ & 248,0.004D0,100, 10, 2, 9,115, 0, & 248,0.004D0,100, 10, 4, 7,115, 0, & 249,0.090D0,100,127,122, 10,116, 0, & 249,0.090D0,100,129,124, 10,116, 0, & 249,0.045D0,100,131,126, 10,116, 0, & 249,0.010D0,100,127,122, 8,116, 0, & 249,0.010D0,100,129,124, 8,116, 0, & 249,0.005D0,100,131,126, 8,116, 0, & 249,0.242D0,100, 7, 2, 10,116, 0, & 249,0.242D0,100, 9, 4, 10,116, 0, & 249,0.027D0,100, 7, 2, 8,116, 0, & 249,0.027D0,100, 9, 4, 8,116, 0, & 249,0.012D0,100, 9, 2, 10,116, 0, & 249,0.012D0,100, 7, 4, 10,116, 0, & 249,0.081D0,100, 10, 2, 7,116, 0, & 249,0.081D0,100, 10, 4, 9,116, 0, & 249,0.009D0,100, 8, 2, 7,116, 0, & 249,0.009D0,100, 8, 4, 9,116, 0, & 249,0.004D0,100, 10, 2, 9,116, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/ & 249,0.004D0,100, 10, 4, 7,116, 0, & 250,0.090D0,100,127,122, 10,117, 0, & 250,0.090D0,100,129,124, 10,117, 0, & 250,0.045D0,100,131,126, 10,117, 0, & 250,0.010D0,100,127,122, 8,117, 0, & 250,0.010D0,100,129,124, 8,117, 0, & 250,0.005D0,100,131,126, 8,117, 0, & 250,0.242D0,100, 7, 2, 10,117, 0, & 250,0.242D0,100, 9, 4, 10,117, 0, & 250,0.027D0,100, 7, 2, 8,117, 0, & 250,0.027D0,100, 9, 4, 8,117, 0, & 250,0.012D0,100, 9, 2, 10,117, 0, & 250,0.012D0,100, 7, 4, 10,117, 0, & 250,0.081D0,100, 10, 2, 7,117, 0, & 250,0.081D0,100, 10, 4, 9,117, 0, & 250,0.009D0,100, 8, 2, 7,117, 0, & 250,0.009D0,100, 8, 4, 9,117, 0, & 250,0.004D0,100, 10, 2, 9,117, 0, & 250,0.004D0,100, 10, 4, 7,117, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/ & 251,0.090D0,100,127,122, 10,118, 0, & 251,0.090D0,100,129,124, 10,118, 0, & 251,0.045D0,100,131,126, 10,118, 0, & 251,0.010D0,100,127,122, 8,118, 0, & 251,0.010D0,100,129,124, 8,118, 0, & 251,0.005D0,100,131,126, 8,118, 0, & 251,0.242D0,100, 7, 2, 10,118, 0, & 251,0.242D0,100, 9, 4, 10,118, 0, & 251,0.027D0,100, 7, 2, 8,118, 0, & 251,0.027D0,100, 9, 4, 8,118, 0, & 251,0.012D0,100, 9, 2, 10,118, 0, & 251,0.012D0,100, 7, 4, 10,118, 0, & 251,0.081D0,100, 10, 2, 7,118, 0, & 251,0.081D0,100, 10, 4, 9,118, 0, & 251,0.009D0,100, 8, 2, 7,118, 0, & 251,0.009D0,100, 8, 4, 9,118, 0, & 251,0.004D0,100, 10, 2, 9,118, 0, & 251,0.004D0,100, 10, 4, 7,118, 0, & 252,0.090D0,100,127,122, 10,119, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/ & 252,0.090D0,100,129,124, 10,119, 0, & 252,0.045D0,100,131,126, 10,119, 0, & 252,0.010D0,100,127,122, 8,119, 0, & 252,0.010D0,100,129,124, 8,119, 0, & 252,0.005D0,100,131,126, 8,119, 0, & 252,0.242D0,100, 7, 2, 10,119, 0, & 252,0.242D0,100, 9, 4, 10,119, 0, & 252,0.027D0,100, 7, 2, 8,119, 0, & 252,0.027D0,100, 9, 4, 8,119, 0, & 252,0.012D0,100, 9, 2, 10,119, 0, & 252,0.012D0,100, 7, 4, 10,119, 0, & 252,0.081D0,100, 10, 2, 7,119, 0, & 252,0.081D0,100, 10, 4, 9,119, 0, & 252,0.009D0,100, 8, 2, 7,119, 0, & 252,0.009D0,100, 8, 4, 9,119, 0, & 252,0.004D0,100, 10, 2, 9,119, 0, & 252,0.004D0,100, 10, 4, 7,119, 0, & 253,0.090D0,100,127,122, 10,120, 0, & 253,0.090D0,100,129,124, 10,120, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/ & 253,0.045D0,100,131,126, 10,120, 0, & 253,0.010D0,100,127,122, 8,120, 0, & 253,0.010D0,100,129,124, 8,120, 0, & 253,0.005D0,100,131,126, 8,120, 0, & 253,0.242D0,100, 7, 2, 10,120, 0, & 253,0.242D0,100, 9, 4, 10,120, 0, & 253,0.027D0,100, 7, 2, 8,120, 0, & 253,0.027D0,100, 9, 4, 8,120, 0, & 253,0.012D0,100, 9, 2, 10,120, 0, & 253,0.012D0,100, 7, 4, 10,120, 0, & 253,0.081D0,100, 10, 2, 7,120, 0, & 253,0.081D0,100, 10, 4, 9,120, 0, & 253,0.009D0,100, 8, 2, 7,120, 0, & 253,0.009D0,100, 8, 4, 9,120, 0, & 253,0.004D0,100, 10, 2, 9,120, 0, & 253,0.004D0,100, 10, 4, 7,120, 0, & 254,0.080D0,100,127,122, 10, 4, 0, & 254,0.080D0,100,129,124, 10, 4, 0, & 254,0.040D0,100,131,126, 10, 4, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/ & 254,0.080D0,100,127,122, 3, 11, 0, & 254,0.080D0,100,129,124, 3, 11, 0, & 254,0.228D0,100, 7, 2, 10, 4, 0, & 254,0.228D0,100, 9, 4, 10, 4, 0, & 254,0.012D0,100, 9, 2, 10, 4, 0, & 254,0.012D0,100, 7, 4, 10, 4, 0, & 254,0.076D0,100, 10, 2, 7, 4, 0, & 254,0.076D0,100, 10, 4, 9, 4, 0, & 254,0.004D0,100, 10, 2, 9, 4, 0, & 254,0.004D0,100, 10, 4, 7, 4, 0, & 265,1.000D0, 0,221, 59, 0, 0, 0, & 266,1.000D0, 0,222, 59, 0, 0, 0, & 267,1.000D0, 0,223, 59, 0, 0, 0, & 268,0.667D0, 0,266, 38, 0, 0, 0, & 268,0.333D0, 0,265, 21, 0, 0, 0, & 269,0.667D0, 0,265, 30, 0, 0, 0, & 269,0.333D0, 0,266, 21, 0, 0, 0, & 270,0.500D0, 0,265, 50, 0, 0, 0, & 270,0.500D0, 0,266, 46, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/ & 271,0.290D0, 0,266, 38, 0, 0, 0, & 271,0.150D0, 0,265, 21, 0, 0, 0, & 271,0.290D0, 0,222, 38, 0, 0, 0, & 271,0.150D0, 0,221, 21, 0, 0, 0, & 271,0.060D0, 0,266, 38, 21, 0, 0, & 271,0.020D0, 0,265, 38, 30, 0, 0, & 271,0.010D0, 0,265, 21, 21, 0, 0, & 271,0.020D0, 0,222, 38, 21, 0, 0, & 271,0.010D0, 0,221, 38, 30, 0, 0, & 272,0.290D0, 0,265, 30, 0, 0, 0, & 272,0.150D0, 0,266, 21, 0, 0, 0, & 272,0.290D0, 0,221, 30, 0, 0, 0, & 272,0.150D0, 0,222, 21, 0, 0, 0, & 272,0.060D0, 0,265, 30, 21, 0, 0, & 272,0.020D0, 0,266, 38, 30, 0, 0, & 272,0.010D0, 0,266, 21, 21, 0, 0, & 272,0.020D0, 0,221, 30, 21, 0, 0, & 272,0.010D0, 0,222, 38, 30, 0, 0, & 273,0.350D0, 0,221, 50, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/ & 273,0.350D0, 0,222, 46, 0, 0, 0, & 273,0.150D0, 0,265, 50, 0, 0, 0, & 273,0.150D0, 0,266, 46, 0, 0, 0, & 274,1.000D0, 0,245, 59, 0, 0, 0, & 275,1.000D0, 0,246, 59, 0, 0, 0, & 276,1.000D0, 0,247, 59, 0, 0, 0, & 277,0.667D0, 0,275, 30, 0, 0, 0, & 277,0.333D0, 0,274, 21, 0, 0, 0, & 278,0.667D0, 0,274, 38, 0, 0, 0, & 278,0.333D0, 0,275, 21, 0, 0, 0, & 279,0.500D0, 0,274, 42, 0, 0, 0, & 279,0.500D0, 0,275, 34, 0, 0, 0, & 280,0.290D0, 0,275, 30, 0, 0, 0, & 280,0.150D0, 0,274, 21, 0, 0, 0, & 280,0.290D0, 0,246, 30, 0, 0, 0, & 280,0.150D0, 0,245, 21, 0, 0, 0, & 280,0.060D0, 0,275, 30, 21, 0, 0, & 280,0.020D0, 0,274, 38, 30, 0, 0, & 280,0.010D0, 0,274, 21, 21, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/ & 280,0.020D0, 0,246, 30, 21, 0, 0, & 280,0.010D0, 0,245, 38, 30, 0, 0, & 281,0.290D0, 0,274, 38, 0, 0, 0, & 281,0.150D0, 0,275, 21, 0, 0, 0, & 281,0.290D0, 0,245, 38, 0, 0, 0, & 281,0.150D0, 0,246, 21, 0, 0, 0, & 281,0.060D0, 0,274, 38, 21, 0, 0, & 281,0.020D0, 0,275, 38, 30, 0, 0, & 281,0.010D0, 0,275, 21, 21, 0, 0, & 281,0.020D0, 0,245, 38, 21, 0, 0, & 281,0.010D0, 0,246, 38, 30, 0, 0, & 282,0.350D0, 0,245, 42, 0, 0, 0, & 282,0.350D0, 0,246, 34, 0, 0, 0, & 282,0.150D0, 0,274, 42, 0, 0, 0, & 282,0.150D0, 0,275, 34, 0, 0, 0, & 285,1.000D0, 0, 24, 21, 0, 0, 0, & 286,0.998D0, 0, 24, 38, 0, 0, 0, & 286,0.002D0, 0, 38, 59, 0, 0, 0, & 287,0.998D0, 0, 24, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/ & 287,0.002D0, 0, 30, 59, 0, 0, 0, & 288,0.330D0, 0, 39, 30, 0, 0, 0, & 288,0.340D0, 0, 23, 21, 0, 0, 0, & 288,0.330D0, 0, 31, 38, 0, 0, 0, & 289,0.250D0, 0, 46, 35, 0, 0, 0, & 289,0.250D0, 0, 34, 47, 0, 0, 0, & 289,0.250D0, 0, 50, 43, 0, 0, 0, & 289,0.250D0, 0, 42, 51, 0, 0, 0, & 290,0.996D0, 0, 22, 21, 0, 0, 0, & 290,0.002D0, 0, 46, 34, 0, 0, 0, & 290,0.002D0, 0, 50, 42, 0, 0, 0, & 291,0.996D0, 0, 22, 38, 0, 0, 0, & 291,0.004D0, 0, 46, 42, 0, 0, 0, & 292,0.996D0, 0, 22, 30, 0, 0, 0, & 292,0.004D0, 0, 50, 34, 0, 0, 0, & 293,0.520D0, 0, 38, 30, 0, 0, 0, & 293,0.260D0, 0, 21, 21, 0, 0, 0, & 293,0.110D0, 0, 46, 34, 0, 0, 0, & 293,0.110D0, 0, 50, 42, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/ & 294,0.620D0, 0, 38, 30, 0, 0, 0, & 294,0.310D0, 0, 21, 21, 0, 0, 0, & 294,0.035D0, 0, 46, 34, 0, 0, 0, & 294,0.035D0, 0, 50, 42, 0, 0, 0, & 295,1.000D0, 0,254, 59, 0, 0, 0, & 296,1.000D0, 0,230, 59, 0, 0, 0, & 297,1.000D0, 0,254, 59, 0, 0, 0, & 298,1.000D0, 0,230, 59, 0, 0, 0, & 299,1.000D0, 0,254, 59, 0, 0, 0, & 300,1.000D0, 0,230, 59, 0, 0, 0, & 301,0.050D0, 0,121,127, 0, 0, 0, & 301,0.050D0, 0,123,129, 0, 0, 0, & 301,0.017D0, 0, 1, 7, 0, 0, 0, & 301,0.066D0, 0, 2, 8, 0, 0, 0, & 301,0.017D0, 0, 3, 9, 0, 0, 0, & 301,0.640D0,130, 13, 13, 13, 0, 0, & 301,0.160D0,130, 13, 13, 59, 0, 0, & 302,0.022D0, 0, 38, 30, 38, 30, 23, & 302,0.016D0, 0, 38, 30, 38, 30, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/ & 302,0.009D0, 0, 38, 30, 46, 34, 0, & 302,0.004D0, 0, 23, 38, 30, 0, 0, & 302,0.002D0, 0, 46, 43, 30, 0, 0, & 302,0.002D0, 0, 34, 51, 38, 0, 0, & 302,0.001D0, 0, 38, 30, 73, 91, 0, & 302,0.273D0, 0, 59,164, 0, 0, 0, & 302,0.671D0, 0, 13, 13, 0, 0, 0, & 303,0.022D0, 0, 38, 30, 38, 30, 0, & 303,0.019D0, 0, 38, 30, 46, 34, 0, & 303,0.012D0, 0, 38, 30, 38, 30, 23, & 303,0.007D0, 0, 23, 38, 30, 0, 0, & 303,0.002D0, 0, 46, 43, 30, 0, 0, & 303,0.002D0, 0, 34, 51, 38, 0, 0, & 303,0.003D0, 0, 38, 30, 73, 91, 0, & 303,0.002D0, 0, 38, 30, 0, 0, 0, & 303,0.002D0, 0, 46, 34, 0, 0, 0, & 303,0.001D0, 0, 21, 21, 0, 0, 0, & 303,0.135D0, 0, 59,164, 0, 0, 0, & 303,0.793D0, 0, 13, 13, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/ & 304,1.000D0, 0, 13, 13, 0, 0, 0, & 305,1.000D0, 0, 13, 13, 0, 0, 0, & 306,0.050D0, 0, 59,231, 0, 0, 0, & 306,0.950D0, 0, 13, 13, 0, 0, 0, & 307,0.350D0, 0, 59,231, 0, 0, 0, & 307,0.650D0, 0, 13, 13, 0, 0, 0, & 308,0.220D0, 0, 59,231, 0, 0, 0, & 308,0.780D0, 0, 13, 13, 0, 0, 0, & 309,0.280D0, 0, 46, 31, 0, 0, 0, & 309,0.140D0, 0, 50, 23, 0, 0, 0, & 309,0.187D0, 0,327, 30, 0, 0, 0, & 309,0.093D0, 0,328, 21, 0, 0, 0, & 309,0.110D0, 0, 50, 24, 0, 0, 0, & 309,0.107D0, 0, 47, 30, 0, 0, 0, & 309,0.053D0, 0, 51, 21, 0, 0, 0, & 309,0.030D0, 0, 50,293, 0, 0, 0, & 310,0.280D0, 0, 50, 39, 0, 0, 0, & 310,0.140D0, 0, 46, 23, 0, 0, 0, & 310,0.187D0, 0,328, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/ & 310,0.093D0, 0,327, 21, 0, 0, 0, & 310,0.110D0, 0, 46, 24, 0, 0, 0, & 310,0.107D0, 0, 51, 38, 0, 0, 0, & 310,0.053D0, 0, 47, 21, 0, 0, 0, & 310,0.030D0, 0, 46,293, 0, 0, 0, & 311,0.280D0, 0, 34, 39, 0, 0, 0, & 311,0.140D0, 0, 42, 23, 0, 0, 0, & 311,0.187D0, 0,330, 38, 0, 0, 0, & 311,0.093D0, 0,329, 21, 0, 0, 0, & 311,0.110D0, 0, 42, 24, 0, 0, 0, & 311,0.107D0, 0, 35, 38, 0, 0, 0, & 311,0.053D0, 0, 43, 21, 0, 0, 0, & 311,0.030D0, 0, 42,293, 0, 0, 0, & 312,0.280D0, 0, 42, 31, 0, 0, 0, & 312,0.140D0, 0, 34, 23, 0, 0, 0, & 312,0.187D0, 0,329, 30, 0, 0, 0, & 312,0.093D0, 0,330, 21, 0, 0, 0, & 312,0.110D0, 0, 34, 24, 0, 0, 0, & 312,0.107D0, 0, 43, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/ & 312,0.053D0, 0, 35, 21, 0, 0, 0, & 312,0.030D0, 0, 34,293, 0, 0, 0, & 313,0.430D0, 0,140, 38, 0, 0, 0, & 313,0.215D0, 0,136, 21, 0, 0, 0, & 313,0.235D0, 0,140, 38, 21, 0, 0, & 313,0.120D0, 0,136, 38, 30, 0, 0, & 314,0.430D0, 0,136, 30, 0, 0, 0, & 314,0.215D0, 0,140, 21, 0, 0, 0, & 314,0.235D0, 0,136, 30, 21, 0, 0, & 314,0.120D0, 0,140, 38, 30, 0, 0, & 315,0.480D0, 0,136, 50, 0, 0, 0, & 315,0.480D0, 0,140, 46, 0, 0, 0, & 315,0.040D0, 0,145, 59, 0, 0, 0, & 316,0.430D0, 0,175, 30, 0, 0, 0, & 316,0.215D0, 0,171, 21, 0, 0, 0, & 316,0.235D0, 0,175, 30, 21, 0, 0, & 316,0.120D0, 0,171, 38, 30, 0, 0, & 317,0.430D0, 0,171, 38, 0, 0, 0, & 317,0.215D0, 0,175, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/ & 317,0.235D0, 0,171, 38, 21, 0, 0, & 317,0.120D0, 0,175, 38, 30, 0, 0, & 318,0.480D0, 0,171, 42, 0, 0, 0, & 318,0.480D0, 0,175, 34, 0, 0, 0, & 318,0.040D0, 0,180, 59, 0, 0, 0, & 319,0.540D0, 0,275, 30, 0, 0, 0, & 319,0.270D0, 0,274, 21, 0, 0, 0, & 319,0.030D0, 0,275, 30, 21, 0, 0, & 319,0.010D0, 0,274, 38, 30, 0, 0, & 319,0.010D0, 0,274, 21, 21, 0, 0, & 319,0.090D0, 0,246, 30, 21, 0, 0, & 319,0.030D0, 0,245, 38, 30, 0, 0, & 319,0.020D0, 0,245, 21, 21, 0, 0, & 320,0.540D0, 0,274, 38, 0, 0, 0, & 320,0.270D0, 0,275, 21, 0, 0, 0, & 320,0.030D0, 0,274, 38, 21, 0, 0, & 320,0.010D0, 0,275, 38, 30, 0, 0, & 320,0.010D0, 0,275, 21, 21, 0, 0, & 320,0.090D0, 0,245, 38, 21, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/ & 320,0.030D0, 0,246, 38, 30, 0, 0, & 320,0.020D0, 0,246, 21, 21, 0, 0, & 321,0.500D0, 0,275, 34, 0, 0, 0, & 321,0.500D0, 0,274, 42, 0, 0, 0, & 322,1.000D0, 0,254, 59, 0, 0, 0, & 323,0.540D0, 0,266, 38, 0, 0, 0, & 323,0.270D0, 0,265, 21, 0, 0, 0, & 323,0.030D0, 0,266, 38, 21, 0, 0, & 323,0.010D0, 0,265, 38, 30, 0, 0, & 323,0.010D0, 0,265, 21, 21, 0, 0, & 323,0.090D0, 0,222, 38, 21, 0, 0, & 323,0.030D0, 0,221, 38, 30, 0, 0, & 323,0.020D0, 0,221, 21, 21, 0, 0, & 324,0.540D0, 0,265, 30, 0, 0, 0, & 324,0.270D0, 0,266, 21, 0, 0, 0, & 324,0.030D0, 0,265, 30, 21, 0, 0, & 324,0.010D0, 0,266, 38, 30, 0, 0, & 324,0.010D0, 0,266, 21, 21, 0, 0, & 324,0.090D0, 0,221, 30, 21, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/ & 324,0.030D0, 0,222, 38, 30, 0, 0, & 324,0.020D0, 0,222, 21, 21, 0, 0, & 325,0.500D0, 0,266, 46, 0, 0, 0, & 325,0.500D0, 0,265, 50, 0, 0, 0, & 326,1.000D0, 0,230, 59, 0, 0, 0, & 327,0.667D0, 0, 50, 38, 0, 0, 0, & 327,0.333D0, 0, 46, 21, 0, 0, 0, & 328,0.667D0, 0, 46, 30, 0, 0, 0, & 328,0.333D0, 0, 50, 21, 0, 0, 0, & 329,0.667D0, 0, 34, 38, 0, 0, 0, & 329,0.333D0, 0, 42, 21, 0, 0, 0, & 330,0.667D0, 0, 42, 30, 0, 0, 0, & 330,0.333D0, 0, 34, 21, 0, 0, 0, & 331,0.667D0, 0,140, 38, 0, 0, 0, & 331,0.333D0, 0,136, 21, 0, 0, 0, & 332,0.667D0, 0,136, 30, 0, 0, 0, & 332,0.333D0, 0,140, 21, 0, 0, 0, & 333,0.500D0, 0,136, 50, 0, 0, 0, & 333,0.500D0, 0,140, 46, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/ & 334,0.667D0, 0,175, 30, 0, 0, 0, & 334,0.333D0, 0,171, 21, 0, 0, 0, & 335,0.667D0, 0,171, 38, 0, 0, 0, & 335,0.333D0, 0,175, 21, 0, 0, 0, & 336,0.500D0, 0,171, 42, 0, 0, 0, & 336,0.500D0, 0,175, 34, 0, 0, 0, & 337,0.667D0, 0,246, 30, 0, 0, 0, & 337,0.333D0, 0,245, 21, 0, 0, 0, & 338,0.667D0, 0,245, 38, 0, 0, 0, & 338,0.333D0, 0,246, 21, 0, 0, 0, & 339,0.500D0, 0,246, 34, 0, 0, 0, & 339,0.500D0, 0,245, 42, 0, 0, 0, & 340,1.000D0, 0,254, 59, 0, 0, 0, & 341,0.667D0, 0,222, 38, 0, 0, 0, & 341,0.333D0, 0,221, 21, 0, 0, 0, & 342,0.667D0, 0,221, 30, 0, 0, 0, & 342,0.333D0, 0,222, 21, 0, 0, 0, & 343,0.500D0, 0,222, 46, 0, 0, 0, & 343,0.500D0, 0,221, 50, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/ & 344,1.000D0, 0,230, 59, 0, 0, 0, & 345,1.000D0, 0,225, 30, 0, 0, 0, & 346,1.000D0, 0,225, 21, 0, 0, 0, & 347,1.000D0, 0,225, 21, 0, 0, 0, & 348,1.000D0, 0,225, 38, 0, 0, 0, & 349,0.600D0, 0,228, 38, 0, 0, 0, & 349,0.300D0, 0,227, 21, 0, 0, 0, & 349,0.100D0, 0,227, 59, 0, 0, 0, & 350,0.600D0, 0,228, 38, 0, 0, 0, & 350,0.300D0, 0,227, 21, 0, 0, 0, & 350,0.100D0, 0,227, 59, 0, 0, 0, & 351,0.600D0, 0,227, 30, 0, 0, 0, & 351,0.300D0, 0,228, 21, 0, 0, 0, & 351,0.100D0, 0,228, 59, 0, 0, 0, & 352,0.600D0, 0,227, 30, 0, 0, 0, & 352,0.300D0, 0,228, 21, 0, 0, 0, & 352,0.100D0, 0,228, 59, 0, 0, 0, & 353,1.000D0, 0,229, 59, 0, 0, 0, & 354,1.000D0, 0,249, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/ & 355,1.000D0, 0,249, 21, 0, 0, 0, & 356,1.000D0, 0,249, 21, 0, 0, 0, & 357,1.000D0, 0,249, 30, 0, 0, 0, & 358,0.600D0, 0,252, 30, 0, 0, 0, & 358,0.300D0, 0,251, 21, 0, 0, 0, & 358,0.100D0, 0,251, 59, 0, 0, 0, & 359,0.600D0, 0,252, 30, 0, 0, 0, & 359,0.300D0, 0,251, 21, 0, 0, 0, & 359,0.100D0, 0,251, 59, 0, 0, 0, & 360,0.600D0, 0,251, 38, 0, 0, 0, & 360,0.300D0, 0,252, 21, 0, 0, 0, & 360,0.100D0, 0,252, 59, 0, 0, 0, & 361,0.600D0, 0,251, 38, 0, 0, 0, & 361,0.300D0, 0,252, 21, 0, 0, 0, & 361,0.100D0, 0,252, 59, 0, 0, 0, & 362,1.000D0, 0,253, 59, 0, 0, 0, & 363,0.400D0, 0, 53, 38, 0, 0, 0, & 363,0.200D0, 0, 49, 21, 0, 0, 0, & 363,0.100D0, 0, 51, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/ & 363,0.050D0, 0, 47, 21, 0, 0, 0, & 363,0.150D0, 0, 46, 26, 0, 0, 0, & 363,0.050D0, 0, 46, 56, 0, 0, 0, & 363,0.050D0, 0, 46, 24, 0, 0, 0, & 364,0.400D0, 0, 49, 30, 0, 0, 0, & 364,0.200D0, 0, 53, 21, 0, 0, 0, & 364,0.100D0, 0, 47, 30, 0, 0, 0, & 364,0.050D0, 0, 51, 21, 0, 0, 0, & 364,0.150D0, 0, 50, 26, 0, 0, 0, & 364,0.050D0, 0, 50, 56, 0, 0, 0, & 364,0.050D0, 0, 50, 24, 0, 0, 0, & 365,0.400D0, 0, 37, 38, 0, 0, 0, & 365,0.200D0, 0, 45, 21, 0, 0, 0, & 365,0.100D0, 0, 35, 38, 0, 0, 0, & 365,0.050D0, 0, 43, 21, 0, 0, 0, & 365,0.150D0, 0, 42, 26, 0, 0, 0, & 365,0.050D0, 0, 42, 56, 0, 0, 0, & 365,0.050D0, 0, 42, 24, 0, 0, 0, & 366,0.400D0, 0, 45, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/ & 366,0.200D0, 0, 37, 21, 0, 0, 0, & 366,0.100D0, 0, 43, 30, 0, 0, 0, & 366,0.050D0, 0, 35, 21, 0, 0, 0, & 366,0.150D0, 0, 34, 26, 0, 0, 0, & 366,0.050D0, 0, 34, 56, 0, 0, 0, & 366,0.050D0, 0, 34, 24, 0, 0, 0, & 367,0.258D0, 0, 50, 38, 0, 0, 0, & 367,0.129D0, 0, 46, 21, 0, 0, 0, & 367,0.209D0, 0, 50, 39, 0, 0, 0, & 367,0.105D0, 0, 46, 23, 0, 0, 0, & 367,0.199D0, 0, 51, 38, 0, 0, 0, & 367,0.100D0, 0, 47, 21, 0, 0, 0, & 368,0.258D0, 0, 46, 30, 0, 0, 0, & 368,0.129D0, 0, 50, 21, 0, 0, 0, & 368,0.209D0, 0, 46, 31, 0, 0, 0, & 368,0.105D0, 0, 50, 23, 0, 0, 0, & 368,0.199D0, 0, 47, 30, 0, 0, 0, & 368,0.100D0, 0, 51, 21, 0, 0, 0, & 369,0.258D0, 0, 34, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/ & 369,0.129D0, 0, 42, 21, 0, 0, 0, & 369,0.209D0, 0, 34, 39, 0, 0, 0, & 369,0.105D0, 0, 42, 23, 0, 0, 0, & 369,0.199D0, 0, 35, 38, 0, 0, 0, & 369,0.100D0, 0, 43, 21, 0, 0, 0, & 370,0.258D0, 0, 42, 30, 0, 0, 0, & 370,0.129D0, 0, 34, 21, 0, 0, 0, & 370,0.209D0, 0, 42, 31, 0, 0, 0, & 370,0.105D0, 0, 34, 23, 0, 0, 0, & 370,0.199D0, 0, 43, 30, 0, 0, 0, & 370,0.100D0, 0, 35, 21, 0, 0, 0, & 371,0.400D0, 0, 53, 38, 0, 0, 0, & 371,0.200D0, 0, 49, 21, 0, 0, 0, & 371,0.100D0, 0, 51, 38, 0, 0, 0, & 371,0.050D0, 0, 47, 21, 0, 0, 0, & 371,0.150D0, 0, 46, 26, 0, 0, 0, & 371,0.050D0, 0, 46, 56, 0, 0, 0, & 371,0.050D0, 0, 46, 24, 0, 0, 0, & 372,0.400D0, 0, 49, 30, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/ & 372,0.200D0, 0, 53, 21, 0, 0, 0, & 372,0.100D0, 0, 47, 30, 0, 0, 0, & 372,0.050D0, 0, 51, 21, 0, 0, 0, & 372,0.150D0, 0, 50, 26, 0, 0, 0, & 372,0.050D0, 0, 50, 56, 0, 0, 0, & 372,0.050D0, 0, 50, 24, 0, 0, 0, & 373,0.400D0, 0, 37, 38, 0, 0, 0, & 373,0.200D0, 0, 45, 21, 0, 0, 0, & 373,0.100D0, 0, 35, 38, 0, 0, 0, & 373,0.050D0, 0, 43, 21, 0, 0, 0, & 373,0.150D0, 0, 42, 26, 0, 0, 0, & 373,0.050D0, 0, 42, 56, 0, 0, 0, & 373,0.050D0, 0, 42, 24, 0, 0, 0, & 374,0.400D0, 0, 45, 30, 0, 0, 0, & 374,0.200D0, 0, 37, 21, 0, 0, 0, & 374,0.100D0, 0, 43, 30, 0, 0, 0, & 374,0.050D0, 0, 35, 21, 0, 0, 0, & 374,0.150D0, 0, 34, 26, 0, 0, 0, & 374,0.050D0, 0, 34, 56, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/ & 374,0.050D0, 0, 34, 24, 0, 0, 0, & 375,0.208D0, 0, 50, 39, 0, 0, 0, & 375,0.104D0, 0, 46, 23, 0, 0, 0, & 375,0.134D0, 0, 51, 38, 0, 0, 0, & 375,0.067D0, 0, 47, 21, 0, 0, 0, & 375,0.124D0, 0, 50, 38, 0, 0, 0, & 375,0.062D0, 0, 46, 21, 0, 0, 0, & 375,0.301D0, 0, 46, 22, 0, 0, 0, & 376,0.208D0, 0, 46, 31, 0, 0, 0, & 376,0.104D0, 0, 50, 23, 0, 0, 0, & 376,0.134D0, 0, 47, 30, 0, 0, 0, & 376,0.067D0, 0, 51, 21, 0, 0, 0, & 376,0.124D0, 0, 46, 30, 0, 0, 0, & 376,0.062D0, 0, 50, 21, 0, 0, 0, & 376,0.301D0, 0, 50, 22, 0, 0, 0, & 377,0.208D0, 0, 34, 39, 0, 0, 0, & 377,0.104D0, 0, 42, 23, 0, 0, 0, & 377,0.134D0, 0, 35, 38, 0, 0, 0, & 377,0.067D0, 0, 43, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/ & 377,0.124D0, 0, 34, 38, 0, 0, 0, & 377,0.062D0, 0, 42, 21, 0, 0, 0, & 377,0.301D0, 0, 42, 22, 0, 0, 0, & 378,0.208D0, 0, 42, 31, 0, 0, 0, & 378,0.104D0, 0, 34, 23, 0, 0, 0, & 378,0.134D0, 0, 43, 30, 0, 0, 0, & 378,0.067D0, 0, 35, 21, 0, 0, 0, & 378,0.124D0, 0, 42, 30, 0, 0, 0, & 378,0.062D0, 0, 34, 21, 0, 0, 0, & 378,0.301D0, 0, 34, 22, 0, 0, 0, & 379,0.562D0, 0, 26, 38, 0, 0, 0, & 379,0.155D0, 0, 39, 21, 0, 0, 0, & 379,0.155D0, 0, 23, 38, 0, 0, 0, & 379,0.088D0, 0,293, 38, 0, 0, 0, & 379,0.020D0, 0, 46, 43, 0, 0, 0, & 379,0.020D0, 0, 42, 47, 0, 0, 0, & 380,0.562D0, 0, 26, 21, 0, 0, 0, & 380,0.155D0, 0, 39, 30, 0, 0, 0, & 380,0.155D0, 0, 31, 38, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/ & 380,0.088D0, 0,293, 21, 0, 0, 0, & 380,0.010D0, 0, 46, 35, 0, 0, 0, & 380,0.010D0, 0, 50, 43, 0, 0, 0, & 380,0.010D0, 0, 34, 47, 0, 0, 0, & 380,0.010D0, 0, 42, 51, 0, 0, 0, & 381,0.562D0, 0, 26, 30, 0, 0, 0, & 381,0.155D0, 0, 31, 21, 0, 0, 0, & 381,0.155D0, 0, 23, 30, 0, 0, 0, & 381,0.088D0, 0,293, 30, 0, 0, 0, & 381,0.020D0, 0, 34, 51, 0, 0, 0, & 381,0.020D0, 0, 50, 35, 0, 0, 0, & 382,0.360D0, 0, 31, 38, 38, 0, 0, & 382,0.180D0, 0, 23, 38, 21, 0, 0, & 382,0.040D0, 0, 39, 21, 21, 0, 0, & 382,0.020D0, 0, 39, 38, 30, 0, 0, & 382,0.300D0, 0, 38, 21, 0, 0, 0, & 382,0.040D0, 0, 46, 43, 0, 0, 0, & 382,0.040D0, 0, 42, 47, 0, 0, 0, & 382,0.020D0, 0, 22, 39, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/ & 383,0.180D0, 0, 39, 30, 21, 0, 0, & 383,0.180D0, 0, 31, 38, 21, 0, 0, & 383,0.160D0, 0, 23, 21, 21, 0, 0, & 383,0.080D0, 0, 23, 38, 30, 0, 0, & 383,0.300D0, 0, 38, 30, 0, 0, 0, & 383,0.020D0, 0, 46, 35, 0, 0, 0, & 383,0.020D0, 0, 50, 43, 0, 0, 0, & 383,0.020D0, 0, 34, 47, 0, 0, 0, & 383,0.020D0, 0, 42, 51, 0, 0, 0, & 383,0.020D0, 0, 22, 23, 0, 0, 0, & 384,0.360D0, 0, 39, 30, 30, 0, 0, & 384,0.180D0, 0, 23, 30, 21, 0, 0, & 384,0.040D0, 0, 31, 21, 21, 0, 0, & 384,0.020D0, 0, 31, 30, 38, 0, 0, & 384,0.300D0, 0, 30, 21, 0, 0, 0, & 384,0.040D0, 0, 34, 51, 0, 0, 0, & 384,0.040D0, 0, 50, 35, 0, 0, 0, & 384,0.020D0, 0, 22, 31, 0, 0, 0, & 385,0.184D0, 0, 41, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/ & 385,0.184D0, 0, 29, 38, 0, 0, 0, & 385,0.184D0, 0, 39, 23, 0, 0, 0, & 385,0.236D0, 0, 38, 21, 0, 0, 0, & 385,0.160D0, 0, 24, 38, 0, 0, 0, & 385,0.018D0, 0, 46, 43, 0, 0, 0, & 385,0.018D0, 0, 42, 47, 0, 0, 0, & 385,0.016D0, 0, 46, 42, 0, 0, 0, & 386,0.184D0, 0, 41, 30, 0, 0, 0, & 386,0.184D0, 0, 33, 38, 0, 0, 0, & 386,0.184D0, 0, 39, 31, 0, 0, 0, & 386,0.236D0, 0, 38, 30, 0, 0, 0, & 386,0.160D0, 0, 24, 21, 0, 0, 0, & 386,0.009D0, 0, 46, 35, 0, 0, 0, & 386,0.009D0, 0, 50, 43, 0, 0, 0, & 386,0.009D0, 0, 34, 47, 0, 0, 0, & 386,0.009D0, 0, 42, 51, 0, 0, 0, & 386,0.008D0, 0, 46, 34, 0, 0, 0, & 386,0.008D0, 0, 42, 50, 0, 0, 0, & 387,0.184D0, 0, 33, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/ & 387,0.184D0, 0, 29, 30, 0, 0, 0, & 387,0.184D0, 0, 31, 23, 0, 0, 0, & 387,0.236D0, 0, 30, 21, 0, 0, 0, & 387,0.160D0, 0, 24, 30, 0, 0, 0, & 387,0.018D0, 0, 34, 51, 0, 0, 0, & 387,0.018D0, 0, 50, 35, 0, 0, 0, & 387,0.016D0, 0, 34, 50, 0, 0, 0, & 388,0.183D0, 0,231, 38, 30, 0, 0, & 388,0.091D0, 0,231, 21, 21, 0, 0, & 388,0.067D0, 0, 59,307, 0, 0, 0, & 388,0.066D0, 0, 59,308, 0, 0, 0, & 388,0.043D0, 0, 59,309, 0, 0, 0, & 388,0.446D0,130, 13, 13, 13, 0, 0, & 388,0.023D0,130, 13, 13, 59, 0, 0, & 388,0.013D0, 0,121,127, 0, 0, 0, & 388,0.013D0, 0,123,129, 0, 0, 0, & 388,0.013D0, 0,125,131, 0, 0, 0, & 388,0.004D0, 0, 1, 7, 0, 0, 0, & 388,0.017D0, 0, 2, 8, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/ & 388,0.004D0, 0, 3, 9, 0, 0, 0, & 388,0.017D0, 0, 4, 10, 0, 0, 0, & 389,0.046D0, 0, 59,388, 0, 0, 0, & 389,0.009D0, 0, 59,231, 0, 0, 0, & 389,0.755D0, 0, 13, 13, 0, 0, 0, & 389,0.030D0, 0,121,127, 0, 0, 0, & 389,0.030D0, 0,123,129, 0, 0, 0, & 389,0.030D0, 0,125,131, 0, 0, 0, & 389,0.010D0, 0, 1, 7, 0, 0, 0, & 389,0.040D0, 0, 2, 8, 0, 0, 0, & 389,0.010D0, 0, 3, 9, 0, 0, 0, & 389,0.040D0, 0, 4, 10, 0, 0, 0, & 390,0.210D0, 0, 59,388, 0, 0, 0, & 390,0.085D0, 0, 59,231, 0, 0, 0, & 390,0.565D0, 0, 13, 13, 0, 0, 0, & 390,0.022D0, 0,121,127, 0, 0, 0, & 390,0.022D0, 0,123,129, 0, 0, 0, & 390,0.022D0, 0,125,131, 0, 0, 0, & 390,0.007D0, 0, 1, 7, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/ & 390,0.030D0, 0, 2, 8, 0, 0, 0, & 390,0.007D0, 0, 3, 9, 0, 0, 0, & 390,0.030D0, 0, 4, 10, 0, 0, 0, & 391,0.162D0, 0, 59,388, 0, 0, 0, & 391,0.071D0, 0, 59,231, 0, 0, 0, & 391,0.615D0, 0, 13, 13, 0, 0, 0, & 391,0.024D0, 0,121,127, 0, 0, 0, & 391,0.024D0, 0,123,129, 0, 0, 0, & 391,0.024D0, 0,125,131, 0, 0, 0, & 391,0.008D0, 0, 1, 7, 0, 0, 0, & 391,0.032D0, 0, 2, 8, 0, 0, 0, & 391,0.008D0, 0, 3, 9, 0, 0, 0, & 391,0.032D0, 0, 4, 10, 0, 0, 0, & 392,0.034D0, 0,267, 38, 30, 0, 0, & 392,0.017D0, 0,267, 21, 21, 0, 0, & 392,0.044D0, 0,231, 38, 30, 0, 0, & 392,0.022D0, 0,231, 21, 21, 0, 0, & 392,0.050D0, 0,267, 59, 59, 0, 0, & 392,0.114D0, 0, 59,389, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/ & 392,0.113D0, 0, 59,390, 0, 0, 0, & 392,0.054D0, 0, 59,391, 0, 0, 0, & 392,0.403D0,130, 13, 13, 13, 0, 0, & 392,0.021D0,130, 13, 13, 59, 0, 0, & 392,0.020D0, 0,121,127, 0, 0, 0, & 392,0.020D0, 0,123,129, 0, 0, 0, & 392,0.020D0, 0,125,131, 0, 0, 0, & 392,0.007D0, 0, 1, 7, 0, 0, 0, & 392,0.027D0, 0, 2, 8, 0, 0, 0, & 392,0.007D0, 0, 3, 9, 0, 0, 0, & 392,0.027D0, 0, 4, 10, 0, 0, 0, & 393,0.250D0, 0,246,222, 0, 0, 0, & 393,0.250D0, 0,245,221, 0, 0, 0, & 393,0.385D0,130, 13, 13, 13, 0, 0, & 393,0.020D0,130, 13, 13, 59, 0, 0, & 393,0.015D0, 0,121,127, 0, 0, 0, & 393,0.015D0, 0,123,129, 0, 0, 0, & 393,0.015D0, 0,125,131, 0, 0, 0, & 393,0.005D0, 0, 1, 7, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/ & 393,0.020D0, 0, 2, 8, 0, 0, 0, & 393,0.005D0, 0, 3, 9, 0, 0, 0, & 393,0.020D0, 0, 4, 10, 0, 0, 0, & 395,0.195D0, 0, 39, 30, 0, 0, 0, & 395,0.195D0, 0, 23, 21, 0, 0, 0, & 395,0.195D0, 0, 31, 38, 0, 0, 0, & 395,0.105D0, 0,286, 30, 0, 0, 0, & 395,0.105D0, 0,285, 21, 0, 0, 0, & 395,0.105D0, 0,287, 38, 0, 0, 0, & 395,0.065D0, 0, 24, 38, 30, 0, 0, & 395,0.035D0, 0, 24, 21, 21, 0, 0, & 396,0.320D0, 0, 46, 34, 0, 0, 0, & 396,0.320D0, 0, 60, 61, 0, 0, 0, & 396,0.090D0, 0, 46, 35, 0, 0, 0, & 396,0.090D0, 0, 42, 51, 0, 0, 0, & 396,0.090D0, 0, 50, 43, 0, 0, 0, & 396,0.090D0, 0, 34, 47, 0, 0, 0, & 397,0.312D0, 0, 41, 30, 0, 0, 0, & 397,0.312D0, 0, 29, 21, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/ & 397,0.312D0, 0, 33, 38, 0, 0, 0, & 397,0.016D0, 0, 46, 35, 0, 0, 0, & 397,0.016D0, 0, 42, 51, 0, 0, 0, & 397,0.016D0, 0, 50, 43, 0, 0, 0, & 397,0.016D0, 0, 34, 47, 0, 0, 0, & 398,0.805D0, 0, 26, 22, 0, 0, 0, & 398,0.065D0, 0, 41, 30, 0, 0, 0, & 398,0.065D0, 0, 29, 21, 0, 0, 0, & 398,0.065D0, 0, 33, 38, 0, 0, 0, & 399,0.667D0, 0, 24, 38, 30, 0, 0, & 399,0.333D0, 0, 24, 21, 21, 0, 0, & 62,0.440D0, 0, 21, 22, 0, 0, 0, & 62,0.160D0, 0, 21, 25, 0, 0, 0, & 62,0.200D0, 0, 50, 42, 0, 0, 0, & 62,0.200D0, 0, 46, 34, 0, 0, 0, & 63,0.440D0, 0, 38, 22, 0, 0, 0, & 63,0.160D0, 0, 38, 25, 0, 0, 0, & 63,0.400D0, 0, 46, 42, 0, 0, 0, & 64,0.440D0, 0, 30, 22, 0, 0, 0/ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/ & 64,0.160D0, 0, 30, 25, 0, 0, 0, & 64,0.400D0, 0, 50, 34, 0, 0, 0/ C--data for MRST98 LO PDF's DATA (FMRS(1,1,I, 1),I=1,49)/ & 0.01518D0, 0.01868D0, 0.02298D0, 0.02594D0, 0.02828D0, & 0.03023D0, 0.03724D0, 0.04592D0, 0.05197D0, 0.05679D0, & 0.06085D0, 0.07576D0, 0.09547D0, 0.11035D0, 0.12307D0, & 0.13453D0, 0.15525D0, 0.18319D0, 0.22542D0, 0.26441D0, & 0.33553D0, 0.39881D0, 0.45451D0, 0.51363D0, 0.56120D0, & 0.59755D0, 0.62324D0, 0.63889D0, 0.64529D0, 0.64295D0, & 0.63335D0, 0.61691D0, 0.59464D0, 0.56748D0, 0.53621D0, & 0.50180D0, 0.46495D0, 0.42660D0, 0.38735D0, 0.34791D0, & 0.30888D0, 0.27105D0, 0.23455D0, 0.16807D0, 0.11197D0, & 0.06774D0, 0.03566D0, 0.00443D0, 0.00000D0/ DATA (FMRS(1,1,I, 2),I=1,49)/ & 0.01534D0, 0.01889D0, 0.02325D0, 0.02625D0, 0.02862D0, & 0.03061D0, 0.03771D0, 0.04653D0, 0.05268D0, 0.05757D0, & 0.06171D0, 0.07691D0, 0.09707D0, 0.11230D0, 0.12533D0, & 0.13708D0, 0.15827D0, 0.18678D0, 0.22968D0, 0.26907D0, & 0.34038D0, 0.40321D0, 0.45801D0, 0.51556D0, 0.56122D0, & 0.59551D0, 0.61905D0, 0.63261D0, 0.63699D0, 0.63286D0, & 0.62162D0, 0.60381D0, 0.58043D0, 0.55244D0, 0.52060D0, & 0.48591D0, 0.44902D0, 0.41090D0, 0.37213D0, 0.33332D0, & 0.29514D0, 0.25827D0, 0.22283D0, 0.15873D0, 0.10506D0, & 0.06310D0, 0.03294D0, 0.00399D0, 0.00000D0/ DATA (FMRS(1,1,I, 3),I=1,49)/ & 0.01559D0, 0.01920D0, 0.02365D0, 0.02672D0, 0.02914D0, & 0.03116D0, 0.03842D0, 0.04744D0, 0.05374D0, 0.05876D0, & 0.06301D0, 0.07866D0, 0.09949D0, 0.11525D0, 0.12874D0, & 0.14090D0, 0.16278D0, 0.19212D0, 0.23598D0, 0.27589D0, & 0.34735D0, 0.40941D0, 0.46279D0, 0.51792D0, 0.56073D0, & 0.59195D0, 0.61237D0, 0.62289D0, 0.62439D0, 0.61773D0, & 0.60419D0, 0.58448D0, 0.55962D0, 0.53052D0, 0.49799D0, & 0.46298D0, 0.42617D0, 0.38844D0, 0.35048D0, 0.31268D0, & 0.27573D0, 0.24031D0, 0.20643D0, 0.14575D0, 0.09554D0, & 0.05679D0, 0.02927D0, 0.00342D0, 0.00000D0/ DATA (FMRS(1,1,I, 4),I=1,49)/ & 0.01577D0, 0.01944D0, 0.02395D0, 0.02707D0, 0.02952D0, & 0.03158D0, 0.03895D0, 0.04812D0, 0.05453D0, 0.05964D0, & 0.06398D0, 0.07996D0, 0.10128D0, 0.11743D0, 0.13126D0, & 0.14371D0, 0.16610D0, 0.19602D0, 0.24052D0, 0.28078D0, & 0.35225D0, 0.41367D0, 0.46596D0, 0.51926D0, 0.56000D0, & 0.58897D0, 0.60716D0, 0.61554D0, 0.61505D0, 0.60661D0, & 0.59150D0, 0.57049D0, 0.54465D0, 0.51484D0, 0.48194D0, & 0.44680D0, 0.41012D0, 0.37271D0, 0.33536D0, 0.29833D0, & 0.26227D0, 0.22791D0, 0.19519D0, 0.13692D0, 0.08913D0, & 0.05257D0, 0.02685D0, 0.00306D0, 0.00000D0/ DATA (FMRS(1,1,I, 5),I=1,49)/ & 0.01597D0, 0.01969D0, 0.02427D0, 0.02744D0, 0.02993D0, & 0.03202D0, 0.03952D0, 0.04885D0, 0.05537D0, 0.06058D0, & 0.06501D0, 0.08134D0, 0.10319D0, 0.11975D0, 0.13393D0, & 0.14669D0, 0.16958D0, 0.20009D0, 0.24521D0, 0.28578D0, & 0.35715D0, 0.41781D0, 0.46887D0, 0.52022D0, 0.55877D0, & 0.58539D0, 0.60126D0, 0.60744D0, 0.60489D0, 0.59469D0, & 0.57807D0, 0.55581D0, 0.52903D0, 0.49861D0, 0.46535D0, & 0.43012D0, 0.39368D0, 0.35672D0, 0.32002D0, 0.28380D0, & 0.24878D0, 0.21549D0, 0.18398D0, 0.12819D0, 0.08284D0, & 0.04845D0, 0.02451D0, 0.00272D0, 0.00000D0/ DATA (FMRS(1,1,I, 6),I=1,49)/ & 0.01613D0, 0.01990D0, 0.02455D0, 0.02776D0, 0.03029D0, & 0.03241D0, 0.04001D0, 0.04949D0, 0.05611D0, 0.06141D0, & 0.06592D0, 0.08256D0, 0.10485D0, 0.12178D0, 0.13626D0, & 0.14927D0, 0.17260D0, 0.20361D0, 0.24924D0, 0.29005D0, & 0.36128D0, 0.42124D0, 0.47121D0, 0.52086D0, 0.55750D0, & 0.58213D0, 0.59603D0, 0.60035D0, 0.59612D0, 0.58445D0, & 0.56659D0, 0.54334D0, 0.51581D0, 0.48493D0, 0.45142D0, & 0.41618D0, 0.37998D0, 0.34345D0, 0.30732D0, 0.27182D0, & 0.23768D0, 0.20532D0, 0.17482D0, 0.12110D0, 0.07777D0, & 0.04515D0, 0.02267D0, 0.00245D0, 0.00000D0/ DATA (FMRS(1,1,I, 7),I=1,49)/ & 0.01630D0, 0.02011D0, 0.02482D0, 0.02807D0, 0.03063D0, & 0.03278D0, 0.04049D0, 0.05010D0, 0.05683D0, 0.06221D0, & 0.06680D0, 0.08373D0, 0.10647D0, 0.12373D0, 0.13849D0, & 0.15175D0, 0.17549D0, 0.20695D0, 0.25304D0, 0.29403D0, & 0.36506D0, 0.42430D0, 0.47319D0, 0.52118D0, 0.55597D0, & 0.57870D0, 0.59079D0, 0.59337D0, 0.58760D0, 0.57458D0, & 0.55556D0, 0.53145D0, 0.50329D0, 0.47196D0, 0.43832D0, & 0.40316D0, 0.36719D0, 0.33110D0, 0.29555D0, 0.26076D0, & 0.22742D0, 0.19600D0, 0.16642D0, 0.11467D0, 0.07318D0, & 0.04221D0, 0.02103D0, 0.00223D0, 0.00000D0/ DATA (FMRS(1,1,I, 8),I=1,49)/ & 0.01647D0, 0.02033D0, 0.02511D0, 0.02840D0, 0.03100D0, & 0.03318D0, 0.04101D0, 0.05076D0, 0.05760D0, 0.06307D0, & 0.06774D0, 0.08499D0, 0.10819D0, 0.12581D0, 0.14088D0, & 0.15440D0, 0.17856D0, 0.21047D0, 0.25702D0, 0.29817D0, & 0.36893D0, 0.42735D0, 0.47507D0, 0.52128D0, 0.55411D0, & 0.57487D0, 0.58505D0, 0.58586D0, 0.57850D0, 0.56412D0, & 0.54397D0, 0.51898D0, 0.49021D0, 0.45851D0, 0.42474D0, & 0.38970D0, 0.35404D0, 0.31842D0, 0.28351D0, 0.24949D0, & 0.21700D0, 0.18654D0, 0.15795D0, 0.10821D0, 0.06861D0, & 0.03930D0, 0.01942D0, 0.00201D0, 0.00000D0/ DATA (FMRS(1,1,I, 9),I=1,49)/ & 0.01662D0, 0.02053D0, 0.02536D0, 0.02869D0, 0.03133D0, & 0.03353D0, 0.04146D0, 0.05135D0, 0.05828D0, 0.06382D0, & 0.06856D0, 0.08610D0, 0.10971D0, 0.12764D0, 0.14296D0, & 0.15670D0, 0.18121D0, 0.21352D0, 0.26045D0, 0.30172D0, & 0.37220D0, 0.42986D0, 0.47655D0, 0.52120D0, 0.55234D0, & 0.57141D0, 0.57995D0, 0.57927D0, 0.57058D0, 0.55506D0, & 0.53402D0, 0.50830D0, 0.47904D0, 0.44709D0, 0.41323D0, & 0.37832D0, 0.34296D0, 0.30776D0, 0.27344D0, 0.24008D0, & 0.20833D0, 0.17868D0, 0.15093D0, 0.10287D0, 0.06487D0, & 0.03693D0, 0.01812D0, 0.00183D0, 0.00000D0/ DATA (FMRS(1,1,I,10),I=1,49)/ & 0.01676D0, 0.02072D0, 0.02560D0, 0.02898D0, 0.03164D0, & 0.03388D0, 0.04190D0, 0.05191D0, 0.05894D0, 0.06456D0, & 0.06937D0, 0.08718D0, 0.11117D0, 0.12940D0, 0.14497D0, & 0.15892D0, 0.18377D0, 0.21643D0, 0.26368D0, 0.30503D0, & 0.37520D0, 0.43209D0, 0.47774D0, 0.52089D0, 0.55041D0, & 0.56787D0, 0.57486D0, 0.57280D0, 0.56285D0, 0.54631D0, & 0.52442D0, 0.49810D0, 0.46842D0, 0.43624D0, 0.40236D0, & 0.36762D0, 0.33255D0, 0.29778D0, 0.26402D0, 0.23132D0, & 0.20029D0, 0.17139D0, 0.14445D0, 0.09798D0, 0.06147D0, & 0.03479D0, 0.01695D0, 0.00168D0, 0.00000D0/ DATA (FMRS(1,1,I,11),I=1,49)/ & 0.01688D0, 0.02087D0, 0.02580D0, 0.02920D0, 0.03189D0, & 0.03415D0, 0.04225D0, 0.05236D0, 0.05946D0, 0.06515D0, & 0.07001D0, 0.08804D0, 0.11234D0, 0.13081D0, 0.14657D0, & 0.16068D0, 0.18579D0, 0.21873D0, 0.26622D0, 0.30762D0, & 0.37751D0, 0.43378D0, 0.47859D0, 0.52054D0, 0.54880D0, & 0.56500D0, 0.57079D0, 0.56765D0, 0.55675D0, 0.53942D0, & 0.51689D0, 0.49012D0, 0.46015D0, 0.42782D0, 0.39393D0, & 0.35936D0, 0.32453D0, 0.29009D0, 0.25678D0, 0.22461D0, & 0.19416D0, 0.16583D0, 0.13951D0, 0.09427D0, 0.05892D0, & 0.03318D0, 0.01609D0, 0.00157D0, 0.00000D0/ DATA (FMRS(1,1,I,12),I=1,49)/ & 0.01713D0, 0.02119D0, 0.02622D0, 0.02969D0, 0.03243D0, & 0.03474D0, 0.04300D0, 0.05334D0, 0.06060D0, 0.06641D0, & 0.07140D0, 0.08989D0, 0.11485D0, 0.13381D0, 0.14997D0, & 0.16442D0, 0.19008D0, 0.22357D0, 0.27152D0, 0.31299D0, & 0.38219D0, 0.43708D0, 0.48008D0, 0.51946D0, 0.54505D0, & 0.55859D0, 0.56192D0, 0.55654D0, 0.54370D0, 0.52483D0, & 0.50100D0, 0.47335D0, 0.44283D0, 0.41025D0, 0.37649D0, & 0.34225D0, 0.30799D0, 0.27433D0, 0.24202D0, 0.21092D0, & 0.18167D0, 0.15459D0, 0.12954D0, 0.08683D0, 0.05380D0, & 0.03001D0, 0.01438D0, 0.00136D0, 0.00000D0/ DATA (FMRS(1,1,I,13),I=1,49)/ & 0.01734D0, 0.02147D0, 0.02658D0, 0.03011D0, 0.03290D0, & 0.03525D0, 0.04366D0, 0.05419D0, 0.06158D0, 0.06752D0, & 0.07261D0, 0.09150D0, 0.11703D0, 0.13641D0, 0.15292D0, & 0.16765D0, 0.19375D0, 0.22769D0, 0.27599D0, 0.31747D0, & 0.38599D0, 0.43964D0, 0.48105D0, 0.51822D0, 0.54152D0, & 0.55284D0, 0.55412D0, 0.54689D0, 0.53251D0, 0.51240D0, & 0.48756D0, 0.45925D0, 0.42833D0, 0.39563D0, 0.36202D0, & 0.32809D0, 0.29438D0, 0.26143D0, 0.22998D0, 0.19977D0, & 0.17155D0, 0.14553D0, 0.12155D0, 0.08091D0, 0.04976D0, & 0.02753D0, 0.01306D0, 0.00120D0, 0.00000D0/ DATA (FMRS(1,1,I,14),I=1,49)/ & 0.01759D0, 0.02179D0, 0.02699D0, 0.03059D0, 0.03343D0, & 0.03582D0, 0.04441D0, 0.05515D0, 0.06270D0, 0.06876D0, & 0.07397D0, 0.09331D0, 0.11948D0, 0.13933D0, 0.15621D0, & 0.17125D0, 0.19782D0, 0.23224D0, 0.28086D0, 0.32228D0, & 0.38998D0, 0.44216D0, 0.48181D0, 0.51649D0, 0.53727D0, & 0.54619D0, 0.54525D0, 0.53606D0, 0.52007D0, 0.49864D0, & 0.47286D0, 0.44390D0, 0.41261D0, 0.37987D0, 0.34645D0, & 0.31295D0, 0.27985D0, 0.24773D0, 0.21718D0, 0.18802D0, & 0.16091D0, 0.13605D0, 0.11323D0, 0.07479D0, 0.04562D0, & 0.02500D0, 0.01174D0, 0.00105D0, 0.00000D0/ DATA (FMRS(1,1,I,15),I=1,49)/ & 0.01784D0, 0.02212D0, 0.02742D0, 0.03109D0, 0.03399D0, & 0.03643D0, 0.04519D0, 0.05616D0, 0.06388D0, 0.07007D0, & 0.07541D0, 0.09522D0, 0.12203D0, 0.14235D0, 0.15961D0, & 0.17496D0, 0.20199D0, 0.23684D0, 0.28574D0, 0.32703D0, & 0.39374D0, 0.44435D0, 0.48208D0, 0.51422D0, 0.53243D0, & 0.53888D0, 0.53581D0, 0.52470D0, 0.50714D0, 0.48444D0, & 0.45778D0, 0.42824D0, 0.39670D0, 0.36400D0, 0.33079D0, & 0.29784D0, 0.26546D0, 0.23422D0, 0.20462D0, 0.17657D0, & 0.15056D0, 0.12684D0, 0.10517D0, 0.06893D0, 0.04169D0, & 0.02264D0, 0.01051D0, 0.00091D0, 0.00000D0/ DATA (FMRS(1,1,I,16),I=1,49)/ & 0.01807D0, 0.02243D0, 0.02782D0, 0.03155D0, 0.03450D0, & 0.03698D0, 0.04591D0, 0.05708D0, 0.06495D0, 0.07127D0, & 0.07672D0, 0.09696D0, 0.12435D0, 0.14510D0, 0.16268D0, & 0.17830D0, 0.20573D0, 0.24094D0, 0.29002D0, 0.33115D0, & 0.39689D0, 0.44603D0, 0.48202D0, 0.51185D0, 0.52778D0, & 0.53213D0, 0.52713D0, 0.51440D0, 0.49550D0, 0.47182D0, & 0.44444D0, 0.41444D0, 0.38277D0, 0.35014D0, 0.31726D0, & 0.28479D0, 0.25306D0, 0.22258D0, 0.19389D0, 0.16682D0, & 0.14175D0, 0.11905D0, 0.09839D0, 0.06403D0, 0.03844D0, & 0.02069D0, 0.00951D0, 0.00080D0, 0.00000D0/ DATA (FMRS(1,1,I,17),I=1,49)/ & 0.01831D0, 0.02273D0, 0.02822D0, 0.03202D0, 0.03502D0, & 0.03755D0, 0.04663D0, 0.05802D0, 0.06604D0, 0.07249D0, & 0.07805D0, 0.09872D0, 0.12670D0, 0.14787D0, 0.16578D0, & 0.18165D0, 0.20947D0, 0.24500D0, 0.29423D0, 0.33515D0, & 0.39986D0, 0.44747D0, 0.48171D0, 0.50924D0, 0.52291D0, & 0.52522D0, 0.51836D0, 0.50409D0, 0.48395D0, 0.45934D0, & 0.43132D0, 0.40095D0, 0.36919D0, 0.33668D0, 0.30419D0, & 0.27223D0, 0.24118D0, 0.21147D0, 0.18368D0, 0.15756D0, & 0.13343D0, 0.11172D0, 0.09203D0, 0.05947D0, 0.03543D0, & 0.01891D0, 0.00861D0, 0.00070D0, 0.00000D0/ DATA (FMRS(1,1,I,18),I=1,49)/ & 0.01851D0, 0.02299D0, 0.02855D0, 0.03241D0, 0.03546D0, & 0.03802D0, 0.04724D0, 0.05881D0, 0.06696D0, 0.07351D0, & 0.07917D0, 0.10019D0, 0.12865D0, 0.15015D0, 0.16833D0, & 0.18440D0, 0.21252D0, 0.24831D0, 0.29761D0, 0.33832D0, & 0.40212D0, 0.44845D0, 0.48121D0, 0.50687D0, 0.51871D0, & 0.51934D0, 0.51104D0, 0.49556D0, 0.47446D0, 0.44911D0, & 0.42066D0, 0.39005D0, 0.35822D0, 0.32587D0, 0.29370D0, & 0.26224D0, 0.23174D0, 0.20270D0, 0.17561D0, 0.15023D0, & 0.12693D0, 0.10599D0, 0.08707D0, 0.05595D0, 0.03312D0, & 0.01756D0, 0.00793D0, 0.00063D0, 0.00000D0/ DATA (FMRS(1,1,I,19),I=1,49)/ & 0.01875D0, 0.02330D0, 0.02896D0, 0.03288D0, 0.03599D0, & 0.03859D0, 0.04798D0, 0.05977D0, 0.06807D0, 0.07475D0, & 0.08052D0, 0.10198D0, 0.13101D0, 0.15292D0, 0.17139D0, & 0.18771D0, 0.21617D0, 0.25222D0, 0.30155D0, 0.34198D0, & 0.40461D0, 0.44935D0, 0.48033D0, 0.50374D0, 0.51343D0, & 0.51210D0, 0.50212D0, 0.48526D0, 0.46307D0, 0.43693D0, & 0.40797D0, 0.37715D0, 0.34533D0, 0.31321D0, 0.28148D0, & 0.25058D0, 0.22080D0, 0.19255D0, 0.16635D0, 0.14187D0, & 0.11948D0, 0.09946D0, 0.08142D0, 0.05198D0, 0.03054D0, & 0.01606D0, 0.00718D0, 0.00056D0, 0.00000D0/ DATA (FMRS(1,1,I,20),I=1,49)/ & 0.01896D0, 0.02358D0, 0.02932D0, 0.03331D0, 0.03646D0, & 0.03911D0, 0.04864D0, 0.06062D0, 0.06906D0, 0.07585D0, & 0.08173D0, 0.10357D0, 0.13310D0, 0.15536D0, 0.17410D0, & 0.19062D0, 0.21937D0, 0.25563D0, 0.30495D0, 0.34510D0, & 0.40666D0, 0.44998D0, 0.47941D0, 0.50085D0, 0.50868D0, & 0.50571D0, 0.49430D0, 0.47628D0, 0.45320D0, 0.42642D0, & 0.39707D0, 0.36611D0, 0.33435D0, 0.30245D0, 0.27113D0, & 0.24074D0, 0.21159D0, 0.18404D0, 0.15862D0, 0.13491D0, & 0.11330D0, 0.09405D0, 0.07676D0, 0.04872D0, 0.02844D0, & 0.01484D0, 0.00658D0, 0.00050D0, 0.00000D0/ DATA (FMRS(1,1,I,21),I=1,49)/ & 0.01916D0, 0.02384D0, 0.02966D0, 0.03370D0, 0.03689D0, & 0.03958D0, 0.04926D0, 0.06141D0, 0.06998D0, 0.07687D0, & 0.08284D0, 0.10503D0, 0.13502D0, 0.15758D0, 0.17655D0, & 0.19325D0, 0.22223D0, 0.25866D0, 0.30794D0, 0.34779D0, & 0.40831D0, 0.45032D0, 0.47832D0, 0.49795D0, 0.50413D0, & 0.49968D0, 0.48705D0, 0.46802D0, 0.44417D0, 0.41690D0, & 0.38723D0, 0.35619D0, 0.32452D0, 0.29287D0, 0.26194D0, & 0.23205D0, 0.20344D0, 0.17655D0, 0.15180D0, 0.12880D0, & 0.10792D0, 0.08934D0, 0.07273D0, 0.04591D0, 0.02665D0, & 0.01381D0, 0.00607D0, 0.00045D0, 0.00000D0/ DATA (FMRS(1,1,I,22),I=1,49)/ & 0.01941D0, 0.02417D0, 0.03009D0, 0.03420D0, 0.03745D0, & 0.04018D0, 0.05003D0, 0.06241D0, 0.07114D0, 0.07817D0, & 0.08426D0, 0.10688D0, 0.13744D0, 0.16039D0, 0.17965D0, & 0.19656D0, 0.22582D0, 0.26244D0, 0.31163D0, 0.35107D0, & 0.41025D0, 0.45056D0, 0.47676D0, 0.49416D0, 0.49829D0, & 0.49204D0, 0.47792D0, 0.45768D0, 0.43295D0, 0.40511D0, & 0.37512D0, 0.34401D0, 0.31250D0, 0.28120D0, 0.25076D0, & 0.22150D0, 0.19361D0, 0.16754D0, 0.14361D0, 0.12149D0, & 0.10149D0, 0.08376D0, 0.06796D0, 0.04260D0, 0.02455D0, & 0.01262D0, 0.00549D0, 0.00039D0, 0.00000D0/ DATA (FMRS(1,1,I,23),I=1,49)/ & 0.01965D0, 0.02448D0, 0.03049D0, 0.03467D0, 0.03797D0, & 0.04075D0, 0.05077D0, 0.06336D0, 0.07225D0, 0.07940D0, & 0.08560D0, 0.10863D0, 0.13972D0, 0.16302D0, 0.18254D0, & 0.19964D0, 0.22916D0, 0.26592D0, 0.31498D0, 0.35400D0, & 0.41189D0, 0.45060D0, 0.47511D0, 0.49045D0, 0.49274D0, & 0.48487D0, 0.46938D0, 0.44808D0, 0.42260D0, 0.39428D0, & 0.36409D0, 0.33294D0, 0.30164D0, 0.27069D0, 0.24070D0, & 0.21203D0, 0.18488D0, 0.15951D0, 0.13633D0, 0.11502D0, & 0.09581D0, 0.07887D0, 0.06380D0, 0.03974D0, 0.02273D0, & 0.01159D0, 0.00500D0, 0.00035D0, 0.00000D0/ DATA (FMRS(1,1,I,24),I=1,49)/ & 0.01987D0, 0.02478D0, 0.03088D0, 0.03511D0, 0.03847D0, & 0.04129D0, 0.05147D0, 0.06426D0, 0.07329D0, 0.08055D0, & 0.08686D0, 0.11027D0, 0.14184D0, 0.16546D0, 0.18521D0, & 0.20248D0, 0.23220D0, 0.26906D0, 0.31795D0, 0.35654D0, & 0.41317D0, 0.45035D0, 0.47330D0, 0.48677D0, 0.48734D0, & 0.47799D0, 0.46135D0, 0.43917D0, 0.41301D0, 0.38430D0, & 0.35392D0, 0.32282D0, 0.29171D0, 0.26113D0, 0.23164D0, & 0.20355D0, 0.17701D0, 0.15231D0, 0.12990D0, 0.10928D0, & 0.09079D0, 0.07455D0, 0.06012D0, 0.03723D0, 0.02116D0, & 0.01072D0, 0.00459D0, 0.00031D0, 0.00000D0/ DATA (FMRS(1,1,I,25),I=1,49)/ & 0.02010D0, 0.02507D0, 0.03126D0, 0.03556D0, 0.03897D0, & 0.04183D0, 0.05216D0, 0.06515D0, 0.07433D0, 0.08171D0, & 0.08812D0, 0.11191D0, 0.14397D0, 0.16790D0, 0.18786D0, & 0.20530D0, 0.23522D0, 0.27216D0, 0.32085D0, 0.35900D0, & 0.41434D0, 0.45001D0, 0.47142D0, 0.48304D0, 0.48197D0, & 0.47120D0, 0.45346D0, 0.43043D0, 0.40367D0, 0.37460D0, & 0.34407D0, 0.31306D0, 0.28215D0, 0.25197D0, 0.22296D0, & 0.19546D0, 0.16953D0, 0.14549D0, 0.12381D0, 0.10387D0, & 0.08608D0, 0.07049D0, 0.05669D0, 0.03490D0, 0.01971D0, & 0.00991D0, 0.00421D0, 0.00028D0, 0.00000D0/ DATA (FMRS(1,1,I,26),I=1,49)/ & 0.02032D0, 0.02536D0, 0.03164D0, 0.03600D0, 0.03946D0, & 0.04236D0, 0.05285D0, 0.06604D0, 0.07535D0, 0.08285D0, & 0.08936D0, 0.11352D0, 0.14603D0, 0.17026D0, 0.19043D0, & 0.20801D0, 0.23810D0, 0.27509D0, 0.32355D0, 0.36123D0, & 0.41527D0, 0.44945D0, 0.46936D0, 0.47919D0, 0.47657D0, & 0.46453D0, 0.44572D0, 0.42188D0, 0.39463D0, 0.36526D0, & 0.33462D0, 0.30373D0, 0.27307D0, 0.24328D0, 0.21472D0, & 0.18782D0, 0.16253D0, 0.13914D0, 0.11811D0, 0.09886D0, & 0.08171D0, 0.06673D0, 0.05353D0, 0.03277D0, 0.01840D0, & 0.00919D0, 0.00387D0, 0.00025D0, 0.00000D0/ DATA (FMRS(1,1,I,27),I=1,49)/ & 0.02054D0, 0.02564D0, 0.03200D0, 0.03642D0, 0.03992D0, & 0.04287D0, 0.05350D0, 0.06688D0, 0.07633D0, 0.08394D0, & 0.09053D0, 0.11504D0, 0.14798D0, 0.17249D0, 0.19284D0, & 0.21055D0, 0.24079D0, 0.27781D0, 0.32602D0, 0.36325D0, & 0.41604D0, 0.44883D0, 0.46732D0, 0.47551D0, 0.47145D0, & 0.45823D0, 0.43846D0, 0.41392D0, 0.38625D0, 0.35664D0, & 0.32595D0, 0.29518D0, 0.26477D0, 0.23536D0, 0.20725D0, & 0.18088D0, 0.15618D0, 0.13340D0, 0.11297D0, 0.09435D0, & 0.07779D0, 0.06337D0, 0.05071D0, 0.03088D0, 0.01724D0, & 0.00855D0, 0.00357D0, 0.00023D0, 0.00000D0/ DATA (FMRS(1,1,I,28),I=1,49)/ & 0.02074D0, 0.02591D0, 0.03234D0, 0.03682D0, 0.04037D0, & 0.04335D0, 0.05412D0, 0.06768D0, 0.07725D0, 0.08496D0, & 0.09165D0, 0.11648D0, 0.14982D0, 0.17457D0, 0.19509D0, & 0.21292D0, 0.24327D0, 0.28031D0, 0.32827D0, 0.36504D0, & 0.41665D0, 0.44811D0, 0.46527D0, 0.47196D0, 0.46656D0, & 0.45228D0, 0.43165D0, 0.40650D0, 0.37846D0, 0.34867D0, & 0.31800D0, 0.28733D0, 0.25718D0, 0.22812D0, 0.20048D0, & 0.17458D0, 0.15043D0, 0.12823D0, 0.10834D0, 0.09029D0, & 0.07427D0, 0.06037D0, 0.04820D0, 0.02920D0, 0.01621D0, & 0.00800D0, 0.00332D0, 0.00021D0, 0.00000D0/ DATA (FMRS(1,1,I,29),I=1,49)/ & 0.02094D0, 0.02617D0, 0.03269D0, 0.03722D0, 0.04081D0, & 0.04383D0, 0.05475D0, 0.06848D0, 0.07818D0, 0.08599D0, & 0.09277D0, 0.11792D0, 0.15165D0, 0.17664D0, 0.19733D0, & 0.21527D0, 0.24574D0, 0.28277D0, 0.33045D0, 0.36674D0, & 0.41715D0, 0.44728D0, 0.46313D0, 0.46834D0, 0.46164D0, & 0.44631D0, 0.42488D0, 0.39917D0, 0.37077D0, 0.34082D0, & 0.31017D0, 0.27964D0, 0.24978D0, 0.22107D0, 0.19390D0, & 0.16849D0, 0.14488D0, 0.12325D0, 0.10390D0, 0.08640D0, & 0.07092D0, 0.05751D0, 0.04581D0, 0.02761D0, 0.01524D0, & 0.00748D0, 0.00308D0, 0.00019D0, 0.00000D0/ DATA (FMRS(1,1,I,30),I=1,49)/ & 0.02115D0, 0.02644D0, 0.03303D0, 0.03762D0, 0.04125D0, & 0.04431D0, 0.05536D0, 0.06927D0, 0.07910D0, 0.08701D0, & 0.09387D0, 0.11934D0, 0.15345D0, 0.17867D0, 0.19951D0, & 0.21755D0, 0.24811D0, 0.28512D0, 0.33251D0, 0.36831D0, & 0.41752D0, 0.44634D0, 0.46092D0, 0.46470D0, 0.45678D0, & 0.44042D0, 0.41827D0, 0.39206D0, 0.36329D0, 0.33323D0, & 0.30260D0, 0.27226D0, 0.24270D0, 0.21435D0, 0.18761D0, & 0.16271D0, 0.13963D0, 0.11853D0, 0.09974D0, 0.08276D0, & 0.06777D0, 0.05484D0, 0.04358D0, 0.02615D0, 0.01436D0, & 0.00700D0, 0.00286D0, 0.00017D0, 0.00000D0/ DATA (FMRS(1,1,I,31),I=1,49)/ & 0.02134D0, 0.02669D0, 0.03336D0, 0.03800D0, 0.04168D0, & 0.04477D0, 0.05595D0, 0.07003D0, 0.07997D0, 0.08798D0, & 0.09492D0, 0.12069D0, 0.15515D0, 0.18059D0, 0.20157D0, & 0.21970D0, 0.25034D0, 0.28732D0, 0.33440D0, 0.36974D0, & 0.41780D0, 0.44538D0, 0.45878D0, 0.46121D0, 0.45216D0, & 0.43488D0, 0.41206D0, 0.38539D0, 0.35634D0, 0.32619D0, & 0.29560D0, 0.26544D0, 0.23618D0, 0.20818D0, 0.18185D0, & 0.15743D0, 0.13483D0, 0.11423D0, 0.09594D0, 0.07945D0, & 0.06492D0, 0.05243D0, 0.04157D0, 0.02483D0, 0.01357D0, & 0.00658D0, 0.00267D0, 0.00016D0, 0.00000D0/ DATA (FMRS(1,1,I,32),I=1,49)/ & 0.02153D0, 0.02693D0, 0.03367D0, 0.03836D0, 0.04208D0, & 0.04521D0, 0.05651D0, 0.07075D0, 0.08080D0, 0.08890D0, & 0.09592D0, 0.12197D0, 0.15676D0, 0.18239D0, 0.20349D0, & 0.22170D0, 0.25240D0, 0.28933D0, 0.33609D0, 0.37098D0, & 0.41793D0, 0.44434D0, 0.45663D0, 0.45780D0, 0.44772D0, & 0.42965D0, 0.40618D0, 0.37910D0, 0.34986D0, 0.31963D0, & 0.28912D0, 0.25913D0, 0.23015D0, 0.20249D0, 0.17658D0, & 0.15257D0, 0.13044D0, 0.11030D0, 0.09247D0, 0.07643D0, & 0.06234D0, 0.05026D0, 0.03976D0, 0.02365D0, 0.01287D0, & 0.00620D0, 0.00250D0, 0.00014D0, 0.00000D0/ DATA (FMRS(1,1,I,33),I=1,49)/ & 0.02171D0, 0.02717D0, 0.03398D0, 0.03872D0, 0.04248D0, & 0.04565D0, 0.05708D0, 0.07147D0, 0.08164D0, 0.08983D0, & 0.09693D0, 0.12326D0, 0.15838D0, 0.18421D0, 0.20543D0, & 0.22371D0, 0.25448D0, 0.29136D0, 0.33779D0, 0.37222D0, & 0.41806D0, 0.44331D0, 0.45449D0, 0.45441D0, 0.44330D0, & 0.42446D0, 0.40038D0, 0.37291D0, 0.34349D0, 0.31319D0, & 0.28277D0, 0.25295D0, 0.22427D0, 0.19695D0, 0.17145D0, & 0.14785D0, 0.12618D0, 0.10650D0, 0.08912D0, 0.07353D0, & 0.05986D0, 0.04817D0, 0.03803D0, 0.02252D0, 0.01220D0, & 0.00585D0, 0.00235D0, 0.00013D0, 0.00000D0/ DATA (FMRS(1,1,I,34),I=1,49)/ & 0.02190D0, 0.02741D0, 0.03429D0, 0.03909D0, 0.04289D0, & 0.04609D0, 0.05764D0, 0.07219D0, 0.08247D0, 0.09075D0, & 0.09793D0, 0.12453D0, 0.15996D0, 0.18597D0, 0.20731D0, & 0.22565D0, 0.25646D0, 0.29325D0, 0.33935D0, 0.37330D0, & 0.41800D0, 0.44209D0, 0.45219D0, 0.45092D0, 0.43883D0, & 0.41923D0, 0.39461D0, 0.36679D0, 0.33718D0, 0.30687D0, & 0.27654D0, 0.24693D0, 0.21853D0, 0.19159D0, 0.16650D0, & 0.14332D0, 0.12207D0, 0.10288D0, 0.08593D0, 0.07076D0, & 0.05749D0, 0.04618D0, 0.03639D0, 0.02146D0, 0.01157D0, & 0.00552D0, 0.00220D0, 0.00012D0, 0.00000D0/ DATA (FMRS(1,1,I,35),I=1,49)/ & 0.02208D0, 0.02764D0, 0.03459D0, 0.03943D0, 0.04327D0, & 0.04650D0, 0.05818D0, 0.07288D0, 0.08327D0, 0.09162D0, & 0.09888D0, 0.12574D0, 0.16147D0, 0.18765D0, 0.20909D0, & 0.22750D0, 0.25834D0, 0.29505D0, 0.34083D0, 0.37432D0, & 0.41794D0, 0.44094D0, 0.45002D0, 0.44763D0, 0.43463D0, & 0.41432D0, 0.38921D0, 0.36108D0, 0.33130D0, 0.30099D0, & 0.27077D0, 0.24136D0, 0.21322D0, 0.18665D0, 0.16193D0, & 0.13915D0, 0.11830D0, 0.09955D0, 0.08301D0, 0.06823D0, & 0.05533D0, 0.04437D0, 0.03490D0, 0.02050D0, 0.01100D0, & 0.00523D0, 0.00207D0, 0.00011D0, 0.00000D0/ DATA (FMRS(1,1,I,36),I=1,49)/ & 0.02225D0, 0.02787D0, 0.03488D0, 0.03977D0, 0.04364D0, & 0.04690D0, 0.05869D0, 0.07354D0, 0.08402D0, 0.09246D0, & 0.09978D0, 0.12689D0, 0.16290D0, 0.18924D0, 0.21077D0, & 0.22923D0, 0.26010D0, 0.29672D0, 0.34217D0, 0.37521D0, & 0.41781D0, 0.43978D0, 0.44789D0, 0.44447D0, 0.43062D0, & 0.40968D0, 0.38412D0, 0.35571D0, 0.32579D0, 0.29550D0, & 0.26538D0, 0.23618D0, 0.20831D0, 0.18206D0, 0.15771D0, & 0.13531D0, 0.11485D0, 0.09649D0, 0.08034D0, 0.06592D0, & 0.05337D0, 0.04272D0, 0.03354D0, 0.01963D0, 0.01049D0, & 0.00496D0, 0.00196D0, 0.00011D0, 0.00000D0/ DATA (FMRS(1,1,I,37),I=1,49)/ & 0.02242D0, 0.02809D0, 0.03517D0, 0.04010D0, 0.04401D0, & 0.04731D0, 0.05921D0, 0.07420D0, 0.08479D0, 0.09331D0, & 0.10070D0, 0.12805D0, 0.16433D0, 0.19082D0, 0.21245D0, & 0.23095D0, 0.26184D0, 0.29836D0, 0.34345D0, 0.37604D0, & 0.41760D0, 0.43853D0, 0.44568D0, 0.44123D0, 0.42654D0, & 0.40499D0, 0.37899D0, 0.35034D0, 0.32029D0, 0.29001D0, & 0.26003D0, 0.23104D0, 0.20345D0, 0.17752D0, 0.15354D0, & 0.13153D0, 0.11147D0, 0.09348D0, 0.07771D0, 0.06366D0, & 0.05147D0, 0.04112D0, 0.03222D0, 0.01879D0, 0.01000D0, & 0.00471D0, 0.00185D0, 0.00010D0, 0.00000D0/ DATA (FMRS(1,1,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,2,I, 1),I=1,49)/ & 0.00513D0, 0.00648D0, 0.00818D0, 0.00938D0, 0.01034D0, & 0.01116D0, 0.01418D0, 0.01818D0, 0.02118D0, 0.02372D0, & 0.02613D0, 0.03576D0, 0.05040D0, 0.06228D0, 0.07266D0, & 0.08202D0, 0.09864D0, 0.12002D0, 0.14955D0, 0.17387D0, & 0.21184D0, 0.23954D0, 0.25956D0, 0.27606D0, 0.28502D0, & 0.28790D0, 0.28586D0, 0.27985D0, 0.27060D0, 0.25918D0, & 0.24535D0, 0.23028D0, 0.21416D0, 0.19735D0, 0.18044D0, & 0.16347D0, 0.14671D0, 0.13049D0, 0.11512D0, 0.10018D0, & 0.08630D0, 0.07360D0, 0.06172D0, 0.04171D0, 0.02610D0, & 0.01478D0, 0.00721D0, 0.00074D0, 0.00000D0/ DATA (FMRS(1,2,I, 2),I=1,49)/ & 0.00518D0, 0.00654D0, 0.00828D0, 0.00950D0, 0.01049D0, & 0.01133D0, 0.01443D0, 0.01854D0, 0.02162D0, 0.02423D0, & 0.02670D0, 0.03657D0, 0.05155D0, 0.06366D0, 0.07421D0, & 0.08371D0, 0.10052D0, 0.12206D0, 0.15163D0, 0.17583D0, & 0.21329D0, 0.24028D0, 0.25950D0, 0.27498D0, 0.28295D0, & 0.28491D0, 0.28206D0, 0.27535D0, 0.26555D0, 0.25365D0, & 0.23952D0, 0.22423D0, 0.20802D0, 0.19123D0, 0.17441D0, & 0.15763D0, 0.14114D0, 0.12520D0, 0.11019D0, 0.09565D0, & 0.08218D0, 0.06990D0, 0.05847D0, 0.03927D0, 0.02442D0, & 0.01373D0, 0.00665D0, 0.00066D0, 0.00000D0/ DATA (FMRS(1,2,I, 3),I=1,49)/ & 0.00524D0, 0.00664D0, 0.00843D0, 0.00970D0, 0.01072D0, & 0.01159D0, 0.01481D0, 0.01908D0, 0.02229D0, 0.02501D0, & 0.02757D0, 0.03781D0, 0.05328D0, 0.06572D0, 0.07653D0, & 0.08622D0, 0.10330D0, 0.12505D0, 0.15465D0, 0.17864D0, & 0.21528D0, 0.24119D0, 0.25922D0, 0.27320D0, 0.27971D0, & 0.28035D0, 0.27635D0, 0.26864D0, 0.25807D0, 0.24551D0, & 0.23101D0, 0.21544D0, 0.19911D0, 0.18240D0, 0.16578D0, & 0.14929D0, 0.13320D0, 0.11772D0, 0.10322D0, 0.08926D0, & 0.07639D0, 0.06473D0, 0.05394D0, 0.03591D0, 0.02212D0, & 0.01231D0, 0.00589D0, 0.00057D0, 0.00000D0/ DATA (FMRS(1,2,I, 4),I=1,49)/ & 0.00529D0, 0.00672D0, 0.00855D0, 0.00985D0, 0.01090D0, & 0.01179D0, 0.01510D0, 0.01949D0, 0.02279D0, 0.02558D0, & 0.02822D0, 0.03873D0, 0.05456D0, 0.06724D0, 0.07823D0, & 0.08806D0, 0.10532D0, 0.12720D0, 0.15680D0, 0.18061D0, & 0.21663D0, 0.24172D0, 0.25888D0, 0.27177D0, 0.27723D0, & 0.27696D0, 0.27213D0, 0.26373D0, 0.25262D0, 0.23966D0, & 0.22489D0, 0.20919D0, 0.19281D0, 0.17616D0, 0.15968D0, & 0.14345D0, 0.12763D0, 0.11250D0, 0.09838D0, 0.08485D0, & 0.07242D0, 0.06118D0, 0.05083D0, 0.03363D0, 0.02058D0, & 0.01136D0, 0.00539D0, 0.00050D0, 0.00000D0/ DATA (FMRS(1,2,I, 5),I=1,49)/ & 0.00534D0, 0.00680D0, 0.00868D0, 0.01001D0, 0.01108D0, & 0.01200D0, 0.01540D0, 0.01993D0, 0.02332D0, 0.02620D0, & 0.02891D0, 0.03971D0, 0.05590D0, 0.06884D0, 0.08000D0, & 0.08997D0, 0.10741D0, 0.12941D0, 0.15897D0, 0.18257D0, & 0.21790D0, 0.24212D0, 0.25836D0, 0.27010D0, 0.27446D0, & 0.27326D0, 0.26762D0, 0.25853D0, 0.24692D0, 0.23356D0, & 0.21851D0, 0.20270D0, 0.18633D0, 0.16975D0, 0.15345D0, & 0.13751D0, 0.12199D0, 0.10721D0, 0.09351D0, 0.08043D0, & 0.06843D0, 0.05765D0, 0.04775D0, 0.03138D0, 0.01907D0, & 0.01045D0, 0.00491D0, 0.00045D0, 0.00000D0/ DATA (FMRS(1,2,I, 6),I=1,49)/ & 0.00539D0, 0.00688D0, 0.00879D0, 0.01015D0, 0.01125D0, & 0.01219D0, 0.01567D0, 0.02031D0, 0.02379D0, 0.02674D0, & 0.02951D0, 0.04056D0, 0.05708D0, 0.07022D0, 0.08154D0, & 0.09162D0, 0.10921D0, 0.13130D0, 0.16082D0, 0.18422D0, & 0.21894D0, 0.24239D0, 0.25783D0, 0.26859D0, 0.27204D0, & 0.27005D0, 0.26373D0, 0.25409D0, 0.24206D0, 0.22838D0, & 0.21313D0, 0.19724D0, 0.18088D0, 0.16440D0, 0.14826D0, & 0.13257D0, 0.11731D0, 0.10284D0, 0.08950D0, 0.07679D0, & 0.06517D0, 0.05477D0, 0.04524D0, 0.02956D0, 0.01786D0, & 0.00972D0, 0.00453D0, 0.00040D0, 0.00000D0/ DATA (FMRS(1,2,I, 7),I=1,49)/ & 0.00544D0, 0.00695D0, 0.00890D0, 0.01029D0, 0.01141D0, & 0.01237D0, 0.01593D0, 0.02068D0, 0.02425D0, 0.02727D0, & 0.03010D0, 0.04138D0, 0.05820D0, 0.07155D0, 0.08301D0, & 0.09319D0, 0.11091D0, 0.13308D0, 0.16253D0, 0.18572D0, & 0.21983D0, 0.24255D0, 0.25721D0, 0.26706D0, 0.26966D0, & 0.26692D0, 0.25996D0, 0.24983D0, 0.23740D0, 0.22344D0, & 0.20806D0, 0.19209D0, 0.17575D0, 0.15940D0, 0.14342D0, & 0.12794D0, 0.11298D0, 0.09881D0, 0.08579D0, 0.07344D0, & 0.06219D0, 0.05213D0, 0.04295D0, 0.02791D0, 0.01677D0, & 0.00906D0, 0.00419D0, 0.00037D0, 0.00000D0/ DATA (FMRS(1,2,I, 8),I=1,49)/ & 0.00549D0, 0.00703D0, 0.00902D0, 0.01044D0, 0.01159D0, & 0.01257D0, 0.01622D0, 0.02109D0, 0.02474D0, 0.02783D0, & 0.03073D0, 0.04227D0, 0.05940D0, 0.07296D0, 0.08456D0, & 0.09485D0, 0.11270D0, 0.13493D0, 0.16429D0, 0.18726D0, & 0.22070D0, 0.24263D0, 0.25647D0, 0.26535D0, 0.26707D0, & 0.26357D0, 0.25596D0, 0.24532D0, 0.23250D0, 0.21829D0, & 0.20276D0, 0.18675D0, 0.17045D0, 0.15424D0, 0.13845D0, & 0.12321D0, 0.10855D0, 0.09470D0, 0.08203D0, 0.07005D0, & 0.05917D0, 0.04947D0, 0.04065D0, 0.02627D0, 0.01569D0, & 0.00842D0, 0.00386D0, 0.00033D0, 0.00000D0/ DATA (FMRS(1,2,I, 9),I=1,49)/ & 0.00553D0, 0.00711D0, 0.00913D0, 0.01057D0, 0.01174D0, & 0.01274D0, 0.01647D0, 0.02144D0, 0.02517D0, 0.02833D0, & 0.03129D0, 0.04304D0, 0.06045D0, 0.07418D0, 0.08591D0, & 0.09629D0, 0.11425D0, 0.13653D0, 0.16579D0, 0.18855D0, & 0.22139D0, 0.24264D0, 0.25577D0, 0.26380D0, 0.26479D0, & 0.26063D0, 0.25250D0, 0.24142D0, 0.22830D0, 0.21390D0, & 0.19824D0, 0.18222D0, 0.16597D0, 0.14988D0, 0.13426D0, & 0.11924D0, 0.10484D0, 0.09128D0, 0.07889D0, 0.06724D0, & 0.05666D0, 0.04727D0, 0.03875D0, 0.02492D0, 0.01480D0, & 0.00790D0, 0.00360D0, 0.00030D0, 0.00000D0/ DATA (FMRS(1,2,I,10),I=1,49)/ & 0.00558D0, 0.00718D0, 0.00923D0, 0.01071D0, 0.01190D0, & 0.01291D0, 0.01671D0, 0.02178D0, 0.02559D0, 0.02881D0, & 0.03183D0, 0.04379D0, 0.06146D0, 0.07536D0, 0.08720D0, & 0.09766D0, 0.11571D0, 0.13802D0, 0.16719D0, 0.18973D0, & 0.22198D0, 0.24256D0, 0.25502D0, 0.26225D0, 0.26252D0, & 0.25776D0, 0.24914D0, 0.23766D0, 0.22428D0, 0.20968D0, & 0.19393D0, 0.17791D0, 0.16173D0, 0.14575D0, 0.13032D0, & 0.11552D0, 0.10136D0, 0.08807D0, 0.07596D0, 0.06462D0, & 0.05433D0, 0.04524D0, 0.03701D0, 0.02369D0, 0.01400D0, & 0.00743D0, 0.00336D0, 0.00028D0, 0.00000D0/ DATA (FMRS(1,2,I,11),I=1,49)/ & 0.00562D0, 0.00723D0, 0.00932D0, 0.01081D0, 0.01202D0, & 0.01305D0, 0.01691D0, 0.02206D0, 0.02593D0, 0.02920D0, & 0.03226D0, 0.04438D0, 0.06226D0, 0.07629D0, 0.08822D0, & 0.09874D0, 0.11687D0, 0.13920D0, 0.16827D0, 0.19064D0, & 0.22242D0, 0.24246D0, 0.25439D0, 0.26100D0, 0.26071D0, & 0.25548D0, 0.24648D0, 0.23472D0, 0.22112D0, 0.20638D0, & 0.19059D0, 0.17454D0, 0.15845D0, 0.14257D0, 0.12728D0, & 0.11265D0, 0.09869D0, 0.08561D0, 0.07373D0, 0.06261D0, & 0.05256D0, 0.04369D0, 0.03568D0, 0.02275D0, 0.01339D0, & 0.00707D0, 0.00318D0, 0.00026D0, 0.00000D0/ DATA (FMRS(1,2,I,12),I=1,49)/ & 0.00570D0, 0.00736D0, 0.00950D0, 0.01104D0, 0.01228D0, & 0.01335D0, 0.01733D0, 0.02266D0, 0.02665D0, 0.03003D0, & 0.03319D0, 0.04566D0, 0.06397D0, 0.07827D0, 0.09038D0, & 0.10102D0, 0.11928D0, 0.14164D0, 0.17050D0, 0.19247D0, & 0.22321D0, 0.24211D0, 0.25293D0, 0.25822D0, 0.25677D0, & 0.25059D0, 0.24082D0, 0.22847D0, 0.21448D0, 0.19945D0, & 0.18361D0, 0.16759D0, 0.15163D0, 0.13598D0, 0.12100D0, & 0.10676D0, 0.09321D0, 0.08058D0, 0.06917D0, 0.05856D0, & 0.04898D0, 0.04057D0, 0.03301D0, 0.02089D0, 0.01219D0, & 0.00638D0, 0.00284D0, 0.00022D0, 0.00000D0/ DATA (FMRS(1,2,I,13),I=1,49)/ & 0.00578D0, 0.00747D0, 0.00966D0, 0.01124D0, 0.01252D0, & 0.01361D0, 0.01770D0, 0.02318D0, 0.02729D0, 0.03076D0, & 0.03400D0, 0.04677D0, 0.06545D0, 0.07997D0, 0.09223D0, & 0.10297D0, 0.12133D0, 0.14370D0, 0.17234D0, 0.19395D0, & 0.22379D0, 0.24170D0, 0.25156D0, 0.25575D0, 0.25334D0, & 0.24638D0, 0.23598D0, 0.22317D0, 0.20887D0, 0.19364D0, & 0.17776D0, 0.16180D0, 0.14597D0, 0.13054D0, 0.11583D0, & 0.10193D0, 0.08873D0, 0.07648D0, 0.06548D0, 0.05529D0, & 0.04609D0, 0.03806D0, 0.03088D0, 0.01941D0, 0.01124D0, & 0.00583D0, 0.00257D0, 0.00020D0, 0.00000D0/ DATA (FMRS(1,2,I,14),I=1,49)/ & 0.00586D0, 0.00760D0, 0.00985D0, 0.01147D0, 0.01278D0, & 0.01391D0, 0.01812D0, 0.02377D0, 0.02801D0, 0.03158D0, & 0.03491D0, 0.04802D0, 0.06710D0, 0.08186D0, 0.09428D0, & 0.10512D0, 0.12358D0, 0.14593D0, 0.17430D0, 0.19551D0, & 0.22431D0, 0.24113D0, 0.24990D0, 0.25292D0, 0.24948D0, & 0.24168D0, 0.23063D0, 0.21737D0, 0.20273D0, 0.18735D0, & 0.17142D0, 0.15550D0, 0.13986D0, 0.12470D0, 0.11033D0, & 0.09680D0, 0.08400D0, 0.07217D0, 0.06162D0, 0.05183D0, & 0.04308D0, 0.03546D0, 0.02866D0, 0.01788D0, 0.01027D0, & 0.00528D0, 0.00231D0, 0.00017D0, 0.00000D0/ DATA (FMRS(1,2,I,15),I=1,49)/ & 0.00596D0, 0.00773D0, 0.01005D0, 0.01171D0, 0.01307D0, & 0.01423D0, 0.01857D0, 0.02439D0, 0.02876D0, 0.03244D0, & 0.03586D0, 0.04932D0, 0.06880D0, 0.08380D0, 0.09637D0, & 0.10730D0, 0.12584D0, 0.14815D0, 0.17622D0, 0.19694D0, & 0.22466D0, 0.24034D0, 0.24804D0, 0.24983D0, 0.24536D0, & 0.23677D0, 0.22506D0, 0.21136D0, 0.19645D0, 0.18096D0, & 0.16500D0, 0.14922D0, 0.13378D0, 0.11890D0, 0.10488D0, & 0.09171D0, 0.07933D0, 0.06793D0, 0.05781D0, 0.04848D0, & 0.04016D0, 0.03293D0, 0.02652D0, 0.01642D0, 0.00936D0, & 0.00477D0, 0.00206D0, 0.00015D0, 0.00000D0/ DATA (FMRS(1,2,I,16),I=1,49)/ & 0.00604D0, 0.00786D0, 0.01023D0, 0.01194D0, 0.01333D0, & 0.01452D0, 0.01898D0, 0.02497D0, 0.02945D0, 0.03323D0, & 0.03674D0, 0.05050D0, 0.07034D0, 0.08554D0, 0.09824D0, & 0.10925D0, 0.12785D0, 0.15009D0, 0.17786D0, 0.19815D0, & 0.22486D0, 0.23952D0, 0.24625D0, 0.24698D0, 0.24163D0, & 0.23233D0, 0.22009D0, 0.20603D0, 0.19091D0, 0.17529D0, & 0.15938D0, 0.14374D0, 0.12849D0, 0.11388D0, 0.10016D0, & 0.08733D0, 0.07533D0, 0.06433D0, 0.05458D0, 0.04564D0, & 0.03769D0, 0.03082D0, 0.02473D0, 0.01521D0, 0.00860D0, & 0.00435D0, 0.00186D0, 0.00013D0, 0.00000D0/ DATA (FMRS(1,2,I,17),I=1,49)/ & 0.00614D0, 0.00799D0, 0.01042D0, 0.01217D0, 0.01359D0, & 0.01482D0, 0.01940D0, 0.02555D0, 0.03016D0, 0.03404D0, & 0.03763D0, 0.05170D0, 0.07188D0, 0.08729D0, 0.10010D0, & 0.11119D0, 0.12983D0, 0.15200D0, 0.17943D0, 0.19928D0, & 0.22497D0, 0.23860D0, 0.24438D0, 0.24406D0, 0.23786D0, & 0.22788D0, 0.21517D0, 0.20077D0, 0.18546D0, 0.16976D0, & 0.15392D0, 0.13841D0, 0.12338D0, 0.10905D0, 0.09563D0, & 0.08314D0, 0.07152D0, 0.06090D0, 0.05152D0, 0.04295D0, & 0.03537D0, 0.02883D0, 0.02306D0, 0.01409D0, 0.00791D0, & 0.00396D0, 0.00168D0, 0.00011D0, 0.00000D0/ DATA (FMRS(1,2,I,18),I=1,49)/ & 0.00621D0, 0.00810D0, 0.01058D0, 0.01236D0, 0.01382D0, & 0.01507D0, 0.01975D0, 0.02604D0, 0.03075D0, 0.03471D0, & 0.03837D0, 0.05269D0, 0.07316D0, 0.08872D0, 0.10163D0, & 0.11277D0, 0.13143D0, 0.15352D0, 0.18066D0, 0.20012D0, & 0.22496D0, 0.23774D0, 0.24276D0, 0.24159D0, 0.23471D0, & 0.22421D0, 0.21113D0, 0.19645D0, 0.18102D0, 0.16532D0, & 0.14952D0, 0.13412D0, 0.11930D0, 0.10519D0, 0.09201D0, & 0.07983D0, 0.06850D0, 0.05818D0, 0.04914D0, 0.04085D0, & 0.03356D0, 0.02728D0, 0.02176D0, 0.01322D0, 0.00738D0, & 0.00367D0, 0.00154D0, 0.00010D0, 0.00000D0/ DATA (FMRS(1,2,I,19),I=1,49)/ & 0.00631D0, 0.00824D0, 0.01077D0, 0.01261D0, 0.01410D0, & 0.01538D0, 0.02018D0, 0.02663D0, 0.03146D0, 0.03553D0, & 0.03927D0, 0.05390D0, 0.07469D0, 0.09044D0, 0.10345D0, & 0.11464D0, 0.13332D0, 0.15529D0, 0.18206D0, 0.20106D0, & 0.22486D0, 0.23661D0, 0.24071D0, 0.23855D0, 0.23089D0, & 0.21978D0, 0.20626D0, 0.19133D0, 0.17575D0, 0.16006D0, & 0.14433D0, 0.12911D0, 0.11452D0, 0.10069D0, 0.08783D0, & 0.07600D0, 0.06503D0, 0.05507D0, 0.04638D0, 0.03845D0, & 0.03149D0, 0.02552D0, 0.02030D0, 0.01225D0, 0.00679D0, & 0.00335D0, 0.00139D0, 0.00009D0, 0.00000D0/ DATA (FMRS(1,2,I,20),I=1,49)/ & 0.00640D0, 0.00837D0, 0.01095D0, 0.01282D0, 0.01434D0, & 0.01565D0, 0.02057D0, 0.02717D0, 0.03210D0, 0.03625D0, & 0.04007D0, 0.05496D0, 0.07605D0, 0.09195D0, 0.10504D0, & 0.11628D0, 0.13496D0, 0.15682D0, 0.18325D0, 0.20182D0, & 0.22471D0, 0.23557D0, 0.23887D0, 0.23587D0, 0.22753D0, & 0.21592D0, 0.20204D0, 0.18691D0, 0.17123D0, 0.15556D0, & 0.13990D0, 0.12485D0, 0.11047D0, 0.09690D0, 0.08432D0, & 0.07279D0, 0.06213D0, 0.05248D0, 0.04407D0, 0.03646D0, & 0.02978D0, 0.02408D0, 0.01910D0, 0.01145D0, 0.00631D0, & 0.00309D0, 0.00127D0, 0.00008D0, 0.00000D0/ DATA (FMRS(1,2,I,21),I=1,49)/ & 0.00648D0, 0.00848D0, 0.01111D0, 0.01302D0, 0.01457D0, & 0.01591D0, 0.02092D0, 0.02766D0, 0.03269D0, 0.03692D0, & 0.04081D0, 0.05593D0, 0.07728D0, 0.09331D0, 0.10647D0, & 0.11774D0, 0.13641D0, 0.15816D0, 0.18425D0, 0.20243D0, & 0.22446D0, 0.23452D0, 0.23710D0, 0.23336D0, 0.22443D0, & 0.21239D0, 0.19820D0, 0.18290D0, 0.16716D0, 0.15148D0, & 0.13595D0, 0.12104D0, 0.10685D0, 0.09353D0, 0.08121D0, & 0.06995D0, 0.05958D0, 0.05021D0, 0.04207D0, 0.03472D0, & 0.02829D0, 0.02282D0, 0.01806D0, 0.01077D0, 0.00590D0, & 0.00287D0, 0.00118D0, 0.00007D0, 0.00000D0/ DATA (FMRS(1,2,I,22),I=1,49)/ & 0.00659D0, 0.00863D0, 0.01133D0, 0.01328D0, 0.01487D0, & 0.01624D0, 0.02138D0, 0.02828D0, 0.03345D0, 0.03777D0, & 0.04174D0, 0.05717D0, 0.07882D0, 0.09501D0, 0.10826D0, & 0.11956D0, 0.13822D0, 0.15980D0, 0.18547D0, 0.20313D0, & 0.22408D0, 0.23313D0, 0.23482D0, 0.23017D0, 0.22053D0, & 0.20797D0, 0.19344D0, 0.17794D0, 0.16215D0, 0.14650D0, & 0.13110D0, 0.11639D0, 0.10245D0, 0.08944D0, 0.07745D0, & 0.06653D0, 0.05651D0, 0.04748D0, 0.03968D0, 0.03265D0, & 0.02652D0, 0.02133D0, 0.01682D0, 0.00997D0, 0.00542D0, & 0.00262D0, 0.00106D0, 0.00006D0, 0.00000D0/ DATA (FMRS(1,2,I,23),I=1,49)/ & 0.00669D0, 0.00878D0, 0.01153D0, 0.01352D0, 0.01515D0, & 0.01655D0, 0.02181D0, 0.02888D0, 0.03416D0, 0.03858D0, & 0.04263D0, 0.05833D0, 0.08027D0, 0.09661D0, 0.10992D0, & 0.12125D0, 0.13987D0, 0.16129D0, 0.18654D0, 0.20370D0, & 0.22365D0, 0.23178D0, 0.23266D0, 0.22717D0, 0.21689D0, & 0.20387D0, 0.18906D0, 0.17340D0, 0.15758D0, 0.14198D0, & 0.12670D0, 0.11220D0, 0.09851D0, 0.08577D0, 0.07408D0, & 0.06350D0, 0.05377D0, 0.04507D0, 0.03757D0, 0.03084D0, & 0.02497D0, 0.02003D0, 0.01574D0, 0.00927D0, 0.00500D0, & 0.00240D0, 0.00096D0, 0.00006D0, 0.00000D0/ DATA (FMRS(1,2,I,24),I=1,49)/ & 0.00679D0, 0.00892D0, 0.01172D0, 0.01376D0, 0.01542D0, & 0.01685D0, 0.02222D0, 0.02944D0, 0.03483D0, 0.03934D0, & 0.04345D0, 0.05941D0, 0.08161D0, 0.09806D0, 0.11144D0, & 0.12278D0, 0.14136D0, 0.16260D0, 0.18745D0, 0.20414D0, & 0.22314D0, 0.23041D0, 0.23054D0, 0.22429D0, 0.21345D0, & 0.20006D0, 0.18498D0, 0.16918D0, 0.15336D0, 0.13783D0, & 0.12271D0, 0.10840D0, 0.09494D0, 0.08246D0, 0.07106D0, & 0.06075D0, 0.05132D0, 0.04292D0, 0.03570D0, 0.02922D0, & 0.02361D0, 0.01888D0, 0.01480D0, 0.00867D0, 0.00465D0, & 0.00221D0, 0.00088D0, 0.00005D0, 0.00000D0/ DATA (FMRS(1,2,I,25),I=1,49)/ & 0.00689D0, 0.00906D0, 0.01192D0, 0.01399D0, 0.01569D0, & 0.01715D0, 0.02264D0, 0.03000D0, 0.03550D0, 0.04009D0, & 0.04429D0, 0.06049D0, 0.08294D0, 0.09952D0, 0.11294D0, & 0.12429D0, 0.14282D0, 0.16389D0, 0.18832D0, 0.20454D0, & 0.22261D0, 0.22902D0, 0.22843D0, 0.22145D0, 0.21007D0, & 0.19632D0, 0.18101D0, 0.16509D0, 0.14928D0, 0.13382D0, & 0.11886D0, 0.10475D0, 0.09153D0, 0.07931D0, 0.06819D0, & 0.05815D0, 0.04900D0, 0.04089D0, 0.03393D0, 0.02770D0, & 0.02232D0, 0.01781D0, 0.01392D0, 0.00811D0, 0.00432D0, & 0.00204D0, 0.00081D0, 0.00004D0, 0.00000D0/ DATA (FMRS(1,2,I,26),I=1,49)/ & 0.00699D0, 0.00920D0, 0.01211D0, 0.01423D0, 0.01596D0, & 0.01744D0, 0.02304D0, 0.03056D0, 0.03616D0, 0.04084D0, & 0.04510D0, 0.06154D0, 0.08423D0, 0.10091D0, 0.11437D0, & 0.12573D0, 0.14419D0, 0.16508D0, 0.18909D0, 0.20485D0, & 0.22201D0, 0.22760D0, 0.22631D0, 0.21867D0, 0.20676D0, & 0.19266D0, 0.17717D0, 0.16120D0, 0.14536D0, 0.12999D0, & 0.11520D0, 0.10128D0, 0.08831D0, 0.07633D0, 0.06548D0, & 0.05572D0, 0.04685D0, 0.03900D0, 0.03228D0, 0.02629D0, & 0.02113D0, 0.01682D0, 0.01311D0, 0.00760D0, 0.00403D0, & 0.00189D0, 0.00074D0, 0.00004D0, 0.00000D0/ DATA (FMRS(1,2,I,27),I=1,49)/ & 0.00708D0, 0.00933D0, 0.01230D0, 0.01445D0, 0.01621D0, & 0.01773D0, 0.02343D0, 0.03108D0, 0.03678D0, 0.04155D0, & 0.04587D0, 0.06253D0, 0.08544D0, 0.10221D0, 0.11571D0, & 0.12707D0, 0.14546D0, 0.16617D0, 0.18977D0, 0.20509D0, & 0.22139D0, 0.22623D0, 0.22430D0, 0.21604D0, 0.20367D0, & 0.18926D0, 0.17361D0, 0.15759D0, 0.14176D0, 0.12648D0, & 0.11185D0, 0.09812D0, 0.08537D0, 0.07364D0, 0.06303D0, & 0.05352D0, 0.04490D0, 0.03729D0, 0.03081D0, 0.02503D0, & 0.02007D0, 0.01594D0, 0.01240D0, 0.00714D0, 0.00376D0, & 0.00176D0, 0.00068D0, 0.00004D0, 0.00000D0/ DATA (FMRS(1,2,I,28),I=1,49)/ & 0.00718D0, 0.00946D0, 0.01247D0, 0.01467D0, 0.01646D0, & 0.01800D0, 0.02380D0, 0.03158D0, 0.03738D0, 0.04221D0, & 0.04660D0, 0.06346D0, 0.08657D0, 0.10342D0, 0.11695D0, & 0.12830D0, 0.14663D0, 0.16715D0, 0.19037D0, 0.20527D0, & 0.22075D0, 0.22489D0, 0.22237D0, 0.21353D0, 0.20079D0, & 0.18610D0, 0.17031D0, 0.15425D0, 0.13844D0, 0.12326D0, & 0.10877D0, 0.09523D0, 0.08268D0, 0.07119D0, 0.06080D0, & 0.05153D0, 0.04314D0, 0.03575D0, 0.02948D0, 0.02390D0, & 0.01913D0, 0.01516D0, 0.01177D0, 0.00675D0, 0.00353D0, & 0.00164D0, 0.00063D0, 0.00003D0, 0.00000D0/ DATA (FMRS(1,2,I,29),I=1,49)/ & 0.00727D0, 0.00959D0, 0.01265D0, 0.01488D0, 0.01670D0, & 0.01827D0, 0.02417D0, 0.03208D0, 0.03797D0, 0.04288D0, & 0.04733D0, 0.06440D0, 0.08769D0, 0.10463D0, 0.11818D0, & 0.12952D0, 0.14777D0, 0.16810D0, 0.19092D0, 0.20540D0, & 0.22008D0, 0.22352D0, 0.22043D0, 0.21103D0, 0.19791D0, & 0.18297D0, 0.16705D0, 0.15095D0, 0.13519D0, 0.12011D0, & 0.10577D0, 0.09241D0, 0.08008D0, 0.06881D0, 0.05866D0, & 0.04961D0, 0.04145D0, 0.03427D0, 0.02822D0, 0.02282D0, & 0.01822D0, 0.01441D0, 0.01116D0, 0.00637D0, 0.00332D0, & 0.00153D0, 0.00059D0, 0.00003D0, 0.00000D0/ DATA (FMRS(1,2,I,30),I=1,49)/ & 0.00737D0, 0.00972D0, 0.01283D0, 0.01510D0, 0.01695D0, & 0.01854D0, 0.02454D0, 0.03258D0, 0.03856D0, 0.04354D0, & 0.04805D0, 0.06532D0, 0.08879D0, 0.10580D0, 0.11936D0, & 0.13069D0, 0.14886D0, 0.16900D0, 0.19141D0, 0.20548D0, & 0.21937D0, 0.22213D0, 0.21850D0, 0.20855D0, 0.19507D0, & 0.17994D0, 0.16388D0, 0.14775D0, 0.13208D0, 0.11709D0, & 0.10291D0, 0.08973D0, 0.07760D0, 0.06655D0, 0.05664D0, & 0.04779D0, 0.03985D0, 0.03289D0, 0.02702D0, 0.02182D0, & 0.01738D0, 0.01372D0, 0.01060D0, 0.00602D0, 0.00312D0, & 0.00143D0, 0.00055D0, 0.00003D0, 0.00000D0/ DATA (FMRS(1,2,I,31),I=1,49)/ & 0.00746D0, 0.00985D0, 0.01300D0, 0.01530D0, 0.01718D0, & 0.01880D0, 0.02489D0, 0.03306D0, 0.03912D0, 0.04417D0, & 0.04873D0, 0.06619D0, 0.08983D0, 0.10690D0, 0.12048D0, & 0.13179D0, 0.14987D0, 0.16982D0, 0.19186D0, 0.20553D0, & 0.21868D0, 0.22081D0, 0.21666D0, 0.20623D0, 0.19242D0, & 0.17710D0, 0.16093D0, 0.14478D0, 0.12919D0, 0.11430D0, & 0.10026D0, 0.08726D0, 0.07533D0, 0.06447D0, 0.05479D0, & 0.04614D0, 0.03840D0, 0.03163D0, 0.02594D0, 0.02091D0, & 0.01662D0, 0.01309D0, 0.01009D0, 0.00571D0, 0.00295D0, & 0.00134D0, 0.00051D0, 0.00003D0, 0.00000D0/ DATA (FMRS(1,2,I,32),I=1,49)/ & 0.00755D0, 0.00997D0, 0.01317D0, 0.01550D0, 0.01741D0, & 0.01905D0, 0.02522D0, 0.03351D0, 0.03966D0, 0.04477D0, & 0.04938D0, 0.06700D0, 0.09079D0, 0.10792D0, 0.12151D0, & 0.13280D0, 0.15080D0, 0.17056D0, 0.19223D0, 0.20552D0, & 0.21797D0, 0.21951D0, 0.21489D0, 0.20403D0, 0.18991D0, & 0.17441D0, 0.15817D0, 0.14202D0, 0.12646D0, 0.11170D0, & 0.09780D0, 0.08498D0, 0.07322D0, 0.06257D0, 0.05306D0, & 0.04463D0, 0.03708D0, 0.03049D0, 0.02496D0, 0.02008D0, & 0.01594D0, 0.01252D0, 0.00963D0, 0.00542D0, 0.00279D0, & 0.00126D0, 0.00048D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,33),I=1,49)/ & 0.00764D0, 0.01009D0, 0.01333D0, 0.01570D0, 0.01763D0, & 0.01930D0, 0.02556D0, 0.03396D0, 0.04019D0, 0.04537D0, & 0.05004D0, 0.06783D0, 0.09177D0, 0.10895D0, 0.12254D0, & 0.13381D0, 0.15173D0, 0.17130D0, 0.19261D0, 0.20552D0, & 0.21726D0, 0.21822D0, 0.21313D0, 0.20185D0, 0.18743D0, & 0.17175D0, 0.15545D0, 0.13931D0, 0.12379D0, 0.10917D0, & 0.09540D0, 0.08276D0, 0.07118D0, 0.06072D0, 0.05139D0, & 0.04317D0, 0.03581D0, 0.02938D0, 0.02402D0, 0.01929D0, & 0.01528D0, 0.01198D0, 0.00920D0, 0.00516D0, 0.00264D0, & 0.00119D0, 0.00045D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,34),I=1,49)/ & 0.00773D0, 0.01021D0, 0.01350D0, 0.01590D0, 0.01786D0, & 0.01955D0, 0.02590D0, 0.03441D0, 0.04072D0, 0.04597D0, & 0.05068D0, 0.06863D0, 0.09272D0, 0.10994D0, 0.12353D0, & 0.13477D0, 0.15260D0, 0.17197D0, 0.19290D0, 0.20543D0, & 0.21649D0, 0.21688D0, 0.21134D0, 0.19965D0, 0.18497D0, & 0.16913D0, 0.15278D0, 0.13665D0, 0.12121D0, 0.10669D0, & 0.09308D0, 0.08060D0, 0.06921D0, 0.05894D0, 0.04980D0, & 0.04176D0, 0.03458D0, 0.02833D0, 0.02311D0, 0.01853D0, & 0.01465D0, 0.01147D0, 0.00879D0, 0.00491D0, 0.00250D0, & 0.00112D0, 0.00042D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,35),I=1,49)/ & 0.00781D0, 0.01033D0, 0.01366D0, 0.01609D0, 0.01808D0, & 0.01979D0, 0.02622D0, 0.03484D0, 0.04123D0, 0.04653D0, & 0.05129D0, 0.06941D0, 0.09362D0, 0.11088D0, 0.12448D0, & 0.13569D0, 0.15342D0, 0.17260D0, 0.19318D0, 0.20535D0, & 0.21576D0, 0.21562D0, 0.20966D0, 0.19759D0, 0.18266D0, & 0.16668D0, 0.15028D0, 0.13418D0, 0.11882D0, 0.10439D0, & 0.09094D0, 0.07861D0, 0.06739D0, 0.05729D0, 0.04834D0, & 0.04048D0, 0.03346D0, 0.02736D0, 0.02228D0, 0.01784D0, & 0.01408D0, 0.01100D0, 0.00842D0, 0.00468D0, 0.00237D0, & 0.00106D0, 0.00039D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,36),I=1,49)/ & 0.00790D0, 0.01044D0, 0.01382D0, 0.01628D0, 0.01829D0, & 0.02002D0, 0.02653D0, 0.03525D0, 0.04172D0, 0.04707D0, & 0.05188D0, 0.07013D0, 0.09447D0, 0.11177D0, 0.12535D0, & 0.13654D0, 0.15418D0, 0.17318D0, 0.19341D0, 0.20524D0, & 0.21505D0, 0.21440D0, 0.20805D0, 0.19563D0, 0.18048D0, & 0.16438D0, 0.14795D0, 0.13186D0, 0.11657D0, 0.10226D0, & 0.08894D0, 0.07676D0, 0.06571D0, 0.05578D0, 0.04700D0, & 0.03929D0, 0.03242D0, 0.02648D0, 0.02153D0, 0.01720D0, & 0.01356D0, 0.01058D0, 0.00808D0, 0.00448D0, 0.00226D0, & 0.00101D0, 0.00037D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,37),I=1,49)/ & 0.00798D0, 0.01056D0, 0.01397D0, 0.01646D0, 0.01850D0, & 0.02025D0, 0.02684D0, 0.03567D0, 0.04221D0, 0.04762D0, & 0.05247D0, 0.07087D0, 0.09532D0, 0.11265D0, 0.12622D0, & 0.13738D0, 0.15492D0, 0.17373D0, 0.19361D0, 0.20510D0, & 0.21429D0, 0.21315D0, 0.20641D0, 0.19365D0, 0.17829D0, & 0.16207D0, 0.14561D0, 0.12954D0, 0.11434D0, 0.10013D0, & 0.08696D0, 0.07493D0, 0.06406D0, 0.05429D0, 0.04567D0, & 0.03812D0, 0.03141D0, 0.02561D0, 0.02079D0, 0.01659D0, & 0.01305D0, 0.01017D0, 0.00775D0, 0.00428D0, 0.00215D0, & 0.00095D0, 0.00035D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,2,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I, 1),I=1,49)/ & 3.68244D0, 3.61785D0, 3.55346D0, 3.51555D0, 3.48837D0, & 3.46702D0, 3.39811D0, 3.32177D0, 3.27072D0, 3.23000D0, & 3.19378D0, 3.05765D0, 2.86346D0, 2.71339D0, 2.58651D0, & 2.47572D0, 2.28777D0, 2.06245D0, 1.78178D0, 1.57726D0, & 1.30519D0, 1.14076D0, 1.03654D0, 0.95264D0, 0.89447D0, & 0.84663D0, 0.80090D0, 0.75325D0, 0.70217D0, 0.64784D0, & 0.59048D0, 0.53173D0, 0.47263D0, 0.41459D0, 0.35887D0, & 0.30634D0, 0.25757D0, 0.21335D0, 0.17415D0, 0.13936D0, & 0.10957D0, 0.08459D0, 0.06372D0, 0.03369D0, 0.01574D0, & 0.00625D0, 0.00195D0, 0.00005D0, 0.00000D0/ DATA (FMRS(1,3,I, 2),I=1,49)/ & 6.24307D0, 5.86376D0, 5.50631D0, 5.30646D0, 5.16844D0, & 5.06337D0, 4.74657D0, 4.44005D0, 4.26242D0, 4.13555D0, & 4.03502D0, 3.71094D0, 3.34882D0, 3.11051D0, 2.92600D0, & 2.77355D0, 2.52821D0, 2.24967D0, 1.91859D0, 1.68481D0, & 1.37946D0, 1.19535D0, 1.07673D0, 0.97819D0, 0.90750D0, & 0.84881D0, 0.79381D0, 0.73852D0, 0.68149D0, 0.62276D0, & 0.56254D0, 0.50226D0, 0.44285D0, 0.38548D0, 0.33123D0, & 0.28073D0, 0.23437D0, 0.19279D0, 0.15633D0, 0.12427D0, & 0.09707D0, 0.07445D0, 0.05572D0, 0.02906D0, 0.01339D0, & 0.00524D0, 0.00161D0, 0.00004D0, 0.00000D0/ DATA (FMRS(1,3,I, 3),I=1,49)/ & 11.05139D0, 9.94786D0, 8.95244D0, 8.41536D0, 8.05287D0, & 7.78166D0, 6.98996D0, 6.26416D0, 5.86369D0, 5.58758D0, & 5.37431D0, 4.72923D0, 4.08790D0, 3.70661D0, 3.43015D0, & 3.21204D0, 2.87740D0, 2.51734D0, 2.11023D0, 1.83283D0, & 1.47833D0, 1.26530D0, 1.12571D0, 1.00618D0, 0.91793D0, & 0.84442D0, 0.77712D0, 0.71204D0, 0.64770D0, 0.58389D0, & 0.52071D0, 0.45928D0, 0.40030D0, 0.34459D0, 0.29298D0, & 0.24576D0, 0.20309D0, 0.16540D0, 0.13284D0, 0.10462D0, & 0.08093D0, 0.06152D0, 0.04560D0, 0.02333D0, 0.01054D0, & 0.00404D0, 0.00122D0, 0.00003D0, 0.00000D0/ DATA (FMRS(1,3,I, 4),I=1,49)/ & 15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0, & 10.03696D0, 8.81034D0, 7.71341D0, 7.12073D0, 6.71781D0, & 6.40918D0, 5.49848D0, 4.63276D0, 4.13943D0, 3.79203D0, & 3.52386D0, 3.12196D0, 2.70149D0, 2.23890D0, 1.93011D0, & 1.54059D0, 1.30714D0, 1.15286D0, 1.01886D0, 0.91881D0, & 0.83562D0, 0.76055D0, 0.68952D0, 0.62095D0, 0.55452D0, & 0.49011D0, 0.42861D0, 0.37052D0, 0.31647D0, 0.26702D0, & 0.22241D0, 0.18246D0, 0.14751D0, 0.11769D0, 0.09209D0, & 0.07074D0, 0.05343D0, 0.03933D0, 0.01985D0, 0.00885D0, & 0.00335D0, 0.00100D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,3,I, 5),I=1,49)/ & 20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0, & 12.58273D0, 10.83264D0, 9.29877D0, 8.48369D0, 7.93560D0, & 7.51848D0, 6.31010D0, 5.19808D0, 4.58383D0, 4.16067D0, & 3.83948D0, 3.36690D0, 2.88348D0, 2.36367D0, 2.02276D0, & 1.59751D0, 1.34336D0, 1.17440D0, 1.02619D0, 0.91484D0, & 0.82260D0, 0.74049D0, 0.66431D0, 0.59227D0, 0.52387D0, & 0.45886D0, 0.39784D0, 0.34106D0, 0.28898D0, 0.24193D0, & 0.20003D0, 0.16291D0, 0.13075D0, 0.10361D0, 0.08049D0, & 0.06141D0, 0.04606D0, 0.03367D0, 0.01676D0, 0.00737D0, & 0.00275D0, 0.00081D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,3,I, 6),I=1,49)/ & 25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0, & 15.07400D0, 12.78092D0, 10.80231D0, 9.76436D0, 9.07223D0, & 8.54820D0, 7.05063D0, 5.70461D0, 4.97765D0, 4.48471D0, & 4.11512D0, 3.57867D0, 3.03899D0, 2.46867D0, 2.09967D0, & 1.64344D0, 1.37152D0, 1.19009D0, 1.03003D0, 0.90944D0, & 0.81000D0, 0.72245D0, 0.64242D0, 0.56795D0, 0.49835D0, & 0.43318D0, 0.37285D0, 0.31739D0, 0.26712D0, 0.22217D0, & 0.18254D0, 0.14775D0, 0.11786D0, 0.09285D0, 0.07171D0, & 0.05439D0, 0.04056D0, 0.02948D0, 0.01450D0, 0.00631D0, & 0.00232D0, 0.00067D0, 0.00002D0, 0.00000D0/ DATA (FMRS(1,3,I, 7),I=1,49)/ & 31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0, & 17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0, & 9.54456D0, 7.75761D0, 6.18119D0, 5.34474D0, 4.78459D0, & 4.36861D0, 3.77149D0, 3.17878D0, 2.56125D0, 2.16614D0, & 1.68135D0, 1.39321D0, 1.20050D0, 1.02990D0, 0.90129D0, & 0.79577D0, 0.70378D0, 0.62075D0, 0.54457D0, 0.47435D0, & 0.40939D0, 0.34999D0, 0.29601D0, 0.24758D0, 0.20467D0, & 0.16718D0, 0.13453D0, 0.10670D0, 0.08361D0, 0.06425D0, & 0.04845D0, 0.03594D0, 0.02598D0, 0.01264D0, 0.00544D0, & 0.00198D0, 0.00057D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I, 8),I=1,49)/ & 38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0, & 20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0, & 10.64140D0, 8.52490D0, 6.69053D0, 5.73328D0, 5.09966D0, & 4.63338D0, 3.97084D0, 3.32155D0, 2.65414D0, 2.23167D0, & 1.71719D0, 1.41235D0, 1.20819D0, 1.02708D0, 0.89064D0, & 0.77934D0, 0.68328D0, 0.59764D0, 0.52014D0, 0.44964D0, & 0.38523D0, 0.32704D0, 0.27476D0, 0.22832D0, 0.18758D0, & 0.15228D0, 0.12182D0, 0.09604D0, 0.07484D0, 0.05719D0, & 0.04288D0, 0.03164D0, 0.02275D0, 0.01095D0, 0.00466D0, & 0.00168D0, 0.00048D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I, 9),I=1,49)/ & 44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0, & 23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0, & 11.62724D0, 9.20581D0, 7.13631D0, 6.07035D0, 5.37118D0, & 4.86033D0, 4.14011D0, 3.44140D0, 2.73081D0, 2.28485D0, & 1.74506D0, 1.42613D0, 1.21246D0, 1.02274D0, 0.88003D0, & 0.76424D0, 0.66513D0, 0.57765D0, 0.49935D0, 0.42889D0, & 0.36519D0, 0.30820D0, 0.25746D0, 0.21275D0, 0.17388D0, & 0.14043D0, 0.11178D0, 0.08767D0, 0.06799D0, 0.05171D0, & 0.03859D0, 0.02834D0, 0.02028D0, 0.00968D0, 0.00408D0, & 0.00146D0, 0.00041D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I,10),I=1,49)/ & 51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0, & 25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0, & 12.58248D0, 9.85775D0, 7.55746D0, 6.38605D0, 5.62372D0, & 5.07013D0, 4.29501D0, 3.54959D0, 2.79853D0, 2.33075D0, & 1.76763D0, 1.43584D0, 1.21358D0, 1.01625D0, 0.86814D0, & 0.74860D0, 0.64707D0, 0.55827D0, 0.47958D0, 0.40941D0, & 0.34660D0, 0.29089D0, 0.24172D0, 0.19871D0, 0.16160D0, & 0.12988D0, 0.10289D0, 0.08032D0, 0.06202D0, 0.04695D0, & 0.03489D0, 0.02551D0, 0.01818D0, 0.00860D0, 0.00360D0, & 0.00128D0, 0.00036D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I,11),I=1,49)/ & 57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0, & 28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0, & 13.35786D0, 10.38182D0, 7.89242D0, 6.63544D0, 5.82215D0, & 5.23423D0, 4.41529D0, 3.63279D0, 2.84983D0, 2.36499D0, & 1.78374D0, 1.44206D0, 1.21326D0, 1.01023D0, 0.85815D0, & 0.73593D0, 0.63273D0, 0.54312D0, 0.46430D0, 0.39449D0, & 0.33248D0, 0.27783D0, 0.22993D0, 0.18826D0, 0.15250D0, & 0.12212D0, 0.09637D0, 0.07495D0, 0.05770D0, 0.04352D0, & 0.03223D0, 0.02349D0, 0.01668D0, 0.00784D0, 0.00326D0, & 0.00115D0, 0.00032D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I,12),I=1,49)/ & 70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0, & 33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0, & 15.01807D0, 11.48651D0, 8.58576D0, 7.14521D0, 6.22372D0, & 5.56345D0, 4.65284D0, 3.79371D0, 2.94559D0, 2.42633D0, & 1.80899D0, 1.44797D0, 1.20662D0, 0.99291D0, 0.83369D0, & 0.70687D0, 0.60112D0, 0.51056D0, 0.43209D0, 0.36357D0, & 0.30359D0, 0.25146D0, 0.20630D0, 0.16753D0, 0.13462D0, & 0.10696D0, 0.08376D0, 0.06466D0, 0.04944D0, 0.03702D0, & 0.02722D0, 0.01971D0, 0.01390D0, 0.00645D0, 0.00265D0, & 0.00093D0, 0.00026D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I,13),I=1,49)/ & 83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0, & 37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0, & 16.46149D0, 12.42825D0, 9.16326D0, 7.56303D0, 6.54853D0, & 5.82663D0, 4.83880D0, 3.91602D0, 3.01472D0, 2.46779D0, & 1.82202D0, 1.44614D0, 1.19543D0, 0.97402D0, 0.80992D0, & 0.68027D0, 0.57325D0, 0.48262D0, 0.40504D0, 0.33808D0, & 0.28014D0, 0.23033D0, 0.18761D0, 0.15130D0, 0.12077D0, & 0.09534D0, 0.07419D0, 0.05692D0, 0.04326D0, 0.03220D0, & 0.02354D0, 0.01696D0, 0.01189D0, 0.00546D0, 0.00222D0, & 0.00077D0, 0.00021D0, 0.00001D0, 0.00000D0/ DATA (FMRS(1,3,I,14),I=1,49)/ & 99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0, & 43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0, & 18.06292D0, 13.45200D0, 9.77556D0, 7.99825D0, 6.88178D0, & 6.09288D0, 5.02224D0, 4.03207D0, 3.07569D0, 2.50055D0, & 1.82658D0, 1.43637D0, 1.17694D0, 0.94870D0, 0.78062D0, & 0.64903D0, 0.54156D0, 0.45166D0, 0.37564D0, 0.31084D0, & 0.25547D0, 0.20834D0, 0.16843D0, 0.13481D0, 0.10686D0, & 0.08378D0, 0.06476D0, 0.04934D0, 0.03727D0, 0.02756D0, & 0.02003D0, 0.01435D0, 0.01000D0, 0.00454D0, 0.00183D0, & 0.00063D0, 0.00017D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,15),I=1,49)/ & 117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0, & 49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0, & 19.72087D0, 14.49332D0, 10.38573D0, 8.42544D0, 7.20484D0, & 6.34818D0, 5.19436D0, 4.13748D0, 3.12707D0, 2.52493D0, & 1.82437D0, 1.42118D0, 1.15415D0, 0.92032D0, 0.74934D0, & 0.61673D0, 0.50955D0, 0.42103D0, 0.34703D0, 0.28471D0, & 0.23205D0, 0.18777D0, 0.15064D0, 0.11967D0, 0.09419D0, & 0.07336D0, 0.05631D0, 0.04263D0, 0.03201D0, 0.02354D0, & 0.01700D0, 0.01211D0, 0.00839D0, 0.00377D0, 0.00151D0, & 0.00052D0, 0.00014D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,16),I=1,49)/ & 134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0, & 54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0, & 21.23395D0, 15.42784D0, 10.92244D0, 8.79593D0, 7.48170D0, & 6.56462D0, 5.33723D0, 4.22208D0, 3.16533D0, 2.54035D0, & 1.81781D0, 1.40424D0, 1.13142D0, 0.89365D0, 0.72095D0, & 0.58811D0, 0.48181D0, 0.39483D0, 0.32289D0, 0.26295D0, & 0.21278D0, 0.17100D0, 0.13629D0, 0.10758D0, 0.08415D0, & 0.06517D0, 0.04972D0, 0.03744D0, 0.02797D0, 0.02046D0, & 0.01470D0, 0.01042D0, 0.00719D0, 0.00321D0, 0.00127D0, & 0.00043D0, 0.00012D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,17),I=1,49)/ & 154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0, & 60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0, & 22.77463D0, 16.36506D0, 11.45095D0, 9.15610D0, 7.74790D0, & 6.77064D0, 5.47057D0, 4.29852D0, 3.19720D0, 2.55058D0, & 1.80771D0, 1.38488D0, 1.10716D0, 0.86634D0, 0.69264D0, & 0.56014D0, 0.45511D0, 0.36997D0, 0.30026D0, 0.24276D0, & 0.19507D0, 0.15573D0, 0.12333D0, 0.09676D0, 0.07524D0, & 0.05794D0, 0.04395D0, 0.03292D0, 0.02447D0, 0.01781D0, & 0.01274D0, 0.00899D0, 0.00618D0, 0.00274D0, 0.00108D0, & 0.00037D0, 0.00010D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,18),I=1,49)/ & 171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0, & 65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0, & 24.04215D0, 17.12464D0, 11.87120D0, 9.43856D0, 7.95410D0, & 6.92832D0, 5.57016D0, 4.35322D0, 3.21721D0, 2.55406D0, & 1.79608D0, 1.36671D0, 1.08575D0, 0.84319D0, 0.66925D0, & 0.53749D0, 0.43376D0, 0.35041D0, 0.28267D0, 0.22722D0, & 0.18154D0, 0.14418D0, 0.11359D0, 0.08871D0, 0.06865D0, & 0.05262D0, 0.03976D0, 0.02965D0, 0.02195D0, 0.01592D0, & 0.01135D0, 0.00798D0, 0.00547D0, 0.00241D0, 0.00095D0, & 0.00032D0, 0.00009D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,19),I=1,49)/ & 193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0, & 72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0, & 25.56394D0, 18.02311D0, 12.35926D0, 9.76179D0, 8.18702D0, & 7.10431D0, 5.67841D0, 4.40968D0, 3.23437D0, 2.55292D0, & 1.77867D0, 1.34261D0, 1.05865D0, 0.81484D0, 0.64125D0, & 0.51082D0, 0.40904D0, 0.32798D0, 0.26269D0, 0.20975D0, & 0.16651D0, 0.13145D0, 0.10293D0, 0.07994D0, 0.06153D0, & 0.04691D0, 0.03527D0, 0.02618D0, 0.01929D0, 0.01394D0, & 0.00989D0, 0.00693D0, 0.00473D0, 0.00207D0, 0.00081D0, & 0.00027D0, 0.00007D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,20),I=1,49)/ & 214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0, & 77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0, & 26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0, 8.38419D0, & 7.25181D0, 5.76723D0, 4.45410D0, 3.24560D0, 2.54901D0, & 1.76164D0, 1.32048D0, 1.03446D0, 0.79010D0, 0.61721D0, & 0.48824D0, 0.38835D0, 0.30938D0, 0.24629D0, 0.19551D0, & 0.15438D0, 0.12122D0, 0.09444D0, 0.07299D0, 0.05594D0, & 0.04245D0, 0.03178D0, 0.02349D0, 0.01725D0, 0.01242D0, & 0.00879D0, 0.00614D0, 0.00418D0, 0.00182D0, 0.00071D0, & 0.00024D0, 0.00007D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,21),I=1,49)/ & 234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0, & 83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0, & 28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0, 8.54710D0, & 7.37140D0, 5.83642D0, 4.48556D0, 3.24949D0, 2.54059D0, & 1.74309D0, 1.29840D0, 1.01128D0, 0.76711D0, 0.59538D0, & 0.46805D0, 0.37012D0, 0.29319D0, 0.23219D0, 0.18337D0, & 0.14410D0, 0.11261D0, 0.08738D0, 0.06725D0, 0.05133D0, & 0.03881D0, 0.02895D0, 0.02133D0, 0.01562D0, 0.01121D0, & 0.00791D0, 0.00551D0, 0.00374D0, 0.00162D0, 0.00063D0, & 0.00021D0, 0.00006D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,22),I=1,49)/ & 261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0, & 90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0, & 29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0, 8.74295D0, & 7.51340D0, 5.91633D0, 4.51953D0, 3.25037D0, 2.52703D0, & 1.71812D0, 1.26985D0, 0.98192D0, 0.73853D0, 0.56860D0, & 0.44359D0, 0.34825D0, 0.27396D0, 0.21556D0, 0.16918D0, & 0.13216D0, 0.10269D0, 0.07927D0, 0.06069D0, 0.04611D0, & 0.03471D0, 0.02577D0, 0.01891D0, 0.01380D0, 0.00987D0, & 0.00694D0, 0.00482D0, 0.00326D0, 0.00141D0, 0.00055D0, & 0.00018D0, 0.00005D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,23),I=1,49)/ & 289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0, & 97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0, & 31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0, 8.91469D0, & 7.63597D0, 5.98282D0, 4.54504D0, 3.24687D0, 2.51128D0, & 1.69316D0, 1.24243D0, 0.95435D0, 0.71223D0, 0.54431D0, & 0.42170D0, 0.32889D0, 0.25710D0, 0.20110D0, 0.15697D0, & 0.12195D0, 0.09429D0, 0.07242D0, 0.05518D0, 0.04175D0, & 0.03132D0, 0.02316D0, 0.01693D0, 0.01232D0, 0.00878D0, & 0.00615D0, 0.00426D0, 0.00288D0, 0.00124D0, 0.00048D0, & 0.00016D0, 0.00004D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,24),I=1,49)/ & 315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0, & 103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0, & 32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0, 9.05547D0, & 7.73389D0, 6.03187D0, 4.55934D0, 3.23736D0, 2.49207D0, & 1.66734D0, 1.21544D0, 0.92800D0, 0.68769D0, 0.52210D0, & 0.40197D0, 0.31164D0, 0.24228D0, 0.18850D0, 0.14640D0, & 0.11322D0, 0.08715D0, 0.06666D0, 0.05059D0, 0.03813D0, & 0.02850D0, 0.02101D0, 0.01531D0, 0.01111D0, 0.00790D0, & 0.00552D0, 0.00382D0, 0.00258D0, 0.00111D0, 0.00043D0, & 0.00014D0, 0.00004D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,25),I=1,49)/ & 342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0, & 110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0, & 33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0, 9.19035D0, & 7.82660D0, 6.07682D0, 4.57070D0, 3.22605D0, 2.47181D0, & 1.64130D0, 1.18872D0, 0.90224D0, 0.66398D0, 0.50084D0, & 0.38326D0, 0.29541D0, 0.22842D0, 0.17680D0, 0.13666D0, & 0.10521D0, 0.08063D0, 0.06143D0, 0.04643D0, 0.03487D0, & 0.02598D0, 0.01909D0, 0.01388D0, 0.01004D0, 0.00712D0, & 0.00496D0, 0.00343D0, 0.00231D0, 0.00099D0, 0.00038D0, & 0.00013D0, 0.00004D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,26),I=1,49)/ & 370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0, & 116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0, & 34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0, 9.30664D0, & 7.90402D0, 6.11093D0, 4.57472D0, 3.21035D0, 2.44880D0, & 1.61427D0, 1.16192D0, 0.87693D0, 0.64114D0, 0.48063D0, & 0.36570D0, 0.28035D0, 0.21566D0, 0.16615D0, 0.12784D0, & 0.09801D0, 0.07482D0, 0.05679D0, 0.04277D0, 0.03202D0, & 0.02378D0, 0.01743D0, 0.01263D0, 0.00912D0, 0.00645D0, & 0.00449D0, 0.00310D0, 0.00208D0, 0.00089D0, 0.00034D0, & 0.00012D0, 0.00003D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,27),I=1,49)/ & 398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0, & 123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0, & 36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0, 9.40909D0, & 7.97073D0, 6.13825D0, 4.57511D0, 3.19349D0, 2.42581D0, & 1.58834D0, 1.13668D0, 0.85340D0, 0.62017D0, 0.46227D0, & 0.34987D0, 0.26689D0, 0.20435D0, 0.15674D0, 0.12011D0, & 0.09172D0, 0.06977D0, 0.05278D0, 0.03962D0, 0.02958D0, & 0.02190D0, 0.01601D0, 0.01157D0, 0.00834D0, 0.00589D0, & 0.00409D0, 0.00282D0, 0.00189D0, 0.00081D0, 0.00031D0, & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,28),I=1,49)/ & 425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0, & 129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0, & 37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0, 9.49577D0, & 8.02523D0, 6.15776D0, 4.57120D0, 3.17506D0, 2.40249D0, & 1.56325D0, 1.11278D0, 0.83141D0, 0.60084D0, 0.44554D0, & 0.33559D0, 0.25483D0, 0.19432D0, 0.14844D0, 0.11333D0, & 0.08624D0, 0.06537D0, 0.04932D0, 0.03692D0, 0.02748D0, & 0.02030D0, 0.01481D0, 0.01068D0, 0.00768D0, 0.00541D0, & 0.00376D0, 0.00258D0, 0.00173D0, 0.00074D0, 0.00028D0, & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,29),I=1,49)/ & 452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0, & 135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0, & 38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0, 9.57579D0, & 8.07414D0, 6.17308D0, 4.56436D0, 3.15482D0, 2.37807D0, & 1.53780D0, 1.08891D0, 0.80971D0, 0.58195D0, 0.42935D0, & 0.32187D0, 0.24333D0, 0.18479D0, 0.14060D0, 0.10697D0, & 0.08112D0, 0.06130D0, 0.04611D0, 0.03442D0, 0.02556D0, & 0.01884D0, 0.01371D0, 0.00987D0, 0.00709D0, 0.00499D0, & 0.00346D0, 0.00237D0, 0.00159D0, 0.00068D0, 0.00026D0, & 0.00009D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,30),I=1,49)/ & 481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0, & 141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0, & 39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0, 9.64523D0, & 8.11468D0, 6.18265D0, 4.55389D0, 3.13269D0, 2.35270D0, & 1.51231D0, 1.06542D0, 0.78862D0, 0.56381D0, 0.41396D0, & 0.30893D0, 0.23257D0, 0.17592D0, 0.13335D0, 0.10111D0, & 0.07645D0, 0.05760D0, 0.04319D0, 0.03217D0, 0.02383D0, & 0.01753D0, 0.01273D0, 0.00915D0, 0.00656D0, 0.00461D0, & 0.00319D0, 0.00219D0, 0.00146D0, 0.00062D0, 0.00024D0, & 0.00008D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,31),I=1,49)/ & 508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0, & 146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0, & 40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0, 9.70659D0, & 8.14933D0, 6.18899D0, 4.54214D0, 3.11075D0, 2.32815D0, & 1.48813D0, 1.04340D0, 0.76902D0, 0.54710D0, 0.39988D0, & 0.29718D0, 0.22284D0, 0.16794D0, 0.12688D0, 0.09590D0, & 0.07230D0, 0.05433D0, 0.04063D0, 0.03020D0, 0.02232D0, & 0.01639D0, 0.01188D0, 0.00852D0, 0.00610D0, 0.00428D0, & 0.00296D0, 0.00203D0, 0.00136D0, 0.00057D0, 0.00022D0, & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,32),I=1,49)/ & 535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0, & 152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0, & 40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0, 9.75539D0, & 8.17448D0, 6.18955D0, 4.52735D0, 3.08788D0, 2.30359D0, & 1.46475D0, 1.02248D0, 0.75063D0, 0.53161D0, 0.38695D0, & 0.28648D0, 0.21405D0, 0.16077D0, 0.12112D0, 0.09128D0, & 0.06863D0, 0.05145D0, 0.03839D0, 0.02847D0, 0.02101D0, & 0.01540D0, 0.01114D0, 0.00798D0, 0.00571D0, 0.00400D0, & 0.00276D0, 0.00189D0, 0.00126D0, 0.00054D0, 0.00020D0, & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,33),I=1,49)/ & 563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0, & 158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0, & 41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0, 9.80451D0, & 8.19975D0, 6.19012D0, 4.51259D0, 3.06514D0, 2.27926D0, & 1.44171D0, 1.00196D0, 0.73265D0, 0.51654D0, 0.37443D0, & 0.27615D0, 0.20559D0, 0.15389D0, 0.11561D0, 0.08687D0, & 0.06514D0, 0.04872D0, 0.03627D0, 0.02685D0, 0.01977D0, & 0.01446D0, 0.01045D0, 0.00747D0, 0.00534D0, 0.00374D0, & 0.00258D0, 0.00176D0, 0.00118D0, 0.00050D0, 0.00019D0, & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,34),I=1,49)/ & 590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0, & 163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0, & 42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0, 9.84041D0, & 8.21457D0, 6.18338D0, 4.49312D0, 3.03982D0, 2.25340D0, & 1.41818D0, 0.98144D0, 0.71494D0, 0.50189D0, 0.36238D0, & 0.26631D0, 0.19763D0, 0.14748D0, 0.11046D0, 0.08279D0, & 0.06193D0, 0.04622D0, 0.03434D0, 0.02537D0, 0.01865D0, & 0.01362D0, 0.00983D0, 0.00702D0, 0.00501D0, 0.00351D0, & 0.00242D0, 0.00165D0, 0.00110D0, 0.00046D0, 0.00018D0, & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,35),I=1,49)/ & 617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0, & 168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0, & 43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0, 9.87443D0, & 8.22855D0, 6.17694D0, 4.47470D0, 3.01600D0, 2.22915D0, & 1.39622D0, 0.96237D0, 0.69854D0, 0.48839D0, 0.35132D0, & 0.25731D0, 0.19037D0, 0.14164D0, 0.10579D0, 0.07911D0, & 0.05904D0, 0.04396D0, 0.03261D0, 0.02405D0, 0.01765D0, & 0.01287D0, 0.00928D0, 0.00662D0, 0.00472D0, 0.00330D0, & 0.00227D0, 0.00155D0, 0.00103D0, 0.00044D0, 0.00017D0, & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,36),I=1,49)/ & 643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0, & 173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0, & 44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0, 9.90141D0, & 8.23759D0, 6.16791D0, 4.45540D0, 2.99242D0, 2.20560D0, & 1.37532D0, 0.94442D0, 0.68324D0, 0.47589D0, 0.34114D0, & 0.24908D0, 0.18375D0, 0.13636D0, 0.10159D0, 0.07580D0, & 0.05645D0, 0.04195D0, 0.03106D0, 0.02287D0, 0.01676D0, & 0.01221D0, 0.00879D0, 0.00626D0, 0.00446D0, 0.00311D0, & 0.00214D0, 0.00146D0, 0.00097D0, 0.00041D0, 0.00016D0, & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,37),I=1,49)/ & 670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0, & 178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0, & 44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0, 9.92310D0, & 8.24227D0, 6.15572D0, 4.43398D0, 2.96756D0, 2.18122D0, & 1.35409D0, 0.92638D0, 0.66799D0, 0.46354D0, 0.33115D0, & 0.24105D0, 0.17731D0, 0.13125D0, 0.09756D0, 0.07262D0, & 0.05397D0, 0.04005D0, 0.02960D0, 0.02176D0, 0.01592D0, & 0.01159D0, 0.00833D0, 0.00593D0, 0.00422D0, 0.00294D0, & 0.00202D0, 0.00138D0, 0.00092D0, 0.00039D0, 0.00015D0, & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,3,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 1),I=1,49)/ & 0.86800D0, 0.76598D0, 0.67520D0, 0.62675D0, 0.59428D0, & 0.57013D0, 0.50046D0, 0.43816D0, 0.40484D0, 0.38253D0, & 0.36613D0, 0.31874D0, 0.27654D0, 0.25397D0, 0.23882D0, & 0.22750D0, 0.21099D0, 0.19387D0, 0.17401D0, 0.15872D0, & 0.13363D0, 0.11222D0, 0.09356D0, 0.07392D0, 0.05824D0, & 0.04613D0, 0.03700D0, 0.03017D0, 0.02498D0, 0.02125D0, & 0.01786D0, 0.01513D0, 0.01268D0, 0.01040D0, 0.00852D0, & 0.00674D0, 0.00520D0, 0.00388D0, 0.00299D0, 0.00201D0, & 0.00134D0, 0.00094D0, 0.00051D0, 0.00021D0, 0.00007D0, & 0.00003D0, -0.00001D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 2),I=1,49)/ & 0.88205D0, 0.77983D0, 0.68869D0, 0.63997D0, 0.60729D0, & 0.58296D0, 0.51264D0, 0.44961D0, 0.41580D0, 0.39312D0, & 0.37640D0, 0.32792D0, 0.28442D0, 0.26097D0, 0.24515D0, & 0.23328D0, 0.21590D0, 0.19782D0, 0.17683D0, 0.16077D0, & 0.13467D0, 0.11273D0, 0.09381D0, 0.07406D0, 0.05839D0, & 0.04632D0, 0.03722D0, 0.03037D0, 0.02516D0, 0.02135D0, & 0.01792D0, 0.01513D0, 0.01262D0, 0.01032D0, 0.00842D0, & 0.00664D0, 0.00510D0, 0.00380D0, 0.00291D0, 0.00197D0, & 0.00130D0, 0.00091D0, 0.00051D0, 0.00020D0, 0.00007D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 3),I=1,49)/ & 0.91886D0, 0.81356D0, 0.71953D0, 0.66920D0, 0.63541D0, & 0.61023D0, 0.53738D0, 0.47189D0, 0.43666D0, 0.41295D0, & 0.39539D0, 0.34428D0, 0.29794D0, 0.27277D0, 0.25567D0, & 0.24279D0, 0.22388D0, 0.20416D0, 0.18131D0, 0.16398D0, & 0.13630D0, 0.11352D0, 0.09418D0, 0.07425D0, 0.05857D0, & 0.04653D0, 0.03744D0, 0.03056D0, 0.02532D0, 0.02139D0, & 0.01791D0, 0.01504D0, 0.01246D0, 0.01016D0, 0.00822D0, & 0.00648D0, 0.00493D0, 0.00368D0, 0.00278D0, 0.00188D0, & 0.00124D0, 0.00086D0, 0.00051D0, 0.00020D0, 0.00006D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 4),I=1,49)/ & 0.95997D0, 0.84981D0, 0.75147D0, 0.69884D0, 0.66351D0, & 0.63718D0, 0.56100D0, 0.49247D0, 0.45556D0, 0.43069D0, & 0.41221D0, 0.35830D0, 0.30918D0, 0.28239D0, 0.26415D0, & 0.25039D0, 0.23017D0, 0.20908D0, 0.18474D0, 0.16642D0, & 0.13752D0, 0.11409D0, 0.09444D0, 0.07437D0, 0.05864D0, & 0.04662D0, 0.03752D0, 0.03063D0, 0.02535D0, 0.02135D0, & 0.01783D0, 0.01492D0, 0.01232D0, 0.01000D0, 0.00803D0, & 0.00631D0, 0.00479D0, 0.00358D0, 0.00268D0, 0.00180D0, & 0.00120D0, 0.00084D0, 0.00049D0, 0.00020D0, 0.00006D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 5),I=1,49)/ & 1.02269D0, 0.90363D0, 0.79759D0, 0.74093D0, 0.70294D0, & 0.67465D0, 0.59289D0, 0.51944D0, 0.47990D0, 0.45324D0, & 0.43337D0, 0.37541D0, 0.32249D0, 0.29359D0, 0.27391D0, & 0.25907D0, 0.23726D0, 0.21456D0, 0.18851D0, 0.16906D0, & 0.13883D0, 0.11469D0, 0.09468D0, 0.07442D0, 0.05863D0, & 0.04662D0, 0.03753D0, 0.03061D0, 0.02531D0, 0.02124D0, & 0.01767D0, 0.01472D0, 0.01211D0, 0.00977D0, 0.00782D0, & 0.00614D0, 0.00464D0, 0.00341D0, 0.00257D0, 0.00173D0, & 0.00113D0, 0.00080D0, 0.00046D0, 0.00018D0, 0.00005D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 6),I=1,49)/ & 1.08763D0, 0.95875D0, 0.84428D0, 0.78326D0, 0.74239D0, & 0.71199D0, 0.62427D0, 0.54563D0, 0.50333D0, 0.47482D0, & 0.45353D0, 0.39146D0, 0.33478D0, 0.30385D0, 0.28279D0, & 0.26692D0, 0.24362D0, 0.21944D0, 0.19183D0, 0.17138D0, & 0.13995D0, 0.11519D0, 0.09486D0, 0.07444D0, 0.05860D0, & 0.04659D0, 0.03750D0, 0.03056D0, 0.02523D0, 0.02111D0, & 0.01751D0, 0.01454D0, 0.01191D0, 0.00957D0, 0.00764D0, & 0.00598D0, 0.00450D0, 0.00328D0, 0.00247D0, 0.00167D0, & 0.00107D0, 0.00076D0, 0.00044D0, 0.00016D0, 0.00005D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 7),I=1,49)/ & 1.16556D0, 1.02401D0, 0.89875D0, 0.83219D0, 0.78769D0, & 0.75465D0, 0.65951D0, 0.57450D0, 0.52889D0, 0.49818D0, & 0.47520D0, 0.40838D0, 0.34748D0, 0.31432D0, 0.29177D0, & 0.27481D0, 0.24995D0, 0.22424D0, 0.19505D0, 0.17361D0, & 0.14101D0, 0.11563D0, 0.09500D0, 0.07441D0, 0.05852D0, & 0.04652D0, 0.03740D0, 0.03045D0, 0.02509D0, 0.02093D0, & 0.01733D0, 0.01434D0, 0.01170D0, 0.00939D0, 0.00744D0, & 0.00582D0, 0.00436D0, 0.00318D0, 0.00238D0, 0.00161D0, & 0.00104D0, 0.00073D0, 0.00042D0, 0.00014D0, 0.00005D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 8),I=1,49)/ & 1.26306D0, 1.10484D0, 0.96554D0, 0.89180D0, 0.84263D0, & 0.80618D0, 0.70157D0, 0.60853D0, 0.55877D0, 0.52532D0, & 0.50028D0, 0.42768D0, 0.36175D0, 0.32597D0, 0.30171D0, & 0.28349D0, 0.25687D0, 0.22944D0, 0.19851D0, 0.17597D0, & 0.14210D0, 0.11607D0, 0.09509D0, 0.07433D0, 0.05839D0, & 0.04638D0, 0.03725D0, 0.03028D0, 0.02490D0, 0.02071D0, & 0.01710D0, 0.01411D0, 0.01147D0, 0.00917D0, 0.00724D0, & 0.00565D0, 0.00421D0, 0.00306D0, 0.00228D0, 0.00155D0, & 0.00101D0, 0.00070D0, 0.00040D0, 0.00013D0, 0.00005D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I, 9),I=1,49)/ & 1.36120D0, 1.18550D0, 1.03156D0, 0.95040D0, 0.89642D0, & 0.85647D0, 0.74219D0, 0.64102D0, 0.58710D0, 0.55092D0, & 0.52385D0, 0.44558D0, 0.37481D0, 0.33656D0, 0.31068D0, & 0.29130D0, 0.26304D0, 0.23405D0, 0.20153D0, 0.17803D0, & 0.14303D0, 0.11643D0, 0.09515D0, 0.07423D0, 0.05825D0, & 0.04622D0, 0.03709D0, 0.03010D0, 0.02471D0, 0.02052D0, & 0.01688D0, 0.01389D0, 0.01125D0, 0.00895D0, 0.00706D0, & 0.00550D0, 0.00409D0, 0.00295D0, 0.00220D0, 0.00150D0, & 0.00098D0, 0.00067D0, 0.00039D0, 0.00013D0, 0.00005D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,10),I=1,49)/ & 1.47041D0, 1.27446D0, 1.10370D0, 1.01406D0, 0.95460D0, & 0.91068D0, 0.78549D0, 0.67526D0, 0.61674D0, 0.57757D0, & 0.54827D0, 0.46388D0, 0.38797D0, 0.34713D0, 0.31960D0, & 0.29901D0, 0.26910D0, 0.23853D0, 0.20444D0, 0.17998D0, & 0.14388D0, 0.11673D0, 0.09517D0, 0.07410D0, 0.05807D0, & 0.04602D0, 0.03690D0, 0.02989D0, 0.02450D0, 0.02029D0, & 0.01665D0, 0.01365D0, 0.01102D0, 0.00875D0, 0.00689D0, & 0.00534D0, 0.00396D0, 0.00285D0, 0.00213D0, 0.00144D0, & 0.00094D0, 0.00064D0, 0.00038D0, 0.00013D0, 0.00004D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,11),I=1,49)/ & 1.56638D0, 1.35212D0, 1.16625D0, 1.06903D0, 1.00469D0, & 0.95725D0, 0.82240D0, 0.70420D0, 0.64167D0, 0.59990D0, & 0.56868D0, 0.47904D0, 0.39878D0, 0.35576D0, 0.32683D0, & 0.30525D0, 0.27397D0, 0.24210D0, 0.20674D0, 0.18151D0, & 0.14453D0, 0.11694D0, 0.09517D0, 0.07398D0, 0.05791D0, & 0.04585D0, 0.03673D0, 0.02971D0, 0.02433D0, 0.02010D0, & 0.01646D0, 0.01346D0, 0.01083D0, 0.00860D0, 0.00675D0, & 0.00520D0, 0.00385D0, 0.00277D0, 0.00207D0, 0.00139D0, & 0.00090D0, 0.00062D0, 0.00037D0, 0.00013D0, 0.00004D0, & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,12),I=1,49)/ & 1.80214D0, 1.54109D0, 1.31694D0, 1.20067D0, 1.12412D0, & 1.06789D0, 0.90916D0, 0.77146D0, 0.69919D0, 0.65116D0, & 0.61534D0, 0.51323D0, 0.42280D0, 0.37478D0, 0.34269D0, & 0.31886D0, 0.28449D0, 0.24976D0, 0.21162D0, 0.18471D0, & 0.14585D0, 0.11732D0, 0.09509D0, 0.07364D0, 0.05748D0, & 0.04542D0, 0.03629D0, 0.02928D0, 0.02389D0, 0.01964D0, & 0.01603D0, 0.01303D0, 0.01043D0, 0.00824D0, 0.00644D0, & 0.00493D0, 0.00365D0, 0.00261D0, 0.00193D0, 0.00129D0, & 0.00082D0, 0.00058D0, 0.00033D0, 0.00012D0, 0.00003D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,13),I=1,49)/ & 2.04055D0, 1.73004D0, 1.46588D0, 1.32988D0, 1.24076D0, & 1.17553D0, 0.99250D0, 0.83521D0, 0.75328D0, 0.69907D0, & 0.65875D0, 0.54456D0, 0.44445D0, 0.39176D0, 0.35673D0, & 0.33084D0, 0.29368D0, 0.25636D0, 0.21574D0, 0.18736D0, & 0.14688D0, 0.11755D0, 0.09493D0, 0.07328D0, 0.05705D0, & 0.04498D0, 0.03587D0, 0.02887D0, 0.02347D0, 0.01921D0, & 0.01564D0, 0.01265D0, 0.01010D0, 0.00793D0, 0.00617D0, & 0.00472D0, 0.00348D0, 0.00248D0, 0.00181D0, 0.00123D0, & 0.00077D0, 0.00054D0, 0.00031D0, 0.00011D0, 0.00003D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,14),I=1,49)/ & 2.34878D0, 1.97162D0, 1.65417D0, 1.49212D0, 1.38650D0, & 1.30951D0, 1.09500D0, 0.91263D0, 0.81846D0, 0.75649D0, & 0.71054D0, 0.58140D0, 0.46952D0, 0.41122D0, 0.37271D0, & 0.34438D0, 0.30396D0, 0.26367D0, 0.22023D0, 0.19019D0, & 0.14790D0, 0.11770D0, 0.09464D0, 0.07279D0, 0.05650D0, & 0.04444D0, 0.03534D0, 0.02838D0, 0.02299D0, 0.01873D0, & 0.01518D0, 0.01221D0, 0.00971D0, 0.00758D0, 0.00587D0, & 0.00448D0, 0.00329D0, 0.00233D0, 0.00171D0, 0.00117D0, & 0.00073D0, 0.00051D0, 0.00028D0, 0.00010D0, 0.00003D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,15),I=1,49)/ & 2.72076D0, 2.25974D0, 1.87603D0, 1.68193D0, 1.55614D0, & 1.46482D0, 1.21228D0, 1.00004D0, 0.89145D0, 0.82040D0, & 0.76790D0, 0.62156D0, 0.49638D0, 0.43184D0, 0.38951D0, & 0.35852D0, 0.31456D0, 0.27109D0, 0.22467D0, 0.19292D0, & 0.14878D0, 0.11770D0, 0.09423D0, 0.07216D0, 0.05583D0, & 0.04380D0, 0.03471D0, 0.02777D0, 0.02242D0, 0.01821D0, & 0.01468D0, 0.01176D0, 0.00931D0, 0.00721D0, 0.00560D0, & 0.00425D0, 0.00310D0, 0.00215D0, 0.00160D0, 0.00107D0, & 0.00067D0, 0.00046D0, 0.00026D0, 0.00009D0, 0.00003D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,16),I=1,49)/ & 3.10372D0, 2.55317D0, 2.09952D0, 1.87189D0, 1.72513D0, & 1.61899D0, 1.32738D0, 1.08482D0, 0.96174D0, 0.88163D0, & 0.82262D0, 0.65935D0, 0.52128D0, 0.45078D0, 0.40481D0, & 0.37132D0, 0.32407D0, 0.27766D0, 0.22852D0, 0.19522D0, & 0.14943D0, 0.11759D0, 0.09376D0, 0.07153D0, 0.05518D0, & 0.04316D0, 0.03411D0, 0.02721D0, 0.02189D0, 0.01771D0, & 0.01421D0, 0.01135D0, 0.00894D0, 0.00691D0, 0.00532D0, & 0.00403D0, 0.00292D0, 0.00202D0, 0.00150D0, 0.00098D0, & 0.00063D0, 0.00043D0, 0.00024D0, 0.00009D0, 0.00003D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,17),I=1,49)/ & 3.53791D0, 2.88253D0, 2.34786D0, 2.08172D0, 1.91099D0, & 1.78798D0, 1.45224D0, 1.17581D0, 1.03669D0, 0.94660D0, & 0.88048D0, 0.69881D0, 0.54694D0, 0.47011D0, 0.42034D0, & 0.38424D0, 0.33357D0, 0.28414D0, 0.23224D0, 0.19739D0, & 0.14997D0, 0.11738D0, 0.09322D0, 0.07083D0, 0.05448D0, & 0.04248D0, 0.03349D0, 0.02663D0, 0.02135D0, 0.01720D0, & 0.01373D0, 0.01094D0, 0.00857D0, 0.00662D0, 0.00504D0, & 0.00382D0, 0.00275D0, 0.00191D0, 0.00140D0, 0.00091D0, & 0.00060D0, 0.00040D0, 0.00021D0, 0.00008D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,18),I=1,49)/ & 3.93600D0, 3.18179D0, 2.57144D0, 2.26962D0, 2.07679D0, & 1.93828D0, 1.56224D0, 1.25519D0, 1.10169D0, 1.00271D0, & 0.93026D0, 0.73238D0, 0.56848D0, 0.48622D0, 0.43319D0, & 0.39487D0, 0.34131D0, 0.28936D0, 0.23517D0, 0.19905D0, & 0.15030D0, 0.11713D0, 0.09270D0, 0.07021D0, 0.05385D0, & 0.04190D0, 0.03295D0, 0.02612D0, 0.02087D0, 0.01677D0, & 0.01334D0, 0.01060D0, 0.00827D0, 0.00637D0, 0.00486D0, & 0.00366D0, 0.00263D0, 0.00181D0, 0.00134D0, 0.00088D0, & 0.00056D0, 0.00038D0, 0.00020D0, 0.00007D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,19),I=1,49)/ & 4.46512D0, 3.57604D0, 2.86339D0, 2.51369D0, 2.29136D0, & 2.13222D0, 1.70289D0, 1.35573D0, 1.18356D0, 1.07308D0, & 0.99248D0, 0.77387D0, 0.59477D0, 0.50571D0, 0.44864D0, & 0.40759D0, 0.35048D0, 0.29545D0, 0.23852D0, 0.20087D0, & 0.15057D0, 0.11671D0, 0.09200D0, 0.06939D0, 0.05304D0, & 0.04116D0, 0.03225D0, 0.02548D0, 0.02030D0, 0.01627D0, & 0.01289D0, 0.01018D0, 0.00793D0, 0.00608D0, 0.00462D0, & 0.00346D0, 0.00247D0, 0.00170D0, 0.00124D0, 0.00082D0, & 0.00052D0, 0.00036D0, 0.00020D0, 0.00007D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,20),I=1,49)/ & 4.98110D0, 3.95717D0, 3.14315D0, 2.74636D0, 2.49515D0, & 2.31589D0, 1.83490D0, 1.44924D0, 1.25928D0, 1.13790D0, & 1.04961D0, 0.81156D0, 0.61839D0, 0.52309D0, 0.46234D0, & 0.41880D0, 0.35851D0, 0.30072D0, 0.24136D0, 0.20237D0, & 0.15073D0, 0.11629D0, 0.09134D0, 0.06865D0, 0.05232D0, & 0.04048D0, 0.03163D0, 0.02492D0, 0.01980D0, 0.01582D0, & 0.01251D0, 0.00983D0, 0.00765D0, 0.00583D0, 0.00441D0, & 0.00330D0, 0.00234D0, 0.00161D0, 0.00116D0, 0.00076D0, & 0.00049D0, 0.00034D0, 0.00019D0, 0.00006D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,21),I=1,49)/ & 5.48855D0, 4.32906D0, 3.41400D0, 2.97058D0, 2.69088D0, & 2.49185D0, 1.96033D0, 1.53734D0, 1.33025D0, 1.19843D0, & 1.10279D0, 0.84628D0, 0.63987D0, 0.53877D0, 0.47461D0, & 0.42879D0, 0.36557D0, 0.30530D0, 0.24373D0, 0.20356D0, & 0.15074D0, 0.11580D0, 0.09065D0, 0.06792D0, 0.05161D0, & 0.03984D0, 0.03104D0, 0.02440D0, 0.01932D0, 0.01538D0, & 0.01214D0, 0.00950D0, 0.00738D0, 0.00561D0, 0.00423D0, & 0.00315D0, 0.00224D0, 0.00152D0, 0.00110D0, 0.00072D0, & 0.00045D0, 0.00032D0, 0.00018D0, 0.00006D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,22),I=1,49)/ & 6.18910D0, 4.83835D0, 3.78189D0, 3.27368D0, 2.95458D0, & 2.72828D0, 2.12748D0, 1.65375D0, 1.42355D0, 1.27771D0, & 1.17223D0, 0.89116D0, 0.66734D0, 0.55867D0, 0.49010D0, & 0.44134D0, 0.37438D0, 0.31092D0, 0.24658D0, 0.20493D0, & 0.15066D0, 0.11512D0, 0.08974D0, 0.06696D0, 0.05069D0, & 0.03901D0, 0.03030D0, 0.02374D0, 0.01874D0, 0.01485D0, & 0.01168D0, 0.00911D0, 0.00704D0, 0.00533D0, 0.00400D0, & 0.00297D0, 0.00211D0, 0.00142D0, 0.00104D0, 0.00068D0, & 0.00042D0, 0.00029D0, 0.00017D0, 0.00005D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,23),I=1,49)/ & 6.90776D0, 5.35634D0, 4.15288D0, 3.57780D0, 3.21822D0, & 2.96398D0, 2.29266D0, 1.76775D0, 1.51442D0, 1.35462D0, & 1.23937D0, 0.93411D0, 0.69332D0, 0.57734D0, 0.50454D0, & 0.45297D0, 0.38246D0, 0.31600D0, 0.24910D0, 0.20608D0, & 0.15048D0, 0.11442D0, 0.08886D0, 0.06603D0, 0.04982D0, & 0.03823D0, 0.02961D0, 0.02314D0, 0.01820D0, 0.01437D0, & 0.01125D0, 0.00875D0, 0.00671D0, 0.00507D0, 0.00380D0, & 0.00282D0, 0.00198D0, 0.00134D0, 0.00099D0, 0.00065D0, & 0.00039D0, 0.00026D0, 0.00015D0, 0.00005D0, 0.00002D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,24),I=1,49)/ & 7.62426D0, 5.86871D0, 4.51692D0, 3.87481D0, 3.47482D0, & 3.19280D0, 2.45168D0, 1.87657D0, 1.60070D0, 1.42736D0, & 1.30266D0, 0.97414D0, 0.71722D0, 0.59437D0, 0.51760D0, & 0.46341D0, 0.38962D0, 0.32042D0, 0.25117D0, 0.20694D0, & 0.15017D0, 0.11367D0, 0.08795D0, 0.06511D0, 0.04897D0, & 0.03748D0, 0.02894D0, 0.02253D0, 0.01769D0, 0.01392D0, & 0.01087D0, 0.00842D0, 0.00645D0, 0.00484D0, 0.00362D0, & 0.00267D0, 0.00187D0, 0.00128D0, 0.00093D0, 0.00060D0, & 0.00037D0, 0.00024D0, 0.00014D0, 0.00004D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,25),I=1,49)/ & 8.39819D0, 6.41814D0, 4.90446D0, 4.18965D0, 3.74601D0, & 3.43405D0, 2.61811D0, 1.98959D0, 1.68991D0, 1.50231D0, & 1.36770D0, 1.01493D0, 0.74134D0, 0.61144D0, 0.53063D0, & 0.47380D0, 0.39668D0, 0.32474D0, 0.25316D0, 0.20772D0, & 0.14981D0, 0.11289D0, 0.08703D0, 0.06420D0, 0.04813D0, & 0.03673D0, 0.02828D0, 0.02194D0, 0.01719D0, 0.01349D0, & 0.01049D0, 0.00810D0, 0.00620D0, 0.00463D0, 0.00344D0, & 0.00252D0, 0.00177D0, 0.00122D0, 0.00086D0, 0.00056D0, & 0.00034D0, 0.00023D0, 0.00012D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,26),I=1,49)/ & 9.19912D0, 6.98269D0, 5.29980D0, 4.50945D0, 4.02062D0, & 3.67776D0, 2.78497D0, 2.10203D0, 1.77824D0, 1.57626D0, & 1.43169D0, 1.05466D0, 0.76454D0, 0.62772D0, 0.54298D0, & 0.48357D0, 0.40325D0, 0.32867D0, 0.25488D0, 0.20830D0, & 0.14936D0, 0.11205D0, 0.08608D0, 0.06328D0, 0.04729D0, & 0.03598D0, 0.02762D0, 0.02140D0, 0.01669D0, 0.01307D0, & 0.01014D0, 0.00780D0, 0.00595D0, 0.00443D0, 0.00330D0, & 0.00240D0, 0.00168D0, 0.00114D0, 0.00081D0, 0.00053D0, & 0.00032D0, 0.00022D0, 0.00012D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,27),I=1,49)/ & 10.00621D0, 7.54783D0, 5.69293D0, 4.82623D0, 4.29189D0, & 3.91798D0, 2.94832D0, 2.21133D0, 1.86373D0, 1.64761D0, & 1.49327D0, 1.09257D0, 0.78647D0, 0.64301D0, 0.55451D0, & 0.49265D0, 0.40930D0, 0.33223D0, 0.25638D0, 0.20876D0, & 0.14886D0, 0.11122D0, 0.08517D0, 0.06240D0, 0.04650D0, & 0.03528D0, 0.02702D0, 0.02089D0, 0.01623D0, 0.01267D0, & 0.00980D0, 0.00752D0, 0.00573D0, 0.00425D0, 0.00316D0, & 0.00230D0, 0.00159D0, 0.00107D0, 0.00077D0, 0.00050D0, & 0.00030D0, 0.00020D0, 0.00011D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,28),I=1,49)/ & 10.80590D0, 8.10435D0, 6.07766D0, 5.13510D0, 4.55568D0, & 4.15111D0, 3.10583D0, 2.31601D0, 1.94527D0, 1.71546D0, & 1.55167D0, 1.12822D0, 0.80689D0, 0.65715D0, 0.56511D0, & 0.50095D0, 0.41476D0, 0.33539D0, 0.25764D0, 0.20907D0, & 0.14833D0, 0.11039D0, 0.08428D0, 0.06155D0, 0.04576D0, & 0.03462D0, 0.02647D0, 0.02040D0, 0.01582D0, 0.01230D0, & 0.00949D0, 0.00726D0, 0.00551D0, 0.00409D0, 0.00302D0, & 0.00221D0, 0.00152D0, 0.00102D0, 0.00073D0, 0.00048D0, & 0.00029D0, 0.00019D0, 0.00010D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,29),I=1,49)/ & 11.65207D0, 8.68978D0, 6.48001D0, 5.45700D0, 4.82993D0, & 4.39300D0, 3.26826D0, 2.42329D0, 2.02852D0, 1.78454D0, & 1.61099D0, 1.16415D0, 0.82729D0, 0.67117D0, 0.57557D0, & 0.50910D0, 0.42008D0, 0.33842D0, 0.25880D0, 0.20930D0, & 0.14773D0, 0.10953D0, 0.08337D0, 0.06069D0, 0.04500D0, & 0.03397D0, 0.02591D0, 0.01991D0, 0.01541D0, 0.01194D0, & 0.00919D0, 0.00702D0, 0.00530D0, 0.00393D0, 0.00290D0, & 0.00211D0, 0.00145D0, 0.00096D0, 0.00070D0, 0.00045D0, & 0.00028D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,30),I=1,49)/ & 12.52131D0, 9.28774D0, 6.88859D0, 5.78276D0, 5.10678D0, & 4.63673D0, 3.43094D0, 2.53005D0, 2.11104D0, 1.85281D0, & 1.66948D0, 1.19929D0, 0.84705D0, 0.68466D0, 0.58556D0, & 0.51685D0, 0.42507D0, 0.34121D0, 0.25979D0, 0.20942D0, & 0.14709D0, 0.10866D0, 0.08245D0, 0.05983D0, 0.04425D0, & 0.03334D0, 0.02536D0, 0.01943D0, 0.01501D0, 0.01160D0, & 0.00891D0, 0.00678D0, 0.00511D0, 0.00378D0, 0.00279D0, & 0.00202D0, 0.00138D0, 0.00091D0, 0.00067D0, 0.00043D0, & 0.00026D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,31),I=1,49)/ & 13.38978D0, 9.88200D0, 7.29246D0, 6.10376D0, 5.37897D0, & 4.87592D0, 3.58970D0, 2.63365D0, 2.19084D0, 1.91866D0, & 1.72578D0, 1.23288D0, 0.86578D0, 0.69738D0, 0.59494D0, & 0.52409D0, 0.42970D0, 0.34375D0, 0.26065D0, 0.20947D0, & 0.14644D0, 0.10781D0, 0.08158D0, 0.05902D0, 0.04354D0, & 0.03274D0, 0.02484D0, 0.01899D0, 0.01463D0, 0.01128D0, & 0.00865D0, 0.00657D0, 0.00493D0, 0.00364D0, 0.00268D0, & 0.00194D0, 0.00132D0, 0.00087D0, 0.00064D0, 0.00041D0, & 0.00025D0, 0.00017D0, 0.00009D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,32),I=1,49)/ & 14.23688D0, 10.45864D0, 7.68231D0, 6.41264D0, 5.64030D0, & 5.10517D0, 3.74102D0, 2.73180D0, 2.26617D0, 1.98065D0, & 1.77865D0, 1.26417D0, 0.88305D0, 0.70902D0, 0.60346D0, & 0.53062D0, 0.43382D0, 0.34595D0, 0.26134D0, 0.20941D0, & 0.14577D0, 0.10696D0, 0.08072D0, 0.05825D0, 0.04287D0, & 0.03215D0, 0.02436D0, 0.01857D0, 0.01428D0, 0.01098D0, & 0.00840D0, 0.00638D0, 0.00476D0, 0.00351D0, 0.00258D0, & 0.00187D0, 0.00127D0, 0.00083D0, 0.00061D0, 0.00039D0, & 0.00024D0, 0.00016D0, 0.00009D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,33),I=1,49)/ & 15.13941D0, 11.07021D0, 8.09390D0, 6.73786D0, 5.91493D0, & 5.34574D0, 3.89907D0, 2.83385D0, 2.34427D0, 2.04479D0, & 1.83327D0, 1.29634D0, 0.90070D0, 0.72088D0, 0.61213D0, & 0.53725D0, 0.43798D0, 0.34817D0, 0.26202D0, 0.20935D0, & 0.14510D0, 0.10612D0, 0.07988D0, 0.05749D0, 0.04221D0, & 0.03158D0, 0.02388D0, 0.01816D0, 0.01393D0, 0.01069D0, & 0.00816D0, 0.00620D0, 0.00459D0, 0.00338D0, 0.00248D0, & 0.00179D0, 0.00121D0, 0.00080D0, 0.00058D0, 0.00037D0, & 0.00022D0, 0.00014D0, 0.00008D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,34),I=1,49)/ & 16.04276D0, 11.67919D0, 8.50158D0, 7.05899D0, 6.18548D0, & 5.58230D0, 4.05359D0, 2.93300D0, 2.41985D0, 2.10667D0, & 1.88583D0, 1.32700D0, 0.91732D0, 0.73194D0, 0.62013D0, & 0.54331D0, 0.44171D0, 0.35007D0, 0.26248D0, 0.20913D0, & 0.14434D0, 0.10523D0, 0.07901D0, 0.05671D0, 0.04155D0, & 0.03102D0, 0.02340D0, 0.01777D0, 0.01360D0, 0.01042D0, & 0.00793D0, 0.00600D0, 0.00446D0, 0.00326D0, 0.00238D0, & 0.00173D0, 0.00118D0, 0.00076D0, 0.00055D0, 0.00036D0, & 0.00022D0, 0.00014D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,35),I=1,49)/ & 16.94849D0, 12.28721D0, 8.90688D0, 7.37746D0, 6.45332D0, & 5.81617D0, 4.20570D0, 3.03017D0, 2.49373D0, 2.16705D0, & 1.93704D0, 1.35674D0, 0.93336D0, 0.74257D0, 0.62781D0, & 0.54911D0, 0.44527D0, 0.35187D0, 0.26291D0, 0.20892D0, & 0.14363D0, 0.10440D0, 0.07819D0, 0.05599D0, 0.04092D0, & 0.03050D0, 0.02296D0, 0.01740D0, 0.01329D0, 0.01017D0, & 0.00772D0, 0.00583D0, 0.00433D0, 0.00315D0, 0.00229D0, & 0.00167D0, 0.00114D0, 0.00073D0, 0.00053D0, 0.00035D0, & 0.00021D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,36),I=1,49)/ & 17.83243D0, 12.87802D0, 9.29900D0, 7.68475D0, 6.71127D0, & 6.04107D0, 4.35129D0, 3.12272D0, 2.56388D0, 2.22424D0, & 1.98545D0, 1.38466D0, 0.94830D0, 0.75241D0, 0.63488D0, & 0.55441D0, 0.44848D0, 0.35346D0, 0.26323D0, 0.20867D0, & 0.14292D0, 0.10358D0, 0.07741D0, 0.05529D0, 0.04033D0, & 0.03000D0, 0.02255D0, 0.01705D0, 0.01300D0, 0.00993D0, & 0.00753D0, 0.00566D0, 0.00421D0, 0.00306D0, 0.00221D0, & 0.00161D0, 0.00110D0, 0.00071D0, 0.00051D0, 0.00034D0, & 0.00020D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,37),I=1,49)/ & 18.74867D0, 13.48785D0, 9.70200D0, 7.99976D0, 6.97522D0, & 6.27087D0, 4.49936D0, 3.21639D0, 2.63465D0, 2.28182D0, & 2.03408D0, 1.41252D0, 0.96307D0, 0.76207D0, 0.64176D0, & 0.55956D0, 0.45155D0, 0.35492D0, 0.26347D0, 0.20834D0, & 0.14216D0, 0.10274D0, 0.07660D0, 0.05459D0, 0.03974D0, & 0.02950D0, 0.02213D0, 0.01670D0, 0.01272D0, 0.00970D0, & 0.00733D0, 0.00550D0, 0.00408D0, 0.00297D0, 0.00214D0, & 0.00155D0, 0.00105D0, 0.00068D0, 0.00049D0, 0.00032D0, & 0.00018D0, 0.00012D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,4,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 1),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 2),I=1,49)/ & 0.00003D0, 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0, & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, & 0.00002D0, 0.00002D0, 0.00001D0, 0.00001D0, 0.00001D0, & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, & 0.00001D0, 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 3),I=1,49)/ & 0.03227D0, 0.02900D0, 0.02605D0, 0.02445D0, 0.02338D0, & 0.02257D0, 0.02019D0, 0.01798D0, 0.01674D0, 0.01586D0, & 0.01516D0, 0.01302D0, 0.01084D0, 0.00956D0, 0.00865D0, & 0.00795D0, 0.00692D0, 0.00587D0, 0.00477D0, 0.00405D0, & 0.00317D0, 0.00263D0, 0.00225D0, 0.00190D0, 0.00163D0, & 0.00139D0, 0.00119D0, 0.00101D0, 0.00085D0, 0.00072D0, & 0.00059D0, 0.00048D0, 0.00039D0, 0.00031D0, 0.00025D0, & 0.00019D0, 0.00015D0, 0.00011D0, 0.00008D0, 0.00006D0, & 0.00004D0, 0.00003D0, 0.00002D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 4),I=1,49)/ & 0.08412D0, 0.07493D0, 0.06672D0, 0.06231D0, 0.05935D0, & 0.05713D0, 0.05068D0, 0.04474D0, 0.04144D0, 0.03913D0, & 0.03731D0, 0.03177D0, 0.02623D0, 0.02303D0, 0.02077D0, & 0.01905D0, 0.01652D0, 0.01397D0, 0.01129D0, 0.00957D0, & 0.00745D0, 0.00615D0, 0.00525D0, 0.00441D0, 0.00375D0, & 0.00320D0, 0.00272D0, 0.00230D0, 0.00193D0, 0.00161D0, & 0.00132D0, 0.00108D0, 0.00087D0, 0.00069D0, 0.00054D0, & 0.00042D0, 0.00032D0, 0.00024D0, 0.00018D0, 0.00013D0, & 0.00009D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 5),I=1,49)/ & 0.14877D0, 0.13082D0, 0.11499D0, 0.10659D0, 0.10097D0, & 0.09680D0, 0.08477D0, 0.07388D0, 0.06791D0, 0.06379D0, & 0.06056D0, 0.05091D0, 0.04152D0, 0.03619D0, 0.03249D0, & 0.02969D0, 0.02561D0, 0.02153D0, 0.01729D0, 0.01459D0, & 0.01127D0, 0.00925D0, 0.00785D0, 0.00655D0, 0.00553D0, & 0.00469D0, 0.00396D0, 0.00333D0, 0.00278D0, 0.00231D0, & 0.00189D0, 0.00153D0, 0.00123D0, 0.00097D0, 0.00076D0, & 0.00059D0, 0.00045D0, 0.00034D0, 0.00025D0, 0.00018D0, & 0.00012D0, 0.00009D0, 0.00006D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 6),I=1,49)/ & 0.22202D0, 0.19306D0, 0.16779D0, 0.15452D0, 0.14570D0, & 0.13918D0, 0.12051D0, 0.10386D0, 0.09484D0, 0.08868D0, & 0.08388D0, 0.06972D0, 0.05624D0, 0.04872D0, 0.04355D0, & 0.03966D0, 0.03405D0, 0.02848D0, 0.02274D0, 0.01911D0, & 0.01466D0, 0.01197D0, 0.01011D0, 0.00838D0, 0.00703D0, & 0.00592D0, 0.00498D0, 0.00416D0, 0.00346D0, 0.00286D0, & 0.00233D0, 0.00188D0, 0.00150D0, 0.00118D0, 0.00092D0, & 0.00071D0, 0.00054D0, 0.00041D0, 0.00030D0, 0.00021D0, & 0.00015D0, 0.00010D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 7),I=1,49)/ & 0.30272D0, 0.26063D0, 0.22430D0, 0.20535D0, 0.19284D0, & 0.18362D0, 0.15743D0, 0.13433D0, 0.12195D0, 0.11355D0, & 0.10705D0, 0.08808D0, 0.07034D0, 0.06058D0, 0.05394D0, & 0.04898D0, 0.04185D0, 0.03485D0, 0.02767D0, 0.02316D0, & 0.01766D0, 0.01434D0, 0.01204D0, 0.00992D0, 0.00828D0, & 0.00693D0, 0.00580D0, 0.00482D0, 0.00399D0, 0.00328D0, & 0.00266D0, 0.00214D0, 0.00170D0, 0.00133D0, 0.00104D0, & 0.00080D0, 0.00060D0, 0.00045D0, 0.00033D0, 0.00024D0, & 0.00016D0, 0.00011D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 8),I=1,49)/ & 0.40640D0, 0.34641D0, 0.29514D0, 0.26863D0, 0.25121D0, & 0.23843D0, 0.20237D0, 0.17095D0, 0.15427D0, 0.14303D0, & 0.13440D0, 0.10944D0, 0.08650D0, 0.07407D0, 0.06568D0, & 0.05945D0, 0.05056D0, 0.04189D0, 0.03309D0, 0.02757D0, & 0.02089D0, 0.01686D0, 0.01408D0, 0.01153D0, 0.00956D0, & 0.00796D0, 0.00662D0, 0.00548D0, 0.00451D0, 0.00369D0, & 0.00298D0, 0.00239D0, 0.00189D0, 0.00148D0, 0.00114D0, & 0.00087D0, 0.00066D0, 0.00049D0, 0.00037D0, 0.00026D0, & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I, 9),I=1,49)/ & 0.51210D0, 0.43288D0, 0.36574D0, 0.33126D0, 0.30871D0, & 0.29222D0, 0.24594D0, 0.20601D0, 0.18499D0, 0.17091D0, & 0.16014D0, 0.12927D0, 0.10130D0, 0.08631D0, 0.07626D0, & 0.06885D0, 0.05833D0, 0.04813D0, 0.03783D0, 0.03141D0, & 0.02366D0, 0.01900D0, 0.01580D0, 0.01287D0, 0.01061D0, & 0.00880D0, 0.00728D0, 0.00600D0, 0.00491D0, 0.00401D0, & 0.00322D0, 0.00257D0, 0.00203D0, 0.00158D0, 0.00122D0, & 0.00093D0, 0.00070D0, 0.00052D0, 0.00039D0, 0.00028D0, & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,10),I=1,49)/ & 0.62615D0, 0.52524D0, 0.44038D0, 0.39709D0, 0.36888D0, & 0.34831D0, 0.29091D0, 0.24179D0, 0.21613D0, 0.19903D0, & 0.18601D0, 0.14895D0, 0.11579D0, 0.09820D0, 0.08649D0, & 0.07789D0, 0.06575D0, 0.05404D0, 0.04228D0, 0.03498D0, & 0.02621D0, 0.02095D0, 0.01734D0, 0.01405D0, 0.01153D0, & 0.00952D0, 0.00784D0, 0.00644D0, 0.00525D0, 0.00426D0, & 0.00342D0, 0.00272D0, 0.00213D0, 0.00166D0, 0.00127D0, & 0.00097D0, 0.00073D0, 0.00054D0, 0.00040D0, 0.00029D0, & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,11),I=1,49)/ & 0.72756D0, 0.60673D0, 0.50572D0, 0.45443D0, 0.42111D0, & 0.39687D0, 0.32951D0, 0.27226D0, 0.24251D0, 0.22276D0, & 0.20777D0, 0.16535D0, 0.12775D0, 0.10795D0, 0.09484D0, & 0.08524D0, 0.07175D0, 0.05879D0, 0.04583D0, 0.03782D0, & 0.02821D0, 0.02247D0, 0.01853D0, 0.01496D0, 0.01223D0, & 0.01005D0, 0.00826D0, 0.00676D0, 0.00549D0, 0.00445D0, & 0.00355D0, 0.00282D0, 0.00221D0, 0.00171D0, 0.00131D0, & 0.00099D0, 0.00074D0, 0.00055D0, 0.00041D0, 0.00029D0, & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,12),I=1,49)/ & 0.97596D0, 0.80419D0, 0.66232D0, 0.59100D0, 0.54494D0, & 0.51159D0, 0.41968D0, 0.34257D0, 0.30297D0, 0.27688D0, & 0.25720D0, 0.20210D0, 0.15417D0, 0.12932D0, 0.11303D0, & 0.10119D0, 0.08465D0, 0.06892D0, 0.05333D0, 0.04376D0, & 0.03235D0, 0.02557D0, 0.02094D0, 0.01675D0, 0.01359D0, & 0.01109D0, 0.00904D0, 0.00734D0, 0.00594D0, 0.00477D0, & 0.00379D0, 0.00299D0, 0.00233D0, 0.00179D0, 0.00137D0, & 0.00103D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00030D0, & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,13),I=1,49)/ & 1.22977D0, 1.00344D0, 0.81836D0, 0.72605D0, 0.66675D0, & 0.62396D0, 0.50684D0, 0.40963D0, 0.36016D0, 0.32776D0, & 0.30345D0, 0.23597D0, 0.17813D0, 0.14851D0, 0.12924D0, & 0.11531D0, 0.09599D0, 0.07773D0, 0.05977D0, 0.04882D0, & 0.03581D0, 0.02811D0, 0.02289D0, 0.01818D0, 0.01465D0, & 0.01187D0, 0.00963D0, 0.00777D0, 0.00625D0, 0.00500D0, & 0.00395D0, 0.00310D0, 0.00241D0, 0.00185D0, 0.00140D0, & 0.00105D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0, & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,14),I=1,49)/ & 1.55816D0, 1.25825D0, 1.01555D0, 0.89552D0, 0.81883D0, & 0.76371D0, 0.61389D0, 0.49095D0, 0.42897D0, 0.38864D0, & 0.35854D0, 0.27572D0, 0.20581D0, 0.17047D0, 0.14766D0, & 0.13128D0, 0.10869D0, 0.08751D0, 0.06683D0, 0.05430D0, & 0.03950D0, 0.03078D0, 0.02489D0, 0.01962D0, 0.01569D0, & 0.01264D0, 0.01018D0, 0.00817D0, 0.00653D0, 0.00519D0, & 0.00408D0, 0.00319D0, 0.00246D0, 0.00188D0, 0.00142D0, & 0.00106D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0, & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,15),I=1,49)/ & 1.94525D0, 1.55494D0, 1.24230D0, 1.08896D0, 0.99149D0, & 0.92172D0, 0.73335D0, 0.58046D0, 0.50409D0, 0.45471D0, & 0.41801D0, 0.31797D0, 0.23473D0, 0.19316D0, 0.16655D0, & 0.14754D0, 0.12149D0, 0.09725D0, 0.07376D0, 0.05961D0, & 0.04299D0, 0.03326D0, 0.02672D0, 0.02089D0, 0.01659D0, & 0.01327D0, 0.01061D0, 0.00847D0, 0.00673D0, 0.00532D0, & 0.00416D0, 0.00323D0, 0.00248D0, 0.00188D0, 0.00142D0, & 0.00105D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00031D0, & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,16),I=1,49)/ & 2.34531D0, 1.85826D0, 1.47159D0, 1.28330D0, 1.16416D0, & 1.07915D0, 0.85101D0, 0.66758D0, 0.57668D0, 0.51821D0, & 0.47495D0, 0.35786D0, 0.26164D0, 0.21408D0, 0.18385D0, & 0.16236D0, 0.13305D0, 0.10596D0, 0.07987D0, 0.06425D0, & 0.04599D0, 0.03535D0, 0.02822D0, 0.02192D0, 0.01729D0, & 0.01375D0, 0.01093D0, 0.00867D0, 0.00685D0, 0.00540D0, & 0.00420D0, 0.00325D0, 0.00248D0, 0.00188D0, 0.00141D0, & 0.00104D0, 0.00076D0, 0.00056D0, 0.00041D0, 0.00030D0, & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,17),I=1,49)/ & 2.80142D0, 2.20072D0, 1.72790D0, 1.49927D0, 1.35523D0, & 1.25280D0, 0.97945D0, 0.76167D0, 0.65458D0, 0.58603D0, & 0.53553D0, 0.39978D0, 0.28955D0, 0.23561D0, 0.20153D0, & 0.17743D0, 0.14473D0, 0.11467D0, 0.08591D0, 0.06880D0, & 0.04888D0, 0.03733D0, 0.02963D0, 0.02285D0, 0.01791D0, & 0.01415D0, 0.01119D0, 0.00883D0, 0.00694D0, 0.00544D0, & 0.00421D0, 0.00324D0, 0.00247D0, 0.00186D0, 0.00139D0, & 0.00102D0, 0.00075D0, 0.00055D0, 0.00040D0, 0.00029D0, & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,18),I=1,49)/ & 3.21652D0, 2.50960D0, 1.95700D0, 1.69126D0, 1.52443D0, & 1.40610D0, 1.09176D0, 0.84313D0, 0.72161D0, 0.64414D0, & 0.58724D0, 0.43516D0, 0.31280D0, 0.25339D0, 0.21606D0, & 0.18974D0, 0.15419D0, 0.12166D0, 0.09071D0, 0.07236D0, & 0.05109D0, 0.03882D0, 0.03067D0, 0.02352D0, 0.01834D0, & 0.01442D0, 0.01135D0, 0.00892D0, 0.00699D0, 0.00545D0, & 0.00421D0, 0.00322D0, 0.00245D0, 0.00184D0, 0.00137D0, & 0.00100D0, 0.00073D0, 0.00053D0, 0.00039D0, 0.00029D0, & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,19),I=1,49)/ & 3.76652D0, 2.91536D0, 2.25532D0, 1.93997D0, 1.74280D0, & 1.60338D0, 1.23496D0, 0.94601D0, 0.80577D0, 0.71678D0, & 0.65167D0, 0.47873D0, 0.34109D0, 0.27487D0, 0.23349D0, & 0.20445D0, 0.16541D0, 0.12988D0, 0.09628D0, 0.07646D0, & 0.05359D0, 0.04046D0, 0.03178D0, 0.02422D0, 0.01877D0, & 0.01467D0, 0.01149D0, 0.00898D0, 0.00700D0, 0.00543D0, & 0.00418D0, 0.00319D0, 0.00241D0, 0.00180D0, 0.00134D0, & 0.00098D0, 0.00071D0, 0.00052D0, 0.00038D0, 0.00028D0, & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,20),I=1,49)/ & 4.30575D0, 3.30993D0, 2.54302D0, 2.17866D0, 1.95165D0, & 1.79153D0, 1.37036D0, 1.04242D0, 0.88422D0, 0.78423D0, & 0.71130D0, 0.51866D0, 0.36673D0, 0.29419D0, 0.24910D0, & 0.21757D0, 0.17534D0, 0.13711D0, 0.10112D0, 0.07999D0, & 0.05571D0, 0.04184D0, 0.03270D0, 0.02477D0, 0.01909D0, & 0.01486D0, 0.01158D0, 0.00901D0, 0.00699D0, 0.00541D0, & 0.00414D0, 0.00315D0, 0.00237D0, 0.00177D0, 0.00131D0, & 0.00095D0, 0.00069D0, 0.00050D0, 0.00037D0, 0.00027D0, & 0.00016D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,21),I=1,49)/ & 4.82956D0, 3.69021D0, 2.81808D0, 2.40576D0, 2.14966D0, & 1.96944D0, 1.49728D0, 1.13198D0, 0.95669D0, 0.84628D0, & 0.76597D0, 0.55486D0, 0.38968D0, 0.31136D0, 0.26288D0, & 0.22909D0, 0.18399D0, 0.14333D0, 0.10523D0, 0.08295D0, & 0.05744D0, 0.04293D0, 0.03340D0, 0.02518D0, 0.01931D0, & 0.01496D0, 0.01161D0, 0.00900D0, 0.00696D0, 0.00536D0, & 0.00409D0, 0.00310D0, 0.00233D0, 0.00173D0, 0.00128D0, & 0.00093D0, 0.00067D0, 0.00049D0, 0.00036D0, 0.00027D0, & 0.00015D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,22),I=1,49)/ & 5.55546D0, 4.21326D0, 3.19353D0, 2.71436D0, 2.41786D0, & 2.20981D0, 1.66741D0, 1.25104D0, 1.05255D0, 0.92807D0, & 0.83783D0, 0.60198D0, 0.41926D0, 0.33333D0, 0.28043D0, & 0.24370D0, 0.19489D0, 0.15111D0, 0.11032D0, 0.08657D0, & 0.05953D0, 0.04421D0, 0.03422D0, 0.02563D0, 0.01955D0, & 0.01506D0, 0.01163D0, 0.00897D0, 0.00690D0, 0.00529D0, & 0.00403D0, 0.00304D0, 0.00227D0, 0.00168D0, 0.00124D0, & 0.00090D0, 0.00064D0, 0.00047D0, 0.00035D0, 0.00026D0, & 0.00015D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,23),I=1,49)/ & 6.30033D0, 4.74567D0, 3.57260D0, 3.02443D0, 2.68642D0, & 2.44984D0, 1.83585D0, 1.36787D0, 1.14612D0, 1.00758D0, & 0.90746D0, 0.64718D0, 0.44730D0, 0.35401D0, 0.29686D0, & 0.25731D0, 0.20497D0, 0.15824D0, 0.11492D0, 0.08982D0, & 0.06136D0, 0.04532D0, 0.03489D0, 0.02598D0, 0.01971D0, & 0.01511D0, 0.01161D0, 0.00892D0, 0.00683D0, 0.00522D0, & 0.00395D0, 0.00297D0, 0.00222D0, 0.00163D0, 0.00120D0, & 0.00087D0, 0.00062D0, 0.00045D0, 0.00034D0, 0.00025D0, & 0.00014D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,24),I=1,49)/ & 7.03684D0, 5.26796D0, 3.94145D0, 3.32468D0, 2.94556D0, & 2.68082D0, 1.99651D0, 1.47829D0, 1.23404D0, 1.08198D0, & 0.97239D0, 0.68884D0, 0.47281D0, 0.37266D0, 0.31157D0, & 0.26944D0, 0.21386D0, 0.16445D0, 0.11886D0, 0.09256D0, & 0.06285D0, 0.04618D0, 0.03539D0, 0.02621D0, 0.01979D0, & 0.01510D0, 0.01155D0, 0.00884D0, 0.00675D0, 0.00513D0, & 0.00387D0, 0.00290D0, 0.00216D0, 0.00159D0, 0.00116D0, & 0.00084D0, 0.00060D0, 0.00044D0, 0.00033D0, 0.00024D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,25),I=1,49)/ & 7.83575D0, 5.83079D0, 4.33631D0, 3.64485D0, 3.22112D0, & 2.92590D0, 2.16582D0, 1.59383D0, 1.32566D0, 1.15927D0, & 1.03966D0, 0.73165D0, 0.49881D0, 0.39156D0, 0.32642D0, & 0.28163D0, 0.22275D0, 0.17063D0, 0.12274D0, 0.09523D0, & 0.06428D0, 0.04699D0, 0.03585D0, 0.02642D0, 0.01984D0, & 0.01507D0, 0.01148D0, 0.00875D0, 0.00665D0, 0.00505D0, & 0.00380D0, 0.00284D0, 0.00210D0, 0.00154D0, 0.00112D0, & 0.00081D0, 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,26),I=1,49)/ & 8.65815D0, 6.40607D0, 4.73699D0, 3.96832D0, 3.49865D0, & 3.17213D0, 2.33459D0, 1.70806D0, 1.41577D0, 1.23500D0, & 1.10538D0, 0.77305D0, 0.52365D0, 0.40947D0, 0.34040D0, & 0.29306D0, 0.23101D0, 0.17630D0, 0.12625D0, 0.09761D0, & 0.06550D0, 0.04766D0, 0.03620D0, 0.02654D0, 0.01984D0, & 0.01501D0, 0.01139D0, 0.00864D0, 0.00655D0, 0.00495D0, & 0.00371D0, 0.00276D0, 0.00204D0, 0.00149D0, 0.00108D0, & 0.00078D0, 0.00056D0, 0.00041D0, 0.00030D0, 0.00023D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,27),I=1,49)/ & 9.48773D0, 6.98283D0, 5.13620D0, 4.28942D0, 3.77342D0, & 3.41540D0, 2.50025D0, 1.81942D0, 1.50325D0, 1.30829D0, & 1.16884D0, 0.81270D0, 0.54722D0, 0.42638D0, 0.35354D0, & 0.30375D0, 0.23869D0, 0.18153D0, 0.12945D0, 0.09975D0, & 0.06658D0, 0.04823D0, 0.03648D0, 0.02662D0, 0.01982D0, & 0.01493D0, 0.01129D0, 0.00853D0, 0.00645D0, 0.00486D0, & 0.00363D0, 0.00270D0, 0.00199D0, 0.00145D0, 0.00105D0, & 0.00075D0, 0.00054D0, 0.00039D0, 0.00030D0, 0.00022D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,28),I=1,49)/ & 10.30763D0, 7.54945D0, 5.52601D0, 4.60181D0, 4.04004D0, & 3.65097D0, 2.65960D0, 1.92581D0, 1.58647D0, 1.37780D0, & 1.22885D0, 0.84989D0, 0.56911D0, 0.44198D0, 0.36560D0, & 0.31352D0, 0.24565D0, 0.18623D0, 0.13228D0, 0.10162D0, & 0.06750D0, 0.04868D0, 0.03669D0, 0.02666D0, 0.01976D0, & 0.01484D0, 0.01118D0, 0.00842D0, 0.00635D0, 0.00477D0, & 0.00355D0, 0.00263D0, 0.00193D0, 0.00141D0, 0.00102D0, & 0.00073D0, 0.00052D0, 0.00038D0, 0.00029D0, 0.00022D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,29),I=1,49)/ & 11.17527D0, 8.14579D0, 5.93397D0, 4.92768D0, 4.31749D0, & 3.89565D0, 2.82415D0, 2.03499D0, 1.67156D0, 1.44867D0, & 1.28991D0, 0.88743D0, 0.59103D0, 0.45751D0, 0.37756D0, & 0.32318D0, 0.25249D0, 0.19081D0, 0.13501D0, 0.10341D0, & 0.06835D0, 0.04909D0, 0.03686D0, 0.02667D0, 0.01969D0, & 0.01473D0, 0.01106D0, 0.00831D0, 0.00624D0, 0.00467D0, & 0.00347D0, 0.00257D0, 0.00188D0, 0.00136D0, 0.00099D0, & 0.00070D0, 0.00050D0, 0.00037D0, 0.00028D0, 0.00021D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,30),I=1,49)/ & 12.06456D0, 8.75358D0, 6.34740D0, 5.25678D0, 4.59701D0, & 4.14168D0, 2.98858D0, 2.14338D0, 1.75569D0, 1.51853D0, & 1.34994D0, 0.92405D0, 0.61221D0, 0.47241D0, 0.38898D0, & 0.33235D0, 0.25894D0, 0.19508D0, 0.13752D0, 0.10502D0, & 0.06908D0, 0.04942D0, 0.03697D0, 0.02664D0, 0.01960D0, & 0.01461D0, 0.01093D0, 0.00819D0, 0.00613D0, 0.00458D0, & 0.00339D0, 0.00250D0, 0.00183D0, 0.00132D0, 0.00095D0, & 0.00068D0, 0.00049D0, 0.00036D0, 0.00027D0, 0.00021D0, & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,31),I=1,49)/ & 12.95374D0, 9.35831D0, 6.75669D0, 5.58162D0, 4.87232D0, & 4.38360D0, 3.14942D0, 2.24882D0, 1.83726D0, 1.58610D0, & 1.40790D0, 0.95916D0, 0.63237D0, 0.48653D0, 0.39975D0, & 0.34099D0, 0.26498D0, 0.19905D0, 0.13983D0, 0.10648D0, & 0.06974D0, 0.04970D0, 0.03705D0, 0.02660D0, 0.01950D0, & 0.01449D0, 0.01081D0, 0.00807D0, 0.00603D0, 0.00449D0, & 0.00332D0, 0.00244D0, 0.00178D0, 0.00129D0, 0.00093D0, & 0.00066D0, 0.00047D0, 0.00035D0, 0.00026D0, 0.00020D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,32),I=1,49)/ & 13.81822D0, 9.94319D0, 7.15042D0, 5.89310D0, 5.13569D0, & 4.61461D0, 3.30209D0, 2.34827D0, 1.91389D0, 1.64940D0, & 1.46205D0, 0.99170D0, 0.65086D0, 0.49940D0, 0.40952D0, & 0.34877D0, 0.27037D0, 0.20256D0, 0.14182D0, 0.10773D0, & 0.07026D0, 0.04989D0, 0.03708D0, 0.02652D0, 0.01938D0, & 0.01436D0, 0.01068D0, 0.00795D0, 0.00592D0, 0.00440D0, & 0.00325D0, 0.00238D0, 0.00174D0, 0.00125D0, 0.00090D0, & 0.00064D0, 0.00046D0, 0.00034D0, 0.00026D0, 0.00020D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,33),I=1,49)/ & 14.74174D0, 10.56553D0, 7.56770D0, 6.22245D0, 5.41371D0, & 4.85814D0, 3.46239D0, 2.45228D0, 1.99384D0, 1.71531D0, & 1.51837D0, 1.02539D0, 0.66993D0, 0.51263D0, 0.41953D0, & 0.35674D0, 0.27589D0, 0.20614D0, 0.14386D0, 0.10899D0, & 0.07078D0, 0.05009D0, 0.03711D0, 0.02645D0, 0.01927D0, & 0.01422D0, 0.01055D0, 0.00784D0, 0.00582D0, 0.00432D0, & 0.00318D0, 0.00233D0, 0.00169D0, 0.00122D0, 0.00087D0, & 0.00062D0, 0.00044D0, 0.00033D0, 0.00025D0, 0.00020D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,34),I=1,49)/ & 15.66159D0, 11.18202D0, 7.97872D0, 6.54573D0, 5.68591D0, & 5.09611D0, 3.61802D0, 2.55254D0, 2.07056D0, 1.77835D0, & 1.57208D0, 1.05721D0, 0.68771D0, 0.52486D0, 0.42872D0, & 0.36401D0, 0.28085D0, 0.20931D0, 0.14560D0, 0.11004D0, & 0.07117D0, 0.05019D0, 0.03707D0, 0.02633D0, 0.01912D0, & 0.01408D0, 0.01041D0, 0.00771D0, 0.00572D0, 0.00423D0, & 0.00311D0, 0.00227D0, 0.00165D0, 0.00118D0, 0.00085D0, & 0.00060D0, 0.00043D0, 0.00032D0, 0.00025D0, 0.00020D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,35),I=1,49)/ & 16.58568D0, 11.79905D0, 8.38856D0, 6.86738D0, 5.95633D0, & 5.33223D0, 3.77185D0, 2.65127D0, 2.14594D0, 1.84019D0, & 1.62469D0, 1.08825D0, 0.70498D0, 0.53670D0, 0.43761D0, & 0.37103D0, 0.28563D0, 0.21235D0, 0.14727D0, 0.11103D0, & 0.07154D0, 0.05029D0, 0.03704D0, 0.02622D0, 0.01898D0, & 0.01394D0, 0.01028D0, 0.00760D0, 0.00562D0, 0.00415D0, & 0.00304D0, 0.00222D0, 0.00161D0, 0.00115D0, 0.00082D0, & 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0, 0.00019D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,36),I=1,49)/ & 17.48656D0, 12.39804D0, 8.78469D0, 7.17746D0, 6.21652D0, & 5.55909D0, 3.91895D0, 2.74520D0, 2.21743D0, 1.89869D0, & 1.67437D0, 1.11736D0, 0.72106D0, 0.54767D0, 0.44580D0, & 0.37747D0, 0.28999D0, 0.21509D0, 0.14875D0, 0.11190D0, & 0.07184D0, 0.05035D0, 0.03698D0, 0.02610D0, 0.01884D0, & 0.01380D0, 0.01016D0, 0.00749D0, 0.00553D0, 0.00407D0, & 0.00298D0, 0.00217D0, 0.00157D0, 0.00112D0, 0.00080D0, & 0.00057D0, 0.00041D0, 0.00031D0, 0.00024D0, 0.00019D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,37),I=1,49)/ & 18.41889D0, 13.01534D0, 9.19117D0, 7.49481D0, 6.48233D0, & 5.79049D0, 4.06828D0, 2.84006D0, 2.28940D0, 1.95745D0, & 1.72416D0, 1.14634D0, 0.73693D0, 0.55843D0, 0.45379D0, & 0.38373D0, 0.29419D0, 0.21770D0, 0.15013D0, 0.11269D0, & 0.07209D0, 0.05037D0, 0.03690D0, 0.02596D0, 0.01869D0, & 0.01365D0, 0.01003D0, 0.00738D0, 0.00543D0, 0.00399D0, & 0.00291D0, 0.00212D0, 0.00153D0, 0.00109D0, 0.00078D0, & 0.00055D0, 0.00040D0, 0.00030D0, 0.00023D0, 0.00019D0, & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,5,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 1),I=1,49)/ & 0.44989D0, 0.39539D0, 0.34747D0, 0.32216D0, 0.30531D0, & 0.29285D0, 0.25722D0, 0.22578D0, 0.20909D0, 0.19792D0, & 0.18955D0, 0.16547D0, 0.14378D0, 0.13212D0, 0.12429D0, & 0.11845D0, 0.11003D0, 0.10150D0, 0.09208D0, 0.08532D0, & 0.07497D0, 0.06641D0, 0.05872D0, 0.04993D0, 0.04200D0, & 0.03492D0, 0.02867D0, 0.02327D0, 0.01867D0, 0.01463D0, & 0.01149D0, 0.00885D0, 0.00675D0, 0.00511D0, 0.00375D0, & 0.00275D0, 0.00200D0, 0.00140D0, 0.00092D0, 0.00067D0, & 0.00045D0, 0.00028D0, 0.00020D0, 0.00007D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 2),I=1,49)/ & 0.46639D0, 0.41136D0, 0.36279D0, 0.33706D0, 0.31990D0, & 0.30719D0, 0.27073D0, 0.23840D0, 0.22115D0, 0.20956D0, & 0.20084D0, 0.17557D0, 0.15249D0, 0.13993D0, 0.13142D0, & 0.12504D0, 0.11578D0, 0.10635D0, 0.09591D0, 0.08845D0, & 0.07719D0, 0.06805D0, 0.05996D0, 0.05084D0, 0.04269D0, & 0.03544D0, 0.02909D0, 0.02361D0, 0.01895D0, 0.01488D0, & 0.01169D0, 0.00902D0, 0.00689D0, 0.00524D0, 0.00385D0, & 0.00283D0, 0.00206D0, 0.00146D0, 0.00096D0, 0.00071D0, & 0.00048D0, 0.00029D0, 0.00022D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 3),I=1,49)/ & 0.50684D0, 0.44821D0, 0.39632D0, 0.36876D0, 0.35036D0, & 0.33670D0, 0.29743D0, 0.26242D0, 0.24363D0, 0.23094D0, & 0.22132D0, 0.19327D0, 0.16725D0, 0.15293D0, 0.14314D0, & 0.13576D0, 0.12501D0, 0.11402D0, 0.10188D0, 0.09328D0, & 0.08055D0, 0.07049D0, 0.06177D0, 0.05212D0, 0.04362D0, & 0.03613D0, 0.02960D0, 0.02400D0, 0.01926D0, 0.01513D0, & 0.01189D0, 0.00918D0, 0.00704D0, 0.00535D0, 0.00395D0, & 0.00290D0, 0.00211D0, 0.00152D0, 0.00101D0, 0.00074D0, & 0.00051D0, 0.00031D0, 0.00023D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 4),I=1,49)/ & 0.55058D0, 0.48672D0, 0.43021D0, 0.40019D0, 0.38014D0, & 0.36526D0, 0.32246D0, 0.28426D0, 0.26371D0, 0.24981D0, & 0.23922D0, 0.20826D0, 0.17939D0, 0.16343D0, 0.15249D0, & 0.14425D0, 0.13221D0, 0.11993D0, 0.10640D0, 0.09689D0, & 0.08300D0, 0.07224D0, 0.06305D0, 0.05299D0, 0.04421D0, & 0.03653D0, 0.02989D0, 0.02420D0, 0.01939D0, 0.01523D0, & 0.01197D0, 0.00924D0, 0.00709D0, 0.00537D0, 0.00399D0, & 0.00293D0, 0.00213D0, 0.00154D0, 0.00102D0, 0.00074D0, & 0.00053D0, 0.00032D0, 0.00024D0, 0.00009D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 5),I=1,49)/ & 0.61607D0, 0.54291D0, 0.47835D0, 0.44415D0, 0.42133D0, & 0.40441D0, 0.35583D0, 0.31254D0, 0.28927D0, 0.27353D0, & 0.26150D0, 0.22639D0, 0.19363D0, 0.17555D0, 0.16316D0, & 0.15384D0, 0.14026D0, 0.12643D0, 0.11130D0, 0.10077D0, & 0.08558D0, 0.07403D0, 0.06431D0, 0.05381D0, 0.04474D0, & 0.03686D0, 0.03008D0, 0.02432D0, 0.01945D0, 0.01528D0, & 0.01199D0, 0.00925D0, 0.00709D0, 0.00537D0, 0.00398D0, & 0.00293D0, 0.00214D0, 0.00154D0, 0.00103D0, 0.00074D0, & 0.00052D0, 0.00032D0, 0.00024D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 6),I=1,49)/ & 0.68336D0, 0.60005D0, 0.52679D0, 0.48807D0, 0.46228D0, & 0.44318D0, 0.38846D0, 0.33984D0, 0.31375D0, 0.29611D0, & 0.28263D0, 0.24332D0, 0.20674D0, 0.18660D0, 0.17283D0, & 0.16249D0, 0.14745D0, 0.13219D0, 0.11560D0, 0.10414D0, & 0.08779D0, 0.07555D0, 0.06535D0, 0.05447D0, 0.04515D0, & 0.03709D0, 0.03021D0, 0.02439D0, 0.01946D0, 0.01528D0, & 0.01197D0, 0.00923D0, 0.00707D0, 0.00536D0, 0.00396D0, & 0.00291D0, 0.00213D0, 0.00154D0, 0.00103D0, 0.00073D0, & 0.00051D0, 0.00032D0, 0.00023D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 7),I=1,49)/ & 0.76355D0, 0.66723D0, 0.58292D0, 0.53852D0, 0.50902D0, & 0.48721D0, 0.42490D0, 0.36978D0, 0.34030D0, 0.32042D0, & 0.30522D0, 0.26107D0, 0.22021D0, 0.19782D0, 0.18257D0, & 0.17114D0, 0.15457D0, 0.13784D0, 0.11976D0, 0.10736D0, & 0.08987D0, 0.07693D0, 0.06629D0, 0.05503D0, 0.04547D0, & 0.03726D0, 0.03027D0, 0.02439D0, 0.01942D0, 0.01523D0, & 0.01190D0, 0.00918D0, 0.00701D0, 0.00533D0, 0.00392D0, & 0.00287D0, 0.00209D0, 0.00153D0, 0.00101D0, 0.00073D0, & 0.00050D0, 0.00032D0, 0.00022D0, 0.00007D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 8),I=1,49)/ & 0.86343D0, 0.75010D0, 0.65144D0, 0.59973D0, 0.56547D0, & 0.54018D0, 0.46822D0, 0.40492D0, 0.37123D0, 0.34856D0, & 0.33127D0, 0.28125D0, 0.23529D0, 0.21028D0, 0.19331D0, & 0.18063D0, 0.16233D0, 0.14394D0, 0.12420D0, 0.11077D0, & 0.09202D0, 0.07835D0, 0.06722D0, 0.05555D0, 0.04575D0, & 0.03737D0, 0.03028D0, 0.02434D0, 0.01934D0, 0.01514D0, & 0.01181D0, 0.00909D0, 0.00694D0, 0.00526D0, 0.00387D0, & 0.00282D0, 0.00206D0, 0.00150D0, 0.00100D0, 0.00072D0, & 0.00049D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I, 9),I=1,49)/ & 0.96361D0, 0.83251D0, 0.71897D0, 0.65971D0, 0.62055D0, & 0.59171D0, 0.50993D0, 0.43838D0, 0.40047D0, 0.37504D0, & 0.35567D0, 0.29991D0, 0.24906D0, 0.22156D0, 0.20298D0, & 0.18914D0, 0.16924D0, 0.14933D0, 0.12809D0, 0.11373D0, & 0.09387D0, 0.07954D0, 0.06798D0, 0.05596D0, 0.04595D0, & 0.03743D0, 0.03026D0, 0.02427D0, 0.01926D0, 0.01505D0, & 0.01172D0, 0.00900D0, 0.00687D0, 0.00519D0, 0.00383D0, & 0.00278D0, 0.00203D0, 0.00148D0, 0.00098D0, 0.00071D0, & 0.00048D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,10),I=1,49)/ & 1.07479D0, 0.92315D0, 0.79255D0, 0.72469D0, 0.67997D0, & 0.64711D0, 0.55427D0, 0.47353D0, 0.43097D0, 0.40251D0, & 0.38089D0, 0.31894D0, 0.26290D0, 0.23280D0, 0.21256D0, & 0.19753D0, 0.17599D0, 0.15455D0, 0.13181D0, 0.11654D0, & 0.09559D0, 0.08062D0, 0.06865D0, 0.05629D0, 0.04608D0, & 0.03743D0, 0.03019D0, 0.02416D0, 0.01913D0, 0.01493D0, & 0.01161D0, 0.00890D0, 0.00677D0, 0.00511D0, 0.00377D0, & 0.00274D0, 0.00200D0, 0.00145D0, 0.00096D0, 0.00068D0, & 0.00046D0, 0.00030D0, 0.00020D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,11),I=1,49)/ & 1.17232D0, 1.00213D0, 0.85623D0, 0.78069D0, 0.73104D0, & 0.69461D0, 0.59200D0, 0.50321D0, 0.45658D0, 0.42550D0, & 0.40194D0, 0.33467D0, 0.27424D0, 0.24195D0, 0.22032D0, & 0.20431D0, 0.18142D0, 0.15872D0, 0.13477D0, 0.11875D0, & 0.09692D0, 0.08144D0, 0.06915D0, 0.05653D0, 0.04615D0, & 0.03741D0, 0.03011D0, 0.02406D0, 0.01902D0, 0.01482D0, & 0.01152D0, 0.00881D0, 0.00669D0, 0.00505D0, 0.00371D0, & 0.00270D0, 0.00197D0, 0.00143D0, 0.00094D0, 0.00066D0, & 0.00045D0, 0.00029D0, 0.00020D0, 0.00008D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,12),I=1,49)/ & 1.41135D0, 1.19389D0, 1.00931D0, 0.91452D0, 0.85253D0, & 0.80723D0, 0.68048D0, 0.57199D0, 0.51554D0, 0.47813D0, & 0.44992D0, 0.37007D0, 0.29939D0, 0.26209D0, 0.23729D0, & 0.21905D0, 0.19312D0, 0.16764D0, 0.14100D0, 0.12337D0, & 0.09965D0, 0.08309D0, 0.07010D0, 0.05694D0, 0.04624D0, & 0.03729D0, 0.02989D0, 0.02378D0, 0.01873D0, 0.01456D0, & 0.01128D0, 0.00861D0, 0.00651D0, 0.00490D0, 0.00360D0, & 0.00260D0, 0.00189D0, 0.00137D0, 0.00090D0, 0.00062D0, & 0.00043D0, 0.00028D0, 0.00019D0, 0.00007D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,13),I=1,49)/ & 1.65256D0, 1.38522D0, 1.16028D0, 1.04559D0, 0.97092D0, & 0.91653D0, 0.76529D0, 0.63704D0, 0.57085D0, 0.52722D0, & 0.49446D0, 0.40243D0, 0.32201D0, 0.28002D0, 0.25230D0, & 0.23200D0, 0.20332D0, 0.17533D0, 0.14629D0, 0.12724D0, & 0.10187D0, 0.08438D0, 0.07080D0, 0.05719D0, 0.04622D0, & 0.03712D0, 0.02965D0, 0.02350D0, 0.01845D0, 0.01430D0, & 0.01104D0, 0.00841D0, 0.00634D0, 0.00476D0, 0.00349D0, & 0.00251D0, 0.00182D0, 0.00132D0, 0.00086D0, 0.00060D0, & 0.00042D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,14),I=1,49)/ & 1.96387D0, 1.62942D0, 1.35081D0, 1.20988D0, 1.11860D0, & 1.05236D0, 0.86939D0, 0.71589D0, 0.63738D0, 0.58593D0, & 0.54750D0, 0.44041D0, 0.34815D0, 0.30054D0, 0.26935D0, & 0.24663D0, 0.21473D0, 0.18383D0, 0.15206D0, 0.13140D0, & 0.10419D0, 0.08567D0, 0.07145D0, 0.05736D0, 0.04609D0, & 0.03684D0, 0.02930D0, 0.02313D0, 0.01809D0, 0.01398D0, & 0.01074D0, 0.00816D0, 0.00615D0, 0.00459D0, 0.00334D0, & 0.00240D0, 0.00174D0, 0.00125D0, 0.00082D0, 0.00057D0, & 0.00038D0, 0.00024D0, 0.00016D0, 0.00006D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,15),I=1,49)/ & 2.33902D0, 1.92024D0, 1.57497D0, 1.40179D0, 1.29021D0, & 1.20956D0, 0.98833D0, 0.80477D0, 0.71175D0, 0.65116D0, & 0.60614D0, 0.48174D0, 0.37612D0, 0.32226D0, 0.28724D0, & 0.26188D0, 0.22649D0, 0.19248D0, 0.15783D0, 0.13549D0, & 0.10637D0, 0.08680D0, 0.07195D0, 0.05738D0, 0.04585D0, & 0.03646D0, 0.02886D0, 0.02269D0, 0.01768D0, 0.01360D0, & 0.01043D0, 0.00789D0, 0.00592D0, 0.00441D0, 0.00321D0, & 0.00230D0, 0.00166D0, 0.00118D0, 0.00078D0, 0.00054D0, & 0.00037D0, 0.00022D0, 0.00015D0, 0.00006D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,16),I=1,49)/ & 2.72482D0, 2.21608D0, 1.80052D0, 1.59364D0, 1.46096D0, & 1.36541D0, 1.10490D0, 0.89086D0, 0.78327D0, 0.71357D0, & 0.66200D0, 0.52058D0, 0.40200D0, 0.34217D0, 0.30354D0, & 0.27569D0, 0.23704D0, 0.20015D0, 0.16285D0, 0.13900D0, & 0.10817D0, 0.08767D0, 0.07227D0, 0.05729D0, 0.04554D0, & 0.03606D0, 0.02842D0, 0.02227D0, 0.01728D0, 0.01326D0, & 0.01012D0, 0.00763D0, 0.00571D0, 0.00425D0, 0.00307D0, & 0.00219D0, 0.00158D0, 0.00112D0, 0.00073D0, 0.00051D0, & 0.00035D0, 0.00021D0, 0.00014D0, 0.00005D0, 0.00002D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,17),I=1,49)/ & 3.16184D0, 2.54784D0, 2.05090D0, 1.80533D0, 1.64858D0, & 1.53608D0, 1.23122D0, 0.98314D0, 0.85944D0, 0.77972D0, & 0.72099D0, 0.56109D0, 0.42865D0, 0.36249D0, 0.32006D0, & 0.28962D0, 0.24759D0, 0.20774D0, 0.16775D0, 0.14236D0, & 0.10984D0, 0.08843D0, 0.07249D0, 0.05712D0, 0.04518D0, & 0.03560D0, 0.02794D0, 0.02182D0, 0.01686D0, 0.01291D0, & 0.00980D0, 0.00737D0, 0.00550D0, 0.00408D0, 0.00294D0, & 0.00209D0, 0.00150D0, 0.00107D0, 0.00069D0, 0.00049D0, & 0.00034D0, 0.00019D0, 0.00014D0, 0.00005D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,18),I=1,49)/ & 3.56226D0, 2.84906D0, 2.27616D0, 1.99475D0, 1.81581D0, & 1.68774D0, 1.34241D0, 1.06358D0, 0.92544D0, 0.83679D0, & 0.77171D0, 0.59551D0, 0.45100D0, 0.37940D0, 0.33372D0, & 0.30107D0, 0.25620D0, 0.21386D0, 0.17164D0, 0.14499D0, & 0.11108D0, 0.08895D0, 0.07258D0, 0.05692D0, 0.04483D0, & 0.03518D0, 0.02753D0, 0.02142D0, 0.01651D0, 0.01260D0, & 0.00954D0, 0.00717D0, 0.00532D0, 0.00393D0, 0.00284D0, & 0.00201D0, 0.00144D0, 0.00103D0, 0.00066D0, 0.00045D0, & 0.00032D0, 0.00018D0, 0.00013D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,19),I=1,49)/ & 4.09416D0, 3.24567D0, 2.57011D0, 2.24065D0, 2.03209D0, & 1.88332D0, 1.48448D0, 1.16540D0, 1.00850D0, 0.90831D0, & 0.83504D0, 0.63803D0, 0.47827D0, 0.39987D0, 0.35015D0, & 0.31478D0, 0.26640D0, 0.22104D0, 0.17612D0, 0.14797D0, & 0.11241D0, 0.08943D0, 0.07259D0, 0.05659D0, 0.04434D0, & 0.03464D0, 0.02699D0, 0.02092D0, 0.01606D0, 0.01221D0, & 0.00922D0, 0.00691D0, 0.00511D0, 0.00375D0, 0.00271D0, & 0.00191D0, 0.00136D0, 0.00097D0, 0.00063D0, 0.00043D0, & 0.00030D0, 0.00017D0, 0.00012D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,20),I=1,49)/ & 4.61257D0, 3.62885D0, 2.85161D0, 2.47491D0, 2.23738D0, & 2.06842D0, 1.61774D0, 1.26001D0, 1.08527D0, 0.97415D0, & 0.89315D0, 0.67662D0, 0.50274D0, 0.41811D0, 0.36471D0, & 0.32688D0, 0.27534D0, 0.22728D0, 0.17996D0, 0.15048D0, & 0.11349D0, 0.08979D0, 0.07253D0, 0.05626D0, 0.04389D0, & 0.03414D0, 0.02651D0, 0.02047D0, 0.01566D0, 0.01187D0, & 0.00894D0, 0.00668D0, 0.00493D0, 0.00361D0, 0.00261D0, & 0.00182D0, 0.00129D0, 0.00093D0, 0.00059D0, 0.00040D0, & 0.00028D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,21),I=1,49)/ & 5.12222D0, 4.00261D0, 3.12404D0, 2.70057D0, 2.43446D0, & 2.24566D0, 1.74429D0, 1.34911D0, 1.15718D0, 1.03559D0, & 0.94721D0, 0.71215D0, 0.52500D0, 0.43455D0, 0.37776D0, & 0.33766D0, 0.28323D0, 0.23271D0, 0.18324D0, 0.15257D0, & 0.11432D0, 0.08998D0, 0.07237D0, 0.05588D0, 0.04342D0, & 0.03365D0, 0.02604D0, 0.02004D0, 0.01529D0, 0.01156D0, & 0.00869D0, 0.00646D0, 0.00477D0, 0.00348D0, 0.00251D0, & 0.00175D0, 0.00124D0, 0.00088D0, 0.00057D0, 0.00038D0, & 0.00026D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,22),I=1,49)/ & 5.82554D0, 4.51423D0, 3.49391D0, 3.00548D0, 2.69986D0, & 2.48370D0, 1.91285D0, 1.46678D0, 1.25167D0, 1.11601D0, & 1.01775D0, 0.75806D0, 0.55345D0, 0.45543D0, 0.39424D0, & 0.35121D0, 0.29307D0, 0.23942D0, 0.18722D0, 0.15507D0, & 0.11526D0, 0.09014D0, 0.07211D0, 0.05536D0, 0.04279D0, & 0.03301D0, 0.02543D0, 0.01950D0, 0.01483D0, 0.01117D0, & 0.00837D0, 0.00620D0, 0.00456D0, 0.00332D0, 0.00238D0, & 0.00166D0, 0.00117D0, 0.00083D0, 0.00053D0, 0.00035D0, & 0.00024D0, 0.00015D0, 0.00010D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,23),I=1,49)/ & 6.54676D0, 5.03439D0, 3.86673D0, 3.31126D0, 2.96506D0, & 2.72090D0, 2.07933D0, 1.58195D0, 1.34364D0, 1.19398D0, & 1.08591D0, 0.80195D0, 0.58033D0, 0.47501D0, 0.40960D0, & 0.36377D0, 0.30212D0, 0.24551D0, 0.19078D0, 0.15726D0, & 0.11602D0, 0.09021D0, 0.07181D0, 0.05483D0, 0.04218D0, & 0.03240D0, 0.02486D0, 0.01900D0, 0.01440D0, 0.01081D0, & 0.00808D0, 0.00597D0, 0.00437D0, 0.00317D0, 0.00227D0, & 0.00157D0, 0.00111D0, 0.00080D0, 0.00050D0, 0.00034D0, & 0.00022D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,24),I=1,49)/ & 7.26565D0, 5.54876D0, 4.23247D0, 3.60982D0, 3.22311D0, & 2.95109D0, 2.23956D0, 1.69183D0, 1.43093D0, 1.26769D0, & 1.15015D0, 0.84286D0, 0.60508D0, 0.49288D0, 0.42351D0, & 0.37509D0, 0.31017D0, 0.25086D0, 0.19381D0, 0.15905D0, & 0.11655D0, 0.09013D0, 0.07142D0, 0.05426D0, 0.04157D0, & 0.03180D0, 0.02431D0, 0.01852D0, 0.01399D0, 0.01048D0, & 0.00780D0, 0.00574D0, 0.00419D0, 0.00304D0, 0.00217D0, & 0.00149D0, 0.00106D0, 0.00075D0, 0.00048D0, 0.00032D0, & 0.00021D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,25),I=1,49)/ & 8.04192D0, 6.10017D0, 4.62168D0, 3.92618D0, 3.49572D0, & 3.19370D0, 2.40717D0, 1.80591D0, 1.52114D0, 1.34361D0, & 1.21613D0, 0.88453D0, 0.63003D0, 0.51078D0, 0.43739D0, & 0.38633D0, 0.31813D0, 0.25609D0, 0.19674D0, 0.16076D0, & 0.11701D0, 0.09001D0, 0.07101D0, 0.05368D0, 0.04095D0, & 0.03121D0, 0.02377D0, 0.01805D0, 0.01359D0, 0.01015D0, & 0.00753D0, 0.00553D0, 0.00402D0, 0.00291D0, 0.00207D0, & 0.00142D0, 0.00101D0, 0.00071D0, 0.00045D0, 0.00030D0, & 0.00020D0, 0.00012D0, 0.00008D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,26),I=1,49)/ & 8.84513D0, 6.66663D0, 5.01863D0, 4.24745D0, 3.77171D0, & 3.43873D0, 2.57518D0, 1.91937D0, 1.61043D0, 1.41849D0, & 1.28102D0, 0.92509D0, 0.65405D0, 0.52788D0, 0.45056D0, & 0.39694D0, 0.32555D0, 0.26091D0, 0.19936D0, 0.16223D0, & 0.11732D0, 0.08979D0, 0.07053D0, 0.05307D0, 0.04031D0, & 0.03061D0, 0.02325D0, 0.01759D0, 0.01321D0, 0.00982D0, & 0.00728D0, 0.00532D0, 0.00387D0, 0.00279D0, 0.00197D0, & 0.00136D0, 0.00096D0, 0.00067D0, 0.00043D0, 0.00029D0, & 0.00019D0, 0.00011D0, 0.00007D0, 0.00003D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,27),I=1,49)/ & 9.65435D0, 7.23356D0, 5.41328D0, 4.56560D0, 4.04426D0, & 3.68017D0, 2.73960D0, 2.02962D0, 1.69683D0, 1.49072D0, & 1.34344D0, 0.96379D0, 0.67674D0, 0.54393D0, 0.46286D0, & 0.40680D0, 0.33241D0, 0.26531D0, 0.20171D0, 0.16351D0, & 0.11755D0, 0.08953D0, 0.07005D0, 0.05247D0, 0.03970D0, & 0.03004D0, 0.02275D0, 0.01715D0, 0.01284D0, 0.00953D0, & 0.00704D0, 0.00513D0, 0.00373D0, 0.00268D0, 0.00189D0, & 0.00130D0, 0.00092D0, 0.00064D0, 0.00040D0, 0.00027D0, & 0.00018D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,28),I=1,49)/ & 10.45602D0, 7.79175D0, 5.79941D0, 4.87575D0, 4.30926D0, & 3.91444D0, 2.89810D0, 2.13519D0, 1.77921D0, 1.55938D0, & 1.40263D0, 1.00018D0, 0.69787D0, 0.55877D0, 0.47417D0, & 0.41582D0, 0.33862D0, 0.26925D0, 0.20376D0, 0.16459D0, & 0.11767D0, 0.08923D0, 0.06955D0, 0.05189D0, 0.03911D0, & 0.02950D0, 0.02227D0, 0.01675D0, 0.01249D0, 0.00926D0, & 0.00681D0, 0.00496D0, 0.00359D0, 0.00258D0, 0.00181D0, & 0.00125D0, 0.00088D0, 0.00062D0, 0.00038D0, 0.00026D0, & 0.00017D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,29),I=1,49)/ & 11.30416D0, 8.37884D0, 6.20316D0, 5.19892D0, 4.58469D0, & 4.15747D0, 3.06152D0, 2.24335D0, 1.86330D0, 1.62927D0, & 1.46273D0, 1.03685D0, 0.71898D0, 0.57351D0, 0.48535D0, & 0.42471D0, 0.34469D0, 0.27305D0, 0.20570D0, 0.16558D0, & 0.11773D0, 0.08889D0, 0.06902D0, 0.05129D0, 0.03852D0, & 0.02896D0, 0.02179D0, 0.01634D0, 0.01216D0, 0.00899D0, & 0.00659D0, 0.00479D0, 0.00347D0, 0.00248D0, 0.00174D0, & 0.00119D0, 0.00084D0, 0.00059D0, 0.00036D0, 0.00024D0, & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,30),I=1,49)/ & 12.17534D0, 8.97841D0, 6.61310D0, 5.52592D0, 4.86271D0, & 4.40230D0, 3.22516D0, 2.35097D0, 1.94663D0, 1.69833D0, & 1.52199D0, 1.07270D0, 0.73942D0, 0.58770D0, 0.49605D0, & 0.43317D0, 0.35042D0, 0.27659D0, 0.20745D0, 0.16642D0, & 0.11771D0, 0.08850D0, 0.06847D0, 0.05068D0, 0.03793D0, & 0.02842D0, 0.02132D0, 0.01595D0, 0.01184D0, 0.00872D0, & 0.00639D0, 0.00464D0, 0.00334D0, 0.00238D0, 0.00167D0, & 0.00115D0, 0.00081D0, 0.00056D0, 0.00034D0, 0.00023D0, & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,31),I=1,49)/ & 13.04562D0, 9.57419D0, 7.01826D0, 5.84808D0, 5.13599D0, & 4.64254D0, 3.38483D0, 2.45538D0, 2.02720D0, 1.76492D0, & 1.57901D0, 1.10697D0, 0.75881D0, 0.60107D0, 0.50610D0, & 0.44109D0, 0.35574D0, 0.27985D0, 0.20903D0, 0.16716D0, & 0.11764D0, 0.08810D0, 0.06793D0, 0.05010D0, 0.03737D0, & 0.02791D0, 0.02089D0, 0.01558D0, 0.01154D0, 0.00848D0, & 0.00620D0, 0.00450D0, 0.00323D0, 0.00230D0, 0.00160D0, & 0.00110D0, 0.00077D0, 0.00053D0, 0.00032D0, 0.00022D0, & 0.00015D0, 0.00008D0, 0.00006D0, 0.00002D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,32),I=1,49)/ & 13.89443D0, 10.15226D0, 7.40931D0, 6.15805D0, 5.39834D0, & 4.87276D0, 3.53699D0, 2.55429D0, 2.10325D0, 1.82761D0, & 1.63256D0, 1.13890D0, 0.77669D0, 0.61332D0, 0.51524D0, & 0.44825D0, 0.36050D0, 0.28271D0, 0.21036D0, 0.16773D0, & 0.11750D0, 0.08767D0, 0.06738D0, 0.04952D0, 0.03683D0, & 0.02743D0, 0.02048D0, 0.01524D0, 0.01125D0, 0.00826D0, & 0.00603D0, 0.00436D0, 0.00312D0, 0.00222D0, 0.00155D0, & 0.00106D0, 0.00074D0, 0.00051D0, 0.00031D0, 0.00021D0, & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,33),I=1,49)/ & 14.79866D0, 10.76526D0, 7.82209D0, 6.48437D0, 5.67399D0, & 5.11430D0, 3.69589D0, 2.65710D0, 2.18207D0, 1.89245D0, & 1.68785D0, 1.17170D0, 0.79496D0, 0.62581D0, 0.52453D0, & 0.45551D0, 0.36532D0, 0.28560D0, 0.21171D0, 0.16831D0, & 0.11736D0, 0.08724D0, 0.06684D0, 0.04896D0, 0.03630D0, & 0.02696D0, 0.02007D0, 0.01490D0, 0.01098D0, 0.00805D0, & 0.00586D0, 0.00423D0, 0.00302D0, 0.00214D0, 0.00150D0, & 0.00102D0, 0.00071D0, 0.00049D0, 0.00030D0, 0.00020D0, & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,34),I=1,49)/ & 15.70368D0, 11.37564D0, 8.23095D0, 6.80656D0, 5.94554D0, & 5.35181D0, 3.85123D0, 2.75698D0, 2.25835D0, 1.95501D0, & 1.74107D0, 1.20298D0, 0.81219D0, 0.63747D0, 0.53315D0, & 0.46219D0, 0.36968D0, 0.28814D0, 0.21281D0, 0.16870D0, & 0.11711D0, 0.08674D0, 0.06626D0, 0.04836D0, 0.03575D0, & 0.02649D0, 0.01967D0, 0.01456D0, 0.01071D0, 0.00784D0, & 0.00568D0, 0.00409D0, 0.00292D0, 0.00207D0, 0.00144D0, & 0.00098D0, 0.00068D0, 0.00047D0, 0.00029D0, 0.00019D0, & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,35),I=1,49)/ & 16.61098D0, 11.98498D0, 8.63737D0, 7.12604D0, 6.21432D0, & 5.58657D0, 4.00413D0, 2.85486D0, 2.33290D0, 2.01603D0, & 1.79291D0, 1.23331D0, 0.82880D0, 0.64868D0, 0.54141D0, & 0.46858D0, 0.37384D0, 0.29056D0, 0.21385D0, 0.16907D0, & 0.11687D0, 0.08628D0, 0.06571D0, 0.04780D0, 0.03525D0, & 0.02604D0, 0.01929D0, 0.01425D0, 0.01046D0, 0.00764D0, & 0.00552D0, 0.00397D0, 0.00283D0, 0.00200D0, 0.00139D0, & 0.00095D0, 0.00066D0, 0.00045D0, 0.00028D0, 0.00019D0, & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,36),I=1,49)/ & 17.49641D0, 12.57703D0, 9.03053D0, 7.43428D0, 6.47316D0, & 5.81232D0, 4.15045D0, 2.94807D0, 2.40367D0, 2.07383D0, & 1.84191D0, 1.26179D0, 0.84428D0, 0.65906D0, 0.54902D0, & 0.47444D0, 0.37762D0, 0.29271D0, 0.21474D0, 0.16935D0, & 0.11660D0, 0.08580D0, 0.06517D0, 0.04726D0, 0.03476D0, & 0.02562D0, 0.01894D0, 0.01396D0, 0.01022D0, 0.00745D0, & 0.00538D0, 0.00386D0, 0.00274D0, 0.00194D0, 0.00135D0, & 0.00092D0, 0.00063D0, 0.00044D0, 0.00027D0, 0.00018D0, & 0.00011D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,37),I=1,49)/ & 18.41415D0, 13.18812D0, 9.43458D0, 7.75025D0, 6.73800D0, & 6.04297D0, 4.29926D0, 3.04240D0, 2.47507D0, 2.13202D0, & 1.89114D0, 1.29020D0, 0.85959D0, 0.66927D0, 0.55646D0, & 0.48015D0, 0.38126D0, 0.29476D0, 0.21554D0, 0.16955D0, & 0.11628D0, 0.08530D0, 0.06461D0, 0.04672D0, 0.03427D0, & 0.02520D0, 0.01858D0, 0.01367D0, 0.00999D0, 0.00727D0, & 0.00525D0, 0.00375D0, 0.00266D0, 0.00188D0, 0.00131D0, & 0.00088D0, 0.00061D0, 0.00042D0, 0.00026D0, 0.00017D0, & 0.00011D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,6,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 1),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 2),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 3),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 4),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 5),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 6),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 7),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 8),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I, 9),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,10),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,11),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,12),I=1,49)/ & 0.00042D0, 0.00036D0, 0.00032D0, 0.00030D0, 0.00028D0, & 0.00027D0, 0.00023D0, 0.00020D0, 0.00019D0, 0.00018D0, & 0.00017D0, 0.00014D0, 0.00012D0, 0.00011D0, 0.00010D0, & 0.00009D0, 0.00008D0, 0.00007D0, 0.00006D0, 0.00005D0, & 0.00005D0, 0.00004D0, 0.00003D0, 0.00003D0, 0.00003D0, & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00001D0, & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,13),I=1,49)/ & 0.21520D0, 0.16773D0, 0.13065D0, 0.11283D0, 0.10165D0, & 0.09372D0, 0.07266D0, 0.05600D0, 0.04786D0, 0.04266D0, & 0.03883D0, 0.02862D0, 0.02044D0, 0.01649D0, 0.01402D0, & 0.01228D0, 0.00994D0, 0.00781D0, 0.00579D0, 0.00460D0, & 0.00322D0, 0.00243D0, 0.00191D0, 0.00146D0, 0.00114D0, & 0.00089D0, 0.00070D0, 0.00055D0, 0.00043D0, 0.00034D0, & 0.00026D0, 0.00020D0, 0.00015D0, 0.00011D0, 0.00009D0, & 0.00006D0, 0.00005D0, 0.00003D0, 0.00002D0, 0.00001D0, & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,14),I=1,49)/ & 0.62424D0, 0.48455D0, 0.37589D0, 0.32385D0, 0.29126D0, & 0.26818D0, 0.20706D0, 0.15892D0, 0.13546D0, 0.12053D0, & 0.10954D0, 0.08034D0, 0.05707D0, 0.04589D0, 0.03892D0, & 0.03403D0, 0.02747D0, 0.02151D0, 0.01589D0, 0.01258D0, & 0.00876D0, 0.00658D0, 0.00515D0, 0.00391D0, 0.00303D0, & 0.00236D0, 0.00185D0, 0.00144D0, 0.00112D0, 0.00088D0, & 0.00067D0, 0.00051D0, 0.00039D0, 0.00029D0, 0.00022D0, & 0.00016D0, 0.00011D0, 0.00008D0, 0.00006D0, 0.00004D0, & 0.00002D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,15),I=1,49)/ & 1.00765D0, 0.77678D0, 0.59844D0, 0.51350D0, 0.46049D0, & 0.42306D0, 0.32436D0, 0.24719D0, 0.20981D0, 0.18611D0, & 0.16874D0, 0.12279D0, 0.08652D0, 0.06923D0, 0.05850D0, & 0.05102D0, 0.04100D0, 0.03196D0, 0.02347D0, 0.01849D0, & 0.01279D0, 0.00955D0, 0.00743D0, 0.00560D0, 0.00430D0, & 0.00334D0, 0.00260D0, 0.00202D0, 0.00157D0, 0.00121D0, & 0.00093D0, 0.00071D0, 0.00053D0, 0.00040D0, 0.00029D0, & 0.00021D0, 0.00015D0, 0.00011D0, 0.00007D0, 0.00005D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,16),I=1,49)/ & 1.42250D0, 1.08981D0, 0.83442D0, 0.71339D0, 0.63810D0, & 0.58505D0, 0.44575D0, 0.33755D0, 0.28542D0, 0.25249D0, & 0.22841D0, 0.16506D0, 0.11545D0, 0.09197D0, 0.07747D0, & 0.06738D0, 0.05394D0, 0.04186D0, 0.03057D0, 0.02399D0, & 0.01648D0, 0.01223D0, 0.00946D0, 0.00708D0, 0.00541D0, & 0.00417D0, 0.00323D0, 0.00250D0, 0.00193D0, 0.00149D0, & 0.00113D0, 0.00086D0, 0.00064D0, 0.00048D0, 0.00035D0, & 0.00026D0, 0.00018D0, 0.00013D0, 0.00009D0, 0.00005D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,17),I=1,49)/ & 1.90329D0, 1.44918D0, 1.10274D0, 0.93938D0, 0.83807D0, & 0.76686D0, 0.58064D0, 0.43692D0, 0.36805D0, 0.32470D0, & 0.29309D0, 0.21032D0, 0.14604D0, 0.11582D0, 0.09725D0, & 0.08437D0, 0.06728D0, 0.05198D0, 0.03776D0, 0.02950D0, & 0.02012D0, 0.01485D0, 0.01142D0, 0.00850D0, 0.00645D0, & 0.00494D0, 0.00381D0, 0.00293D0, 0.00225D0, 0.00172D0, & 0.00131D0, 0.00098D0, 0.00073D0, 0.00054D0, 0.00040D0, & 0.00029D0, 0.00021D0, 0.00014D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,18),I=1,49)/ & 2.33137D0, 1.76616D0, 1.33713D0, 1.13567D0, 1.01106D0, & 0.92363D0, 0.69576D0, 0.52083D0, 0.43738D0, 0.38501D0, & 0.34690D0, 0.24753D0, 0.17085D0, 0.13502D0, 0.11307D0, & 0.09789D0, 0.07781D0, 0.05991D0, 0.04333D0, 0.03374D0, & 0.02288D0, 0.01680D0, 0.01286D0, 0.00952D0, 0.00719D0, & 0.00549D0, 0.00420D0, 0.00322D0, 0.00246D0, 0.00188D0, & 0.00142D0, 0.00107D0, 0.00079D0, 0.00059D0, 0.00043D0, & 0.00031D0, 0.00022D0, 0.00015D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,19),I=1,49)/ & 2.89798D0, 2.18213D0, 1.64207D0, 1.38971D0, 1.23410D0, & 1.12518D0, 0.84241D0, 0.62670D0, 0.52435D0, 0.46034D0, & 0.41389D0, 0.29333D0, 0.20103D0, 0.15819D0, 0.13206D0, & 0.11405D0, 0.09031D0, 0.06924D0, 0.04982D0, 0.03863D0, & 0.02602D0, 0.01899D0, 0.01446D0, 0.01064D0, 0.00798D0, & 0.00606D0, 0.00462D0, 0.00352D0, 0.00268D0, 0.00204D0, & 0.00153D0, 0.00115D0, 0.00085D0, 0.00062D0, 0.00046D0, & 0.00034D0, 0.00024D0, 0.00016D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,20),I=1,49)/ & 3.45978D0, 2.59142D0, 1.93977D0, 1.63658D0, 1.45012D0, & 1.31987D0, 0.98290D0, 0.72728D0, 0.60655D0, 0.53126D0, & 0.47676D0, 0.33590D0, 0.22879D0, 0.17936D0, 0.14933D0, & 0.12869D0, 0.10156D0, 0.07757D0, 0.05556D0, 0.04293D0, & 0.02875D0, 0.02087D0, 0.01582D0, 0.01157D0, 0.00864D0, & 0.00653D0, 0.00495D0, 0.00376D0, 0.00285D0, 0.00216D0, & 0.00162D0, 0.00120D0, 0.00089D0, 0.00065D0, 0.00048D0, & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,21),I=1,49)/ & 3.99390D0, 2.97724D0, 2.21795D0, 1.86604D0, 1.65015D0, & 1.49961D0, 1.11138D0, 0.81834D0, 0.68051D0, 0.59480D0, & 0.53289D0, 0.37345D0, 0.25296D0, 0.19764D0, 0.16415D0, & 0.14119D0, 0.11109D0, 0.08457D0, 0.06032D0, 0.04645D0, & 0.03094D0, 0.02236D0, 0.01688D0, 0.01228D0, 0.00913D0, & 0.00687D0, 0.00519D0, 0.00392D0, 0.00296D0, 0.00223D0, & 0.00167D0, 0.00124D0, 0.00091D0, 0.00067D0, 0.00049D0, & 0.00036D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,22),I=1,49)/ & 4.74104D0, 3.51318D0, 2.60162D0, 2.18119D0, 1.92405D0, & 1.74515D0, 1.28558D0, 0.94085D0, 0.77956D0, 0.67959D0, & 0.60758D0, 0.42298D0, 0.28453D0, 0.22138D0, 0.18331D0, & 0.15728D0, 0.12329D0, 0.09346D0, 0.06632D0, 0.05087D0, & 0.03366D0, 0.02418D0, 0.01815D0, 0.01313D0, 0.00971D0, & 0.00726D0, 0.00546D0, 0.00411D0, 0.00309D0, 0.00232D0, & 0.00172D0, 0.00128D0, 0.00094D0, 0.00068D0, 0.00049D0, & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,23),I=1,49)/ & 5.50879D0, 4.05964D0, 2.98973D0, 2.49849D0, 2.19888D0, & 1.99086D0, 1.45844D0, 1.06135D0, 0.87646D0, 0.76222D0, & 0.68014D0, 0.47060D0, 0.31455D0, 0.24380D0, 0.20130D0, & 0.17233D0, 0.13462D0, 0.10166D0, 0.07179D0, 0.05486D0, & 0.03607D0, 0.02577D0, 0.01926D0, 0.01386D0, 0.01019D0, & 0.00758D0, 0.00568D0, 0.00425D0, 0.00318D0, 0.00238D0, & 0.00176D0, 0.00130D0, 0.00095D0, 0.00069D0, 0.00050D0, & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,24),I=1,49)/ & 6.25919D0, 4.58931D0, 3.36270D0, 2.80183D0, 2.46064D0, & 2.22421D0, 1.62105D0, 1.17360D0, 0.96617D0, 0.83838D0, & 0.74677D0, 0.51381D0, 0.34143D0, 0.26369D0, 0.21716D0, & 0.18553D0, 0.14447D0, 0.10870D0, 0.07643D0, 0.05820D0, & 0.03805D0, 0.02705D0, 0.02012D0, 0.01441D0, 0.01054D0, & 0.00781D0, 0.00582D0, 0.00434D0, 0.00324D0, 0.00241D0, & 0.00178D0, 0.00131D0, 0.00095D0, 0.00069D0, 0.00050D0, & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,25),I=1,49)/ & 7.07966D0, 5.16501D0, 3.76564D0, 3.12838D0, 2.74171D0, & 2.47426D0, 1.79422D0, 1.29235D0, 1.06071D0, 0.91840D0, & 0.81663D0, 0.55877D0, 0.36917D0, 0.28412D0, 0.23339D0, & 0.19900D0, 0.15447D0, 0.11582D0, 0.08108D0, 0.06153D0, & 0.03999D0, 0.02830D0, 0.02096D0, 0.01493D0, 0.01087D0, & 0.00803D0, 0.00595D0, 0.00442D0, 0.00329D0, 0.00244D0, & 0.00180D0, 0.00131D0, 0.00096D0, 0.00069D0, 0.00050D0, & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,26),I=1,49)/ & 7.91829D0, 5.74916D0, 4.17141D0, 3.45573D0, 3.02255D0, & 2.72346D0, 1.96537D0, 1.40870D0, 1.15285D0, 0.99608D0, & 0.88421D0, 0.60182D0, 0.39541D0, 0.30330D0, 0.24854D0, & 0.21150D0, 0.16368D0, 0.12231D0, 0.08527D0, 0.06448D0, & 0.04169D0, 0.02937D0, 0.02165D0, 0.01535D0, 0.01113D0, & 0.00818D0, 0.00604D0, 0.00447D0, 0.00331D0, 0.00245D0, & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00049D0, & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,27),I=1,49)/ & 8.76657D0, 6.33661D0, 4.57707D0, 3.78184D0, 3.30161D0, & 2.97059D0, 2.13403D0, 1.52261D0, 1.24269D0, 1.07161D0, & 0.94977D0, 0.64324D0, 0.42046D0, 0.32150D0, 0.26285D0, & 0.22328D0, 0.17230D0, 0.12835D0, 0.08912D0, 0.06719D0, & 0.04322D0, 0.03031D0, 0.02226D0, 0.01571D0, 0.01134D0, & 0.00830D0, 0.00611D0, 0.00451D0, 0.00333D0, 0.00245D0, & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00048D0, & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,28),I=1,49)/ & 9.60252D0, 6.91204D0, 4.97199D0, 4.09813D0, 3.57154D0, & 3.20914D0, 2.29574D0, 1.63105D0, 1.32784D0, 1.14296D0, & 1.01154D0, 0.68194D0, 0.44362D0, 0.33823D0, 0.27595D0, & 0.23401D0, 0.18011D0, 0.13377D0, 0.09255D0, 0.06957D0, & 0.04454D0, 0.03111D0, 0.02277D0, 0.01600D0, 0.01150D0, & 0.00839D0, 0.00616D0, 0.00453D0, 0.00333D0, 0.00245D0, & 0.00179D0, 0.00130D0, 0.00094D0, 0.00067D0, 0.00048D0, & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,29),I=1,49)/ & 10.48807D0, 7.51842D0, 5.38590D0, 4.42859D0, 3.85291D0, & 3.45734D0, 2.46302D0, 1.74255D0, 1.41507D0, 1.21586D0, & 1.07451D0, 0.72111D0, 0.46688D0, 0.35494D0, 0.28897D0, & 0.24464D0, 0.18781D0, 0.13908D0, 0.09587D0, 0.07187D0, & 0.04579D0, 0.03185D0, 0.02323D0, 0.01626D0, 0.01165D0, & 0.00847D0, 0.00619D0, 0.00454D0, 0.00333D0, 0.00244D0, & 0.00178D0, 0.00129D0, 0.00093D0, 0.00066D0, 0.00047D0, & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,30),I=1,49)/ & 11.39334D0, 8.13482D0, 5.80422D0, 4.76138D0, 4.13555D0, & 3.70617D0, 2.62967D0, 1.85288D0, 1.50103D0, 1.28747D0, & 1.13621D0, 0.75917D0, 0.48927D0, 0.37093D0, 0.30137D0, & 0.25473D0, 0.19506D0, 0.14404D0, 0.09894D0, 0.07396D0, & 0.04691D0, 0.03251D0, 0.02363D0, 0.01647D0, 0.01175D0, & 0.00851D0, 0.00621D0, 0.00454D0, 0.00332D0, 0.00243D0, & 0.00176D0, 0.00127D0, 0.00091D0, 0.00065D0, 0.00046D0, & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,31),I=1,49)/ & 12.30020D0, 8.74942D0, 6.21933D0, 5.09070D0, 4.41468D0, & 3.95152D0, 2.79315D0, 1.96055D0, 1.58465D0, 1.35697D0, & 1.19598D0, 0.79580D0, 0.51068D0, 0.38615D0, 0.31314D0, & 0.26427D0, 0.20189D0, 0.14868D0, 0.10179D0, 0.07589D0, & 0.04793D0, 0.03309D0, 0.02397D0, 0.01665D0, 0.01184D0, & 0.00855D0, 0.00621D0, 0.00453D0, 0.00330D0, 0.00241D0, & 0.00174D0, 0.00126D0, 0.00090D0, 0.00064D0, 0.00046D0, & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,32),I=1,49)/ & 13.17835D0, 9.34137D0, 6.61692D0, 5.40505D0, 4.68045D0, & 4.18467D0, 2.94753D0, 2.06155D0, 1.66276D0, 1.42169D0, & 1.25150D0, 0.82954D0, 0.53019D0, 0.39993D0, 0.32374D0, & 0.27283D0, 0.20796D0, 0.15278D0, 0.10427D0, 0.07755D0, & 0.04878D0, 0.03356D0, 0.02424D0, 0.01677D0, 0.01189D0, & 0.00856D0, 0.00621D0, 0.00451D0, 0.00328D0, 0.00239D0, & 0.00173D0, 0.00124D0, 0.00089D0, 0.00063D0, 0.00045D0, & 0.00033D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,33),I=1,49)/ & 14.12059D0, 9.97430D0, 7.04054D0, 5.73929D0, 4.96264D0, & 4.43195D0, 3.11069D0, 2.16791D0, 1.74484D0, 1.48959D0, & 1.30967D0, 0.86476D0, 0.55049D0, 0.41422D0, 0.33471D0, & 0.28168D0, 0.21423D0, 0.15699D0, 0.10682D0, 0.07925D0, & 0.04965D0, 0.03404D0, 0.02451D0, 0.01690D0, 0.01194D0, & 0.00857D0, 0.00620D0, 0.00449D0, 0.00326D0, 0.00237D0, & 0.00171D0, 0.00123D0, 0.00088D0, 0.00062D0, 0.00044D0, & 0.00032D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,34),I=1,49)/ & 15.05309D0, 10.59701D0, 7.45476D0, 6.06488D0, 5.23678D0, & 4.67164D0, 3.26773D0, 2.26948D0, 1.82284D0, 1.55389D0, & 1.36460D0, 0.89767D0, 0.56921D0, 0.42730D0, 0.34468D0, & 0.28967D0, 0.21983D0, 0.16070D0, 0.10902D0, 0.08069D0, & 0.05036D0, 0.03441D0, 0.02470D0, 0.01698D0, 0.01196D0, & 0.00856D0, 0.00617D0, 0.00446D0, 0.00323D0, 0.00234D0, & 0.00168D0, 0.00121D0, 0.00086D0, 0.00061D0, 0.00043D0, & 0.00032D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,35),I=1,49)/ & 15.99294D0, 11.22254D0, 7.86947D0, 6.39022D0, 5.51032D0, & 4.91055D0, 3.42373D0, 2.37005D0, 1.89992D0, 1.61733D0, & 1.41872D0, 0.92998D0, 0.58753D0, 0.44006D0, 0.35440D0, & 0.29744D0, 0.22527D0, 0.16430D0, 0.11114D0, 0.08207D0, & 0.05103D0, 0.03476D0, 0.02489D0, 0.01705D0, 0.01198D0, & 0.00855D0, 0.00615D0, 0.00444D0, 0.00321D0, 0.00232D0, & 0.00166D0, 0.00119D0, 0.00085D0, 0.00060D0, 0.00042D0, & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,36),I=1,49)/ & 16.90825D0, 11.82917D0, 8.26989D0, 6.70353D0, 5.77324D0, & 5.13985D0, 3.57272D0, 2.46560D0, 1.97292D0, 1.67727D0, & 1.46976D0, 0.96025D0, 0.60456D0, 0.45187D0, 0.36334D0, & 0.30458D0, 0.23023D0, 0.16756D0, 0.11304D0, 0.08330D0, & 0.05162D0, 0.03506D0, 0.02503D0, 0.01710D0, 0.01198D0, & 0.00853D0, 0.00612D0, 0.00440D0, 0.00318D0, 0.00229D0, & 0.00164D0, 0.00117D0, 0.00083D0, 0.00059D0, 0.00042D0, & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,37),I=1,49)/ & 17.85379D0, 12.45318D0, 8.67996D0, 7.02354D0, 6.04126D0, & 5.37323D0, 3.72362D0, 2.56187D0, 2.04622D0, 1.73730D0, & 1.52078D0, 0.99029D0, 0.62133D0, 0.46343D0, 0.37206D0, & 0.31151D0, 0.23502D0, 0.17068D0, 0.11483D0, 0.08444D0, & 0.05214D0, 0.03531D0, 0.02515D0, 0.01713D0, 0.01196D0, & 0.00850D0, 0.00608D0, 0.00437D0, 0.00315D0, 0.00226D0, & 0.00162D0, 0.00115D0, 0.00082D0, 0.00058D0, 0.00041D0, & 0.00030D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0, & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,7,I,38),I=1,49)/ & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,8,I, 1),I=1,49)/ & 0.88043D0, 0.77333D0, 0.67888D0, 0.62888D0, 0.59555D0, & 0.57086D0, 0.50019D0, 0.43775D0, 0.40464D0, 0.38254D0, & 0.36610D0, 0.31885D0, 0.27689D0, 0.25464D0, 0.23989D0, & 0.22903D0, 0.21364D0, 0.19859D0, 0.18303D0, 0.17273D0, & 0.15826D0, 0.14656D0, 0.13527D0, 0.12062D0, 0.10522D0, & 0.08955D0, 0.07420D0, 0.05981D0, 0.04692D0, 0.03554D0, & 0.02630D0, 0.01878D0, 0.01298D0, 0.00870D0, 0.00554D0, & 0.00339D0, 0.00198D0, 0.00110D0, 0.00049D0, 0.00026D0, & 0.00012D0, 0.00002D0, 0.00002D0, 0.00000D0, -0.00001D0, & -0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/ DATA (FMRS(1,8,I, 2),I=1,49)/ & 0.89442D0, 0.78714D0, 0.69235D0, 0.64208D0, 0.60853D0, & 0.58367D0, 0.51236D0, 0.44919D0, 0.41561D0, 0.39314D0, & 0.37639D0, 0.32808D0, 0.28485D0, 0.26176D0, 0.24637D0, & 0.23501D0, 0.21882D0, 0.20291D0, 0.18634D0, 0.17532D0, & 0.15979D0, 0.14730D0, 0.13538D0, 0.12014D0, 0.10435D0, & 0.08847D0, 0.07306D0, 0.05873D0, 0.04595D0, 0.03477D0, & 0.02571D0, 0.01837D0, 0.01273D0, 0.00855D0, 0.00550D0