+TITLE ISAJET 7.83 31-JUL-2012 18:59:07 +PATCH,*ISADECAY. ISAJET DECAY TABLE. +USE,ISADECAY. ISAJET DECAY MODES. +EOD +PATCH,*ISAJET. ISAJET EVENT GENERATOR. +USE,ISACDE. ISAJET COMMON BLOCKS. +USE,ISADATA. ISAJET BLOCK DATA ALDATA. +USE,ISAJET. ISAJET EVENT GENERATION CODE. +USE,ISASUSY. ISASUSY MSSM DECAYS. +USE,ISATAPE. ISAJET TAPE INPUT/OUTPUT. +USE,ISARUN. ISAJET INTERACTIVE INTERFACE (IF=INTERACT) +EOD +PATCH,*ISAPLT. ISAJET ANALYSIS PACKAGE USING HBOOK. +USE,ISACDE. ISAJET COMMON BLOCKS. +USE,ISAPLT. ISAJET SKELETON ANALYSIS JOB. +USE,HBOOK4. DEFAULT IS HBOOK4, OR USE HBOOK3. +USE,HBOOK4,T=INHIBIT,IF=HBOOK3. +EOD +PATCH,*ISASUGRA. +USE,ISACDE. ALL COMMON BLOCKS. +USE,ISADATA. BLOCK DATA ALDATA. +USE,ISASUSY. ISASUSY DECAY/RGE CODE. +USE,ISASSRUN. MAIN PROGRAM CODE. +USE,P=ISASSRUN,D=SSRUN,T=INHIBIT. INHIBIT ISASUSY MAIN PROGRAM. +EOD +PATCH,*ISASUSY. +USE,ISACDE. ALL COMMON BLOCKS. +USE,ISADATA. BLOCK DATA ALDATA. +USE,ISASUSY. ISASUSY DECAY/RGE CODE. +USE,ISASSRUN. MAIN PROGRAM CODE. +USE,P=ISASSRUN,D=SUGRUN,T=INHIBIT. INHIBIT ISASUGRA MAIN PROGRAM. +EOD +PATCH,*ISATEXT. ISAJET INSTRUCTIONS. +USE,ISACDE. ISAJET COMMON BLOCKS. +USE,ISATEXT. ISAJET DOCUMENTATION. +USE,ISASSDOC. ISASUSY DOCUMENTATION. +USE,PDFLIB. LATEX FAILS ON MISSING VERBATIM PDF COMMONS. +EOD +PATCH,*ISAZEB. ISAJET EVENT GENERATOR. +USE,INTERACT. +USE,CERN. +USE,ZEBINIT. INITIALIZE ZEBRA. +USE,ISACDE. ISAJET COMMON BLOCKS. +USE,ISADATA. ISAJET BLOCK DATA ALDATA. +USE,ISAJET. ISAJET EVENT GENERATION CODE. +USE,ISASUSY. ISASUSY MSSM DECAYS. +USE,ISAZEB. ZEBRA TAPE INPUT/OUTPUT. +USE,ISARUN. ISAJET INTERACTIVE INTERFACE (IF=INTERACT) +EOD +PATCH,*ISZRUN. ISAJET ANALYSIS PACKAGE USING HBOOK4 AND ZEBRA +USE,ISACDE. ISAJET COMMON BLOCKS. +USE,ISZRUN. ISAJET SKELETON ANALYSIS JOB. +EOD +PATCH,ANSI. GENERIC ANSI FORTRAN. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +EOD +PATCH,APOLLO. +DECK,BLANKDEK. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD. +PATCH,CDC. CDC 7600 OR CYBER 175. +USE,SINGLE. SINGLE PRECISION. +USE,LEVEL2. LEVEL 2 STORAGE. +USE,CDCPACK. PACK 2 WORDS PER WORD FOR INPUT/OUTPUT. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +EOD +PATCH,CRAY. CRAY XMP OR 2. +USE,SINGLE. SINGLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +EOD +PATCH,DECS. DEC STATION (ULTRIX) +USE,SUN. +EOD +PATCH,ETA. ETA-10. +USE,SINGLE. SINGLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +EOD +PATCH,HPUX. HP/9000 7XX RUNNING UNIX. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,IBM. IBM 370 OR 30XX. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +EOD +PATCH,IBMRT. IBM RS/6000 WITH AIX 3.X +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,IRS. IBM RS/6000 WITH AIX 3.X +USE,IBMRT. +EOD +PATCH,LINUX. IBM PC WITH LINUX 1.X +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,OSF. DIGITAL OSF1 ON ALPHA. +USE,DOUBLE. DOUBLE PRECISION (USES REAL*8). +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,SGI. SILICON GRAPHICS 4D/XX. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,SUN. SUN (SPARC) +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,VAX. DEC VAX 11/780 OR 8600. +USE,DOUBLE. DOUBLE PRECISION. +USE,STDIO. STANDARD FORTRAN 77 TAPE INPUT/OUTPUT. +USE,MOVEFTN. FORTRAN REPLACEMENT FOR MOVLEV. +USE,RANFFTN,IF=-CERN. FORTRAN RANF. +USE,RANFCALL. STANDARD RANSET AND RANGET CALLS. +USE,NORANLUX,IF=-RANLUX. NO RANLUX RANDOM NUMBERS. +USE,NOCERN,IF=-CERN. NO CERN LIBRARY. +USE,IMPNONE. IMPLICIT NONE +EOD +PATCH,ISACDE. +EOD +DECK,CDEJET. +KEEP,CONST COMMON/CONST/PI,SQRT2,ALFA,GF,UNITS SAVE /CONST/ REAL PI,SQRT2,ALFA,GF,UNITS +KEEP,DKYTAB C LOOK must be dimensioned to the maximum value of INDEX. INTEGER MXLOOK PARAMETER (MXLOOK=500) INTEGER MXDKY PARAMETER (MXDKY=3000) COMMON/DKYTAB/LOOK(MXLOOK),CBR(MXDKY),MODE(5,MXDKY),MELEM(MXDKY) SAVE /DKYTAB/ +CDE,L2DKY,T=PASS,IF=LEVEL2. INTEGER LOOK,MODE,MELEM REAL CBR +KEEP,L2DKY,IF=LEVEL2. LEVEL 2,/DKYTAB/ +KEEP,DYLIM COMMON/DYLIM/QMIN,QMAX,QTMIN,QTMAX,YWMIN,YWMAX,XWMIN,XWMAX,THWMIN, 2 THWMAX,PHWMIN,PHWMAX 3 ,SETLMQ(12) SAVE /DYLIM/ LOGICAL SETLMQ EQUIVALENCE(BLIM1(1),QMIN) REAL QMIN,QMAX,QTMIN,QTMAX,YWMIN,YWMAX,XWMIN,XWMAX,THWMIN, + THWMAX,PHWMIN,PHWMAX,BLIM1(12) +KEEP,DYPAR COMMON/DYPAR/FLW,RNU2(3),ANORM(3),QPOW(3),PTPOW(3) SAVE /DYPAR/ LOGICAL FLW REAL RNU2,ANORM,QPOW,PTPOW +KEEP,EEPAR COMMON/EEPAR/SGMXEE,PLEP,PLEM,RSHMIN,RSHMAX, $UPSLON,SIGZ,IBREM,IBEAM,GAMGAM SAVE /EEPAR/ REAL SGMXEE,PLEP,PLEM,RSHMIN,RSHMAX,UPSLON,SIGZ LOGICAL IBREM,IBEAM,GAMGAM +KEEP,FINAL COMMON/FINAL/NKINF,SIGF,ALUM,ACCEPT,NRECS SAVE /FINAL/ INTEGER NKINF,NRECS REAL SIGF,ALUM,ACCEPT +KEEP,FORCE INTEGER MXFORC PARAMETER (MXFORC=40) COMMON/FORCE/NFORCE,IFORCE(MXFORC),MFORCE(5,MXFORC) $,LOOK2(2,MXFORC),LOOKST(MXFORC),MEFORC(MXFORC) SAVE /FORCE/ INTEGER NFORCE,IFORCE,MFORCE,LOOK2,LOOKST,MEFORC +KEEP,FRAME COMMON/FRAME/FRAME(5,3),N0JETS,N0W,N0PAIR SAVE /FRAME/ INTEGER N0JETS,N0W,N0PAIR REAL FRAME +KEEP,FRGPAR COMMON/FRGPAR/PUD,PBARY,SIGQT,PEND,XGEN(8),PSPIN1(8), $PMIX1(3,2),PMIX2(3,2),XGENSS(9) SAVE /FRGPAR/ EQUIVALENCE (PMIX1(1,1),PMIXX1(1)) EQUIVALENCE (PMIX2(1,1),PMIXX2(1)) EQUIVALENCE(FRPAR(1),PUD) REAL PUD,PBARY,SIGQT,PEND,XGEN,PSPIN1,PMIX1,PMIX2,XGENSS, + PMIXX1(6),PMIXX2(6),FRPAR(32) +KEEP,HCON COMMON/HCON/ANWWWW(4,4,4),ADWWWW(2,4),AIWWWW(4) $,HMASS,HGAM,HGAMS(29),ETAHGG,MATCHH(29),ZSTARS(4,2) $,IHTYPE,HGAMSS(85,85) SAVE /HCON/ +CDE,HCON2,T=PASS,IF=DOUBLE. +CDE,HCON1,T=PASS,IF=SINGLE. INTEGER MATCHH,IHTYPE REAL HMASS,HGAM,HGAMS,ETAHGG,ZSTARS,HGAMSS +KEEP,HCON1,IF=SINGLE. REAL ANWWWW,ADWWWW,AIWWWW +KEEP,HCON2,IF=DOUBLE. DOUBLE PRECISION ANWWWW,ADWWWW,AIWWWW +KEEP,IDRUN COMMON/IDRUN/IDVER,IDG(2),IEVT,IEVGEN SAVE /IDRUN/ INTEGER IDVER,IDG,IEVT,IEVGEN +KEEP,ISAPW C ISAPW1 is used to check whether ALDATA is loaded COMMON/ISAPW/ISAPW1 CHARACTER*30 ISAPW1 SAVE /ISAPW/ +KEEP,ISLOOP COMMON/ISLOOP/NEVOLV,NFRGMN,IEVOL,IFRG SAVE /ISLOOP/ INTEGER NEVOLV,NFRGMN,IEVOL,IFRG +KEEP,ITAPES COMMON/ITAPES/ITDKY,ITEVT,ITCOM,ITLIS SAVE /ITAPES/ INTEGER ITDKY,ITEVT,ITCOM,ITLIS +KEEP,JETLIM C Jet limits INTEGER MXLIM PARAMETER (MXLIM=8) INTEGER MXLX12 PARAMETER (MXLX12=12*MXLIM) COMMON/JETLIM/PMIN(MXLIM),PMAX(MXLIM),PTMIN(MXLIM),PTMAX(MXLIM), $YJMIN(MXLIM),YJMAX(MXLIM),PHIMIN(MXLIM),PHIMAX(MXLIM), $XJMIN(MXLIM),XJMAX(MXLIM),THMIN(MXLIM),THMAX(MXLIM), $SETLMJ(12*MXLIM) SAVE /JETLIM/ COMMON/FIXPAR/FIXP(MXLIM),FIXPT(MXLIM),FIXYJ(MXLIM), $FIXPHI(MXLIM),FIXXJ(MXLIM),FIXQM,FIXQT,FIXYW,FIXXW,FIXPHW SAVE /FIXPAR/ COMMON/SGNPAR/CTHS(2,MXLIM),THS(2,MXLIM),YJS(2,MXLIM),XJS(2,MXLIM) SAVE /SGNPAR/ REAL PMIN,PMAX,PTMIN,PTMAX,YJMIN,YJMAX,PHIMIN,PHIMAX,XJMIN, + XJMAX,THMIN,THMAX,BLIMS(12*MXLIM),CTHS,THS,YJS,XJS LOGICAL SETLMJ LOGICAL FIXQM,FIXQT,FIXYW,FIXXW,FIXPHW LOGICAL FIXP,FIXPT,FIXYJ,FIXPHI,FIXXJ EQUIVALENCE(BLIMS(1),PMIN(1)) +KEEP,JETPAR COMMON/JETPAR/P(3),PT(3),YJ(3),PHI(3),XJ(3),TH(3),CTH(3),STH(3) 1 ,JETTYP(3),SHAT,THAT,UHAT,QSQ,X1,X2,PBEAM(2) 2 ,QMW,QW,QTW,YW,XW,THW,QTMW,PHIW,SHAT1,THAT1,UHAT1,JWTYP 3 ,ALFQSQ,CTHW,STHW,Q0W 4 ,INITYP(2),ISIGS,PBEAMS(5) SAVE /JETPAR/ INTEGER JETTYP,JWTYP,INITYP,ISIGS REAL P,PT,YJ,PHI,XJ,TH,CTH,STH,SHAT,THAT,UHAT,QSQ,X1,X2, + PBEAM,QMW,QW,QTW,YW,XW,THW,QTMW,PHIW,SHAT1,THAT1,UHAT1, + ALFQSQ,CTHW,STHW,Q0W,PBEAMS +KEEP,JETSET INTEGER MXJSET,JPACK PARAMETER (MXJSET=400,JPACK=1000) COMMON/JETSET/NJSET,PJSET(5,MXJSET),JORIG(MXJSET),JTYPE(MXJSET), $JDCAY(MXJSET) SAVE /JETSET/ +CDE,L2JSET,T=PASS,IF=LEVEL2. INTEGER NJSET,JORIG,JTYPE,JDCAY REAL PJSET +KEEP,L2JSET,IF=LEVEL2. LEVEL2,/JETSET/ +KEEP,JETSIG INTEGER MXSIGS,IOPAK PARAMETER (MXSIGS=3000,IOPAK=100) COMMON/JETSIG/SIGMA,SIGS(MXSIGS),NSIGS,INOUT(MXSIGS),SIGEVT SAVE /JETSIG/ +CDE,L2SIGS,T=PASS,IF=LEVEL2. INTEGER NSIGS,INOUT REAL SIGMA,SIGS,SIGEVT +KEEP,L2SIGS,T=PASS,IF=LEVEL2. LEVEL2,/JETSIG/ +KEEP,JWORK COMMON/JWORK/ZZC(MXJSET),JMATCH(MXJSET),TNEW,P1CM(4), 1J1,J2,J3,J4,J5,E1CM,E2CM,E3CM,E4CM,E5CM SAVE /JWORK/ LOGICAL TNEW EQUIVALENCE (J1,JJ(1)),(E1CM,EE(1)) INTEGER JMATCH,J1,J2,J3,J4,J5,JJ(5) REAL ZZC,P1CM,E1CM,E2CM,E3CM,E4CM,E5CM,EE(5) +KEEP,JWORK2 COMMON/JWORK2/JVIR(2),PFINAL(5),SGN,ZMIN,ZMAX,DZMAX,JET,GLFORC(2), $ZGOOD,JIN(400),FXTEST(MXJSET) SAVE /JWORK2/ LOGICAL GLFORC,ZGOOD INTEGER JVIR,JET,JIN REAL PFINAL,SGN,ZMIN,ZMAX,DZMAX,FXTEST +KEEP,KEYS INTEGER MXKEYS PARAMETER (MXKEYS=20) COMMON/KEYS/IKEYS,KEYON,KEYS(MXKEYS) COMMON/XKEYS/REAC SAVE /KEYS/,/XKEYS/ LOGICAL KEYS LOGICAL KEYON CHARACTER*8 REAC INTEGER IKEYS +KEEP,KKGRAV C KKGravity common COMMON/KKGRAV/NEXTRAD,MASSD,KKGSD,SURFD,UVCUT INTEGER NEXTRAD REAL MASSD,KKGSD,SURFD LOGICAL UVCUT SAVE /KKGRAV/ +KEEP,LIMEVL COMMON /LIMEVL/ ETTHRS,CONCUT,USELIM SAVE /LIMEVL/ REAL ETTHRS,CONCUT LOGICAL USELIM +KEEP,LISTSS C LISTSS IDENT and JETTYPE codes C ISGL ISUPL -ISUPL ISDNL -ISDNL ISSTL -ISSTL ISCHL -ISCHL C 1 2 3 4 5 6 7 8 9 C ISBT1 -ISBT1 ISTP1 -ISTP1 ISUPR -ISUPR ISDNR -ISDNR ISSTR C 10 11 12 13 14 15 16 17 18 C -ISSTR ISCHR -ISCHR ISBT2 -ISBT2 ISTP2 -ISTP2 ISW1 -ISW1 C 19 20 21 22 23 24 25 26 27 C ISW2 -ISW2 ISZ1 ISZ2 ISZ3 ISZ4 ISNEL -ISNEL ISEL C 28 29 30 31 32 33 34 35 36 C -ISEL ISNML -ISNML ISMUL -ISMUL ISNTL -ISNTL ISTAU1-ISTAU1 C 37 38 39 40 41 42 43 44 45 C ISER -ISER ISMUR -ISMUR ISTAU2-ISTAU2 9 1 -1 C 46 47 48 49 50 51 52 53 54 C 2 -2 3 -3 4 -4 5 -5 6 C 55 56 57 58 59 60 61 62 63 C -6 11 -11 12 -12 13 -13 14 -14 C 64 65 66 67 68 69 70 71 72 C 15 -15 16 -16 10 80 -80 90 ISHL C 73 74 75 76 77 78 79 80 81 C ISHH ISHA ISHC -ISHC C 82 83 84 85 COMMON/LISTSS/LISTSS(85) INTEGER LISTSS SAVE /LISTSS/ +KEEP,LSTPRT COMMON/LSTPRT/LSTPRT SAVE /LSTPRT/ INTEGER LSTPRT +KEEP,LUXPAR C Parameters for RANLUX generator C Set by ALDATA and READIN but not by RESET C LUXSET=.TRUE. after RLUXGO has been called in PRTLIM INTEGER LUX PARAMETER (LUX=3) COMMON/LUXPAR/LUXINT,LUXK1,LUXK2,LUXGO INTEGER LUXINT,LUXK1,LUXK2 LOGICAL LUXGO +KEEP,MBGEN INTEGER LIMPOM PARAMETER (LIMPOM=20) COMMON/MBGEN/POMWT(LIMPOM),POMGEN(LIMPOM),MNPOM,MXPOM,PDIFFR, $NPOM,XBARY(2),DXBARY(2),XPOM(LIMPOM,2) SAVE /MBGEN/ INTEGER MNPOM,MXPOM,NPOM REAL POMWT,POMGEN,PDIFFR,XBARY,DXBARY,XPOM +KEEP,MBPAR COMMON/MBPAR/PUD0,PJSPN,PISPN,SIGQT0,XGEN0(2),PMIX01(3,2) 1,PMIX02(3,2),PBARY0 SAVE /MBPAR/ REAL PUD0,PJSPN,PISPN,SIGQT0,XGEN0,PMIX01,PMIX02,PBARY0 +KEEP,MGCOMS C===== Begin common blocks used by MadGraph REAL*8 GW, GWWA, GWWZ COMMON /COUP1/ GW, GWWA, GWWZ SAVE /COUP1/ REAL*8 GAL(2),GAU(2),GAD(2),GWF(2) COMMON /COUP2A/ GAL, GAU, GAD, GWF SAVE /COUP2A/ REAL*8 GZN(2),GZL(2),GZU(2),GZD(2),G1(2) COMMON /COUP2B/ GZN, GZL, GZU, GZD, G1 SAVE /COUP2B/ REAL*8 GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH COMMON /COUP3/ GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH SAVE /COUP3/ COMPLEX*16 GCHF(2,12) COMMON /COUP4/ GCHF SAVE /COUP4/ REAL*8 WMASS,WWIDTH,ZMASS,ZWIDTH COMMON /VMASS1/ WMASS,WWIDTH,ZMASS,ZWIDTH SAVE /VMASS1/ REAL*8 AMASS,AWIDTH,HMASS,HWIDTH COMMON /VMASS2/ AMASS,AWIDTH,HMASS,HWIDTH SAVE /VMASS2/ REAL*8 FMASS(12), FWIDTH(12) COMMON /FERMIONS/ FMASS, FWIDTH SAVE /FERMIONS/ REAL*8 GG(2), G COMMON /COUPQCD/ GG, G SAVE /COUPQCD/ C===== End common blocks used by MadGraph +KEEP,MGKIN C Double precision PJETS; MXJETS defined in /JETLIM/ C Format matches MadGraph COMMON/MGKIN/PJETS8(0:3,MXLIM+2),AMJET8(MXLIM+2) REAL*8 PJETS8,AMJET8 SAVE /MGKIN/ +KEEP,MGLIMS C Limits for MadGraph multiparton processes COMMON/MGLIMS/EHMGMN,EHMGMX,YHMGMN,YHMGMX, $AMIJMN(MXLIM,MXLIM),AMIJMX(MXLIM,MXLIM),FIXMIJ(MXLIM,MXLIM) SAVE /MGLIMS/ REAL EHMGMN,EHMGMX,YHMGMN,YHMGMX,AMIJMN,AMIJMX LOGICAL FIXMIJ +KEEP,MGSIGS C C Running totals for MadGraph cross sections C WTTOT8/NWTTOT = total cross section C WTSUM8/NWT8 = channel cross section C IFUNC8, IDENT8 = MadGraph function code channel flavors C INTEGER MXSIG8 PARAMETER (MXSIG8=1000) COMMON /MGSIGS/WTTOT8,WTSUM8(MXSIG8),WTMAX8(MXSIG8),NSIG8, $NWTTOT,NWT8(MXSIG8),IFUNC8(MXSIG8),IDENT8(MXLIM+2,MXSIG8), $ISORT8(MXSIG8) REAL*8 WTTOT8,WTSUM8,WTMAX8 INTEGER NSIG8,NWTTOT,NWT8,IFUNC8,IDENT8,ISORT8 SAVE /MGSIGS/ +KEEP,NODCAY COMMON/NODCAY/NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR,NOGRAV, $NOB,NOTAU LOGICAL NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR,NOGRAV, $NOB,NOTAU SAVE /NODCAY/ +KEEP,PARTCL INTEGER MXPTCL,IPACK PARAMETER (MXPTCL=4000,IPACK=10000) COMMON/PARTCL/NPTCL,PPTCL(5,MXPTCL),IORIG(MXPTCL),IDENT(MXPTCL) 1,IDCAY(MXPTCL) SAVE /PARTCL/ +CDE,L2PART,T=PASS,IF=LEVEL2. INTEGER NPTCL,IORIG,IDENT,IDCAY REAL PPTCL +KEEP,L2PART,IF=LEVEL2. LEVEL2,/PARTCL/ +KEEP,PINITS COMMON/PINITS/PINITS(5,2),IDINIT(2) SAVE /PINITS/ INTEGER IDINIT REAL PINITS +KEEP,PJETS INTEGER MXJETS PARAMETER (MXJETS=10) COMMON/PJETS/PJETS(5,MXJETS),IDJETS(MXJETS),QWJET(5),IDENTW $,PPAIR(5,4),IDPAIR(4),JPAIR(4),NPAIR,IFRAME(MXJETS) SAVE /PJETS/ INTEGER IDJETS,IDENTW,IDPAIR,JPAIR,NPAIR,IFRAME REAL PJETS,QWJET,PPAIR +KEEP,PRIMAR COMMON/PRIMAR/NJET,SCM,HALFE,ECM,IDIN(2),NEVENT,NTRIES,NSIGMA, $WRTLHE SAVE /PRIMAR/ INTEGER NJET,IDIN,NEVENT,NTRIES,NSIGMA LOGICAL WRTLHE REAL SCM,HALFE,ECM +KEEP,PRTOUT COMMON/PRTOUT/NEVPRT,NJUMP SAVE /PRTOUT/ INTEGER NEVPRT,NJUMP +KEEP,PTPAR COMMON/PTPAR/PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3,SIGMAX SAVE /PTPAR/ REAL PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3,SIGMAX +KEEP,Q1Q2 INTEGER MXGOQ,MXGOJ PARAMETER (MXGOQ=85,MXGOJ=8) COMMON/Q1Q2/GOQ(MXGOQ,MXGOJ),GOALL(MXGOJ),GODY(4),STDDY, $GOWW(25,2),ALLWW(2),GOWMOD(25,MXGOJ) SAVE /Q1Q2/ LOGICAL GOQ,GOALL,GODY,STDDY,GOWW,ALLWW,GOWMOD +KEEP,QCDPAR COMMON/QCDPAR/ALAM,ALAM2,CUTJET,ISTRUC SAVE /QCDPAR/ INTEGER ISTRUC REAL ALAM,ALAM2,CUTJET +KEEP,QLMASS COMMON/QLMASS/AMLEP(100),NQLEP,NMES,NBARY SAVE /QLMASS/ INTEGER NQLEP,NMES,NBARY REAL AMLEP +KEEP,QSAVE COMMON/QSAVE/QSAVE(29,2) SAVE /QSAVE/ REAL QSAVE +KEEP,SEED COMMON/SEED/XSEED SAVE /SEED/ CHARACTER*24 XSEED +KEEP,TCPAR COMMON/TCPAR/TCMRHO,TCGRHO SAVE /TCPAR/ REAL TCMRHO,TCGRHO +KEEP,TIMES COMMON/TIMES/TIME1,TIME2 SAVE /TIMES/ REAL TIME1,TIME2 +KEEP,TOTALS COMMON/TOTALS/NKINPT,NWGEN,NKEEP,SUMWT,WT SAVE /TOTALS/ INTEGER NKINPT,NWGEN,NKEEP REAL SUMWT,WT +KEEP,TYPES INTEGER MXTYPE PARAMETER (MXTYPE=8) COMMON/TYPES/LOC(100),NTYP,NJTTYP(MXTYPE),NWWTYP(2),NWMODE(3) COMMON/XTYPES/PARTYP(40),TITLE(10),JETYP(30,MXTYPE),WWTYP(30,2) $,WMODES(30,3) SAVE /TYPES/,/XTYPES/ CHARACTER*8 JETYP,WWTYP,TITLE,PARTYP,WMODES INTEGER LOC,NTYP,NJTTYP,NWWTYP,NWMODE +KEEP,W50510,IF=PDFLIB C Copy of PDFLIB common block COMMON/W50510/IFLPRT INTEGER IFLPRT SAVE /W50510/ +KEEP,W50517,IF=PDFLIB C Copy of PDFLIB common block COMMON/W50517/N6 INTEGER N6 SAVE /W50517/ +KEEP,WCON COMMON/WCON/SIN2W,WMASS(4),WGAM(4),AQ(12,4),BQ(12,4),COUT(4), 1MATCH(25,4),WCBR(25,4),CUTOFF,CUTPOW,TBRWW(4,2),RBRWW(12,4,2),EZ, 2AQDP(12,4),BQDP(12,4),EZDP,WFUDGE SAVE /WCON/ +CDE,WCON2,T=PASS,IF=DOUBLE. +CDE,WCON1,T=PASS,IF=SINGLE. INTEGER MATCH REAL SIN2W,WMASS,WGAM,AQ,BQ,COUT,WCBR,CUTOFF,CUTPOW,TBRWW, + RBRWW,EZ,WFUDGE COMMON/WCON2/CUMWBR(25,3) REAL CUMWBR +KEEP,WCON1,T=PASS,IF=SINGLE. REAL AQDP,BQDP,EZDP +KEEP,WCON2,T=PASS,IF=DOUBLE. DOUBLE PRECISION AQDP,BQDP,EZDP +KEEP,WGEN COMMON/WGEN/PTGN(3,3),QGEN(3,3),PTSEL(3),QSEL(3),SIGSL(3),NKL,NKH 1,EMSQ,EMGAM,KSEL,QSELWT(3) SAVE /WGEN/ INTEGER NKL,NKH,KSEL REAL PTGN,QGEN,PTSEL,QSEL,SIGSL,EMSQ,EMGAM,QSELWT +KEEP,WSIG COMMON/WSIG/SIGLLQ SAVE /WSIG/ REAL SIGLLQ +KEEP,WWPAR. COMMON/WWPAR/SWW,TWW,UWW,WM2,ZM2,P1WW(5),P2WW(5),P3WW(5),P4WW(5) $,PZERO(4,4),S13,P3(5),Q1(5),Q3(5),JQWW(2) $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU SAVE /WWPAR/ +CDE,WWPAR2,T=PASS,IF=DOUBLE. +CDE,WWPAR1,T=PASS,IF=SINGLE. INTEGER JQWW +KEEP,WWPAR1,T=PASS,IF=SINGLE. REAL SWW,TWW,UWW,WM2,ZM2,P1WW,P2WW,P3WW,P4WW $,PZERO,S13,P3,Q1,Q3 $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU +KEEP,WWPAR2,T=PASS,IF=DOUBLE. DOUBLE PRECISION SWW,TWW,UWW,WM2,ZM2,P1WW,P2WW,P3WW,P4WW $,PZERO,S13,P3,Q1,Q3 $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU +KEEP,WWSIG. COMMON/WWSIG/WWSIG SAVE /WWSIG/ REAL WWSIG +DECK,CDESUSY. +KEEP,BREMBM COMMON/BREMBM/QSQBM,EB,XMIN REAL QSQBM,EB,XMIN SAVE /BREMBM/ +KEEP,DKYSS3 C C Data for SUSY 3-body matrix elements. There is a double C pointer structure, first to modes, and then to poles that C make up the matrix element for that mode: C MELEM=-I in /DKYTAB/ points to the mode information: C J1SS3(I) = start of pole list for this mode C J2SS3(I) = end of pole list for this mode C WTSS3(I) = maximum weight for this mode C J1SS3 gaugino f fbar, the pole types are C KSS3=1: spin-1 pole in f-fbar channel C KSS3=2: spin-0 pole in gaugino-f channel C KSS3=3: spin-0 pole in gaugino-fbar channel C KSS3=4: spin-0 pole in f-fbar channel C The two couplings are the coefficients of 1,gamma_5 or of C gamma_mu,gamma_mu*gamma_5. C INTEGER MXMSS3,MXPSS3 PARAMETER (MXMSS3=1000) PARAMETER (MXPSS3=2000) COMMON/DKYSS3/NMSS3,NPSS3, $J1SS3(MXMSS3),J2SS3(MXMSS3),WTSS3(MXMSS3), $KSS3(MXPSS3),AMSS3(MXPSS3),ZISS3(2,MXPSS3),ZFSS3(2,MXPSS3) INTEGER NMSS3,NPSS3,KSS3,J1SS3,J2SS3 REAL WTSS3,AMSS3 COMPLEX ZISS3,ZFSS3 +KEEP,SSINF COMMON/SSINF/XLAM DOUBLE PRECISION XLAM +KEEP,SSLUN COMMON/SSLUN/LOUT,LHEOUT INTEGER LOUT,LHEOUT SAVE /SSLUN/ +KEEP,SSMODE C MXSS = maximum number of modes C NSSMOD = number of modes C ISSMOD = initial particle C JSSMOD = final particles C GSSMOD = width C BSSMOD = branching ratio C MSSMOD = decay matrix element pointer C LSSMOD = logical flag used internally by SSME3 INTEGER MXSS PARAMETER (MXSS=1000) COMMON/SSMODE/NSSMOD,ISSMOD(MXSS),JSSMOD(5,MXSS),GSSMOD(MXSS) $,BSSMOD(MXSS),MSSMOD(MXSS),LSSMOD INTEGER NSSMOD,ISSMOD,JSSMOD,MSSMOD REAL GSSMOD,BSSMOD LOGICAL LSSMOD SAVE /SSMODE/ +KEEP,SSPAR C SUSY parameters C AMGLSS = gluino mass C AMULSS = up-left squark mass C AMELSS = left-selectron mass C AMERSS = right-slepton mass C AMNiSS = sneutrino mass for generation i C TWOM1 = Higgsino mass = - mu C RV2V1 = ratio v2/v1 of vev's C AMTLSS,AMTRSS = left,right stop masses C AMT1SS,AMT2SS = light,heavy stop masses C AMBLSS,AMBRSS = left,right sbottom masses C AMB1SS,AMB2SS = light,heavy sbottom masses C AMLLSS,AMLRSS = left,right stau masses C AML1SS,AML2SS = light,heavy stau masses C AMZiSS = signed mass of Zi C ZMIXSS = Zi mixing matrix C AMWiSS = signed Wi mass C GAMMAL,GAMMAR = Wi left, right mixing angles C AMHL,AMHH,AMHA = neutral Higgs h0, H0, A0 masses C AMHC = charged Higgs H+ mass C ALFAH = Higgs mixing angle C AAT = stop trilinear term C THETAT = stop mixing angle C AAB = sbottom trilinear term C THETAB = sbottom mixing angle C AAL = stau trilinear term C THETAL = stau mixing angle C AMGVSS = gravitino mass C MTQ = top mass at MSUSY C MBQ = bottom mass at MSUSY C MLQ = tau mass at MSUSY C FBMA = b-Yukawa at mA scale C VUQ = Hu vev at MSUSY C VDQ = Hd vev at MSUSY C SGNM3 = sign of gaugino mass M3 COMMON/SSPAR/GORGE,AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS(4,4) $,AMW1SS,AMW2SS $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA, $VUQ,VDQ,SGNM3 REAL AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS $,AMW1SS,AMW2SS $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA,VUQ,VDQ,SGNM3 LOGICAL GORGE REAL AMZISS(4) EQUIVALENCE (AMZISS(1),AMZ1SS) SAVE /SSPAR/ +KEEP,SSPOLS C Polarizations in SUSY decays C PTAUj(i) = P_tau for tauj -> ziss tau C PTAUZi(j) = P_tau for ziss -> tauj tau C PTAUZZ = P_tau for z2ss -> z1ss tau tau C PTAUWZ = P_tau for w1ss -> z1ss tau nutau COMMON/SSPOLS/PTAU1(4),PTAU2(4),PTAUZ2(2),PTAUZ3(2),PTAUZ4(2), $PTAUZZ,PTAUWZ SAVE /SSPOLS/ REAL PTAU1,PTAU2,PTAUZ2,PTAUZ3,PTAUZ4,PTAUZZ,PTAUWZ +KEEP,SSSM C Standard model parameters C AMUP,...,AMTP = quark masses C AME,AMMU,AMTAU = lepton masses C AMW,AMZ = W,Z masses C GAMW,GAMZ = W,Z widths C ALFAEM,SN2THW,ALFA3 = SM couplings C ALQCD4 = 4 flavor lambda COMMON/SSSM/AMUP,AMDN,AMST,AMCH,AMBT,AMTP,AME,AMMU,AMTAU $,AMW,AMZ,GAMW,GAMZ,ALFAEM,SN2THW,ALFA2,ALFA3,ALQCD4 REAL AMUP,AMDN,AMST,AMCH,AMBT,AMTP,AME,AMMU,AMTAU $,AMW,AMZ,GAMW,GAMZ,ALFAEM,SN2THW,ALFA2,ALFA3,ALQCD4 SAVE /SSSM/ +KEEP,SSTMP C Temporary parameters for functions COMMON/SSTMP/TMP(10),ITMP(10) REAL TMP INTEGER ITMP SAVE /SSTMP/ +KEEP,SSTYPE C SM ident code definitions. These are standard ISAJET but C can be changed. INTEGER IDUP,IDDN,IDST,IDCH,IDBT,IDTP INTEGER IDNE,IDE,IDNM,IDMU,IDNT,IDTAU INTEGER IDGL,IDGM,IDW,IDZ,IDH PARAMETER (IDUP=1,IDDN=2,IDST=3,IDCH=4,IDBT=5,IDTP=6) PARAMETER (IDNE=11,IDE=12,IDNM=13,IDMU=14,IDNT=15,IDTAU=16) PARAMETER (IDGL=9,IDGM=10,IDW=80,IDZ=90,IDH=81) C SUSY ident code definitions. They are chosen to be similar C to those in versions < 6.50 but may be changed. INTEGER ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1 INTEGER ISNEL,ISEL,ISNML,ISMUL,ISNTL,ISTAU1 INTEGER ISUPR,ISDNR,ISSTR,ISCHR,ISBT2,ISTP2 INTEGER ISNER,ISER,ISNMR,ISMUR,ISNTR,ISTAU2 INTEGER ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,ISGL INTEGER ISHL,ISHH,ISHA,ISHC INTEGER ISGRAV INTEGER IDTAUL,IDTAUR PARAMETER (ISUPL=21,ISDNL=22,ISSTL=23,ISCHL=24,ISBT1=25,ISTP1=26) PARAMETER (ISNEL=31,ISEL=32,ISNML=33,ISMUL=34,ISNTL=35,ISTAU1=36) PARAMETER (ISUPR=41,ISDNR=42,ISSTR=43,ISCHR=44,ISBT2=45,ISTP2=46) PARAMETER (ISNER=51,ISER=52,ISNMR=53,ISMUR=54,ISNTR=55,ISTAU2=56) PARAMETER (ISGL=29) PARAMETER (ISZ1=30,ISZ2=40,ISZ3=50,ISZ4=60,ISW1=39,ISW2=49) PARAMETER (ISHL=82,ISHH=83,ISHA=84,ISHC=86) PARAMETER (ISGRAV=91) PARAMETER (IDTAUL=10016,IDTAUR=20016) +KEEP,SUGMG C Frozen couplings from RG equations: C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t C GSS(13) = M_hd^2 GSS(14) = M_hu^2 GSS(15) = M_er^2 C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2 C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2 C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N C GSS(28) = M_nr GSS(29) = A_n GSS(30) = vdq C GSS(31) = vuq C Masses: C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl C MSS(16) = nutl MSS(17) = el- MSS(18) = er- C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0 C MSS(31) = ha0 MSS(32) = h+ C Unification: C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUT COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT, $FBGUT,FTAGUT,FNGUT REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT SAVE /SUGMG/ +KEEP,SUGNU C XNUSUG contains non-universal GUT scale soft terms for SUGRA: C XNUSUG(1)=M1 XNUSUG(2)=M2 XNUSUG(3)=M3 C XNUSUG(4)=A_tau XNUSUG(5)=A_b XNUSUG(6)=A_t C XNUSUG(7)=m_Hd XNUSUG(8)=m_Hu XNUSUG(9)=m_eR XNUSUG(10)=m_eL C XNUSUG(11)=m_dR XNUSUG(12)=m_uR XNUSUG(13)=m_uL XNUSUG(14)=m_lR C XNUSUG(15)=m_lL XNUSUG(16)=m_bR XNUSUG(17)=m_tR XNUSUG(18)=m_tL C XNUSUG(19)=mu(Q) XNUSUG(20)=mA(Q) COMMON /SUGNU/ XNUSUG(20),INUHM REAL XNUSUG INTEGER INUHM SAVE /SUGNU/ +KEEP,SUGPAS COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,MHLNEG,MHCNEG, $MSQNEG,IGUTST,ASM3, $VUMT,VDMT,ASMTP,ASMSS,M3Q,MHDSQ,MHUSQ,MHDSMG,MHUSMG,MUMG,BMG, $FT2Z1,FB2Z1,FL2Z1,SIGDMX,SIGUMX,C5MAX REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q,MHDSQ,MHUSQ, $MHDSMG,MHUSMG,MUMG,BMG,FT2Z1,FB2Z1,FL2Z1, $SIGDMX,SIGUMX,C5MAX INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG,MHLNEG,MHCNEG, $MSQNEG,IGUTST SAVE /SUGPAS/ +KEEP,SUGXIN C XSUGIN contains the inputs to SUGRA: C XSUGIN(1) = M_0 XSUGIN(2) = M_(1/2) XSUGIN(3) = A_0 C XSUGIN(4) = tan(beta) XSUGIN(5) = sgn(mu) XSUGIN(6) = M_t C XSUGIN(7) = SUG BC scale C XGMIN(1) = LAM XGMIN(2) = M_MES XGMIN(3) = XN5 C XGMIN(4) = tan(beta) XGMIN(5) = sgn(mu) XGMIN(6) = M_t C XGMIN(7) = CGRAV XGMIN(8) =RSL XGMIN(9) = DEL_HD C XGMIN(10) = DEL_HU XGMIN(11) = DY XGMIN(12) = N5_1 C XGMIN(13) = N5_2 XGMIN(14) = N5_3 C XNRIN(1) = M_N3 XNRIN(2) = M_MAJ XNRIN(3) = ANSS C XNRIN(4) = M_N3SS C XISAIN contains the MSSMi inputs in natural order. COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4), $XAMIN(11) REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN SAVE /SUGXIN/ +KEEP,XMSSM COMMON/XMSSM/GOMSSM,GOSUG,GOGMSB,GOAMSB,AL3UNI,GOMMAM,GOHCAM $,XGLSS,XMUSS,XHASS,XTBSS $,XQ1SS,XDRSS,XURSS,XL1SS,XERSS $,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS $,XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS $,XM1SS,XM2SS,XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU $,XLAMGM,XMESGM,XN5GM,XCMGV,XMGVTO $,XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM $,XMN3NR,XMAJNR,XANSS,XNRSS,XSBCS, $XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM, $XL1AM,XL2AM,XL3AM SAVE /XMSSM/ REAL XGLSS,XMUSS,XHASS,XTBSS $,XQ1SS,XDRSS,XURSS,XL1SS,XERSS $,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS $,XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS $,XM1SS,XM2SS $,XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU $,XLAMGM,XMESGM,XN5GM,XCMGV,XMGVTO $,XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM $,XMN3NR,XMAJNR,XANSS,XNRSS,XSBCS, $XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM, $XL1AM,XL2AM,XL3AM LOGICAL GOMSSM,GOSUG,GOGMSB,GOAMSB,AL3UNI,GOMMAM,GOHCAM +DECK,CDETAPE. +KEEP,HEPEVT INTEGER NMXHEP PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), $JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP REAL PHEP,VHEP SAVE /HEPEVT/ C... NEVHEP - event number C... NHEP - number of entries in this event C... ISTHEP(..) - status code C... IDHEP(..) - particle ID, P.D.G. standard C... JMOHEP(1,..) - position of mother particle in list C... JMOHEP(2,..) - position of second mother particle in list C... JDAHEP(1,..) - position of first daughter in list C... JDAHEP(2,..) - position of last daughter in list C... PHEP(1,..) - x momentum in GeV/c C... PHEP(2,..) - y momentum in GeV/c C... PHEP(3,..) - z momentum in GeV/c C... PHEP(4,..) - energy in GeV C... PHEP(5,..) - mass in GeV/c**2 C... VHEP(1,..) - x vertex position in mm C... VHEP(2,..) - y vertex position in mm C... VHEP(3,..) - z vertex position in mm C... VHEP(4,..) - production time in mm/c +KEEP,ITA COMMON/ITA/ITA,ITB SAVE /ITA/ INTEGER ITA,ITB +KEEP,RECTP COMMON/RECTP/IRECTP,IREC SAVE /RECTP/ INTEGER IRECTP,IREC +KEEP,ZEVEL INTEGER MAXLEN PARAMETER (MAXLEN=1024) COMMON/ZEVEL/IZEVEL(MAXLEN) SAVE /ZEVEL/ EQUIVALENCE(ZEVEL(1),IZEVEL(1)) EQUIVALENCE(LZEVEL(1),IZEVEL(1)) EQUIVALENCE (IZVL1,IZEVEL(1)) EQUIVALENCE (IZVL2,IZEVEL(2)) +CDE,L2ZEVL,T=PASS,IF=LEVEL2. INTEGER IZEVEL,IZVL1,IZVL2 REAL ZEVEL(MAXLEN) LOGICAL LZEVEL(MAXLEN) +KEEP,L2ZEVL,IF=LEVEL2. LEVEL2, /ZEVEL/ +KEEP,ZVOUT COMMON/ZVOUT/ZVOUT(512) SAVE /ZVOUT/ +CDE,L2ZOUT,T=PASS,IF=LEVEL2. REAL ZVOUT +KEEP,L2ZOUT,IF=LEVEL2. LEVEL2,/ZVOUT/ +DECK,CDEZEBRA. +KEEP,ISABNK . C COMMON/ISABNK/BANK,FILISA,FILIS2 SAVE /ISABNK/ CHARACTER*12 BANK CHARACTER*80 FILISA,FILIS2 C C If BANK='ISAP' Zebra bank ISAP (particles) will be written out C if BANK='ISAC' " ISAC (pseudo calorimeter) will be written out C If BANK='ISAL' " ISAL (leptons) will be written out C if BANK='ISAPISAC' both groups will be written out C if BANK='ISAPISACISAL' all groups will be written out C C FILISA= name of ISAJET events file (ZEBRA) C FILIS2= name of second file if needed for output C +KEEP,ISALNK . INTEGER NVD,MQREF,MPQREF PARAMETER (NVD=100) PARAMETER (MQREF=200) PARAMETER (MPQREF=10) COMMON/ISALNK/LVD(NVD),QREF(MQREF),PQREF(MPQREF) SAVE /ISALNK/ INTEGER LVD ! vertex links INTEGER QREF ! initial and final parton links INTEGER PQREF ! links to primary jets +KEEP,ISAUNT . COMMON/ISAUNT/ISUNIT,ISWRIT SAVE /ISAUNT/ INTEGER ISUNIT,ISWRIT C ISUNIT=file number to write(read) ISAJET ZEBRA output C ISWRIT= " to write if ISUNIT used for reading +KEEP,IZISAB . INTEGER IZISAB PARAMETER (IZISAB=17) +KEEP,IZISAC . INTEGER IZISAC PARAMETER (IZISAC=6) +KEEP,IZISAE . INTEGER IZISAE PARAMETER (IZISAE=17) +KEEP,IZISAF . INTEGER IZISAF PARAMETER (IZISAF=17) +KEEP,IZISAJ . INTEGER IZISAJ PARAMETER (IZISAJ=1) +KEEP,IZISAL . INTEGER IZISAL PARAMETER (IZISAL=7) +KEEP,IZISAM . INTEGER IZISAM PARAMETER (IZISAM=9) +KEEP,IZISAQ . INTEGER IZISAQ PARAMETER (IZISAQ=2) +KEEP,IZISCL . INTEGER IZISCL PARAMETER (IZISCL=1) +KEEP,IZISCM . C----------------------------------------------------------------------- C Created 13-DEC-1989 10:20:16.28 Chip Stewart C Link offset of bank ISCM in mother bank ISAB C----------------------------------------------------------------------- INTEGER IZISCM PARAMETER ( IZISCM = 1) +KEEP,IZISJT . C----------------------------------------------------------------------- C Created 29-JAN-1990 Serban D. Protopopescu C Link offset of bank ISJT in mother bank (ISAC) C----------------------------------------------------------------------- INTEGER IZISJT PARAMETER ( IZISJT = 3 ) +KEEP,IZISMR . C----------------------------------------------------------------------- C Created 18-MAY-1989 Serban D. Protopopescu C Link offset of bank ISMR in mother bank C----------------------------------------------------------------------- INTEGER IZISMR PARAMETER ( IZISMR = 2 ) +KEEP,IZISP1 . INTEGER IZISP1 PARAMETER (IZISP1=1) +KEEP,IZISP2 . INTEGER IZISP2 PARAMETER (IZISP2=1) +KEEP,IZISP3 . INTEGER IZISP3 PARAMETER (IZISP3=5) +KEEP,IZISRC . C DEC/CMS REPLACEMENT HISTORY, Element IZISRC.LINK C *1 25-JAN-1990 14:08:41 CSTEWART "Chip Stewart: LINK FILE FOR ISRC BANK" C DEC/CMS REPLACEMENT HISTORY, Element IZISRC.LINK C----------------------------------------------------------------------- C Created 11-JAN-1990 16:49:35.86 Chip Stewart C Link offset of bank ISRC in mother bank ISAB C----------------------------------------------------------------------- INTEGER IZISRC PARAMETER ( IZISRC = 2) +KEEP,IZISV1 . INTEGER IZISV1 PARAMETER (IZISV1=3) +KEEP,IZISV2 . INTEGER IZISV2 PARAMETER (IZISV2=4) +KEEP,IZPJET C----------------------------------------------------------------------- C Created 7-NOV-1989 18:10:09.84 Chip Stewart C Link offset of bank PJET in mother bank PJHD C----------------------------------------------------------------------- INTEGER IZPJET PARAMETER ( IZPJET = 1) +KEEP,IZPJHD C----------------------------------------------------------------------- C Created 7-NOV-1989 17:57:58.00 Chip Stewart C Link offset of bank PJHD in mother bank ISAE C----------------------------------------------------------------------- INTEGER IZPJHD PARAMETER ( IZPJHD = 8) +KEEP,IZPJPT C----------------------------------------------------------------------- C Created 7-NOV-1989 18:10:09.84 Chip Stewart C Link offset of bank PJPT in mother bank PJHD C----------------------------------------------------------------------- INTEGER IZPJPT PARAMETER ( IZPJPT = 1) +KEEP,LKPJET . C---------------------------------------------------------------------- C- C- Name LKPJET.INC C- Purpose Temporary link area for PJET banks C- Created 5-DEC-1989 CHIP STEWART (HBP) C- Updated 13-JAN-1990 Harrison B. Prosper C- Updated 6-NOV-1990 Chip Stewart - ADDED ISP1,ISV1 C- C---------------------------------------------------------------------- C C **** JPJET(1) User flag C **** JPJET(2) System word C **** JPJET(3) First link in area (= KPJET(1)) C INTEGER PJLON PARAMETER( PJLON = 1 ) ! Activate link area C INTEGER PJLOFF PARAMETER( PJLOFF= 0 ) ! De-activate link area C INTEGER MXPJET PARAMETER( MXPJET = 8 ) INTEGER LPJHD,LPJET,LPJPT,LISAQ,LISAJ,LISP1,LISV1 INTEGER JPJET,KPJET(MXPJET) EQUIVALENCE ( LPJHD, KPJET(1) ) EQUIVALENCE ( LPJET, KPJET(2) ) EQUIVALENCE ( LPJPT, KPJET(3) ) EQUIVALENCE ( LISAQ, KPJET(5) ) EQUIVALENCE ( LISAJ, KPJET(6) ) EQUIVALENCE ( LISP1, KPJET(7) ) EQUIVALENCE ( LISV1, KPJET(8) ) COMMON /LKPJET/ JPJET(2),KPJET SAVE /LKPJET/ +KEEP,PI. DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN C C last significant (correctly rounded) decimal place on VAX: C | C V PARAMETER (PI= 3.1415 92653 58979 32384 6) PARAMETER (TWOPI= 6.2831 85307 17958 64769 3) PARAMETER (HALFPI= 1.5707 96326 79489 66192 3) PARAMETER (RADIAN= 0.0174532 92519 94329 5769237) +KEEP,QUEST C C Zebra common, returns status information COMMON /QUEST/ IQUEST(100) SAVE /QUEST/ INTEGER IQUEST +KEEP,ZEBCOM . C C ZEBCOM is the main zebra common block for event data storage C INTEGER NNQ,NREF PARAMETER (NNQ=200000) PARAMETER (NREF=9) COMMON/ZEBCOM/IXCOM,IXMAIN,IXDVR,FENCE,LISAE,LISAB,LREF, $ ZSTOR,ENDZS SAVE /ZEBCOM/ INTEGER IXCOM ! store number $ ,IXMAIN ! event division number $ ,IXDVR ! run division number INTEGER FENCE(8),LREF(NREF),ZSTOR(NNQ),ENDZS INTEGER LISAE ! pointer to ISAE bank INTEGER LISAB ! pointer to ISAB bank REAL Q(NNQ) INTEGER IQ(NNQ),LQ(NNQ) EQUIVALENCE (LISAE,LQ(1)),(LQ(9),IQ(1),Q(1)) C +KEEP,ZLINKA C C general Zebra link area C use with utility subroutines GSLINK,GRLINK,RSLINK and RRLINK INTEGER NSLINK,NRLINK,LSLINK,LRLINK PARAMETER (NSLINK=100) PARAMETER (NRLINK=100) COMMON/ZLINKA/LSLINK(NSLINK),LRLINK(NRLINK) SAVE /ZLINKA/ +DECK,CDEPLT. +KEEP,CALOR REAL DELY,YCMIN,YCMAX INTEGER NCY PARAMETER (NCY=80,DELY=.1,YCMIN=-4.,YCMAX=4.) REAL DELPHI INTEGER NCPHI PARAMETER (NCPHI=72,DELPHI=.087267) COMMON/CALOR/ET(NCY,NCPHI),ETEM(NCY,NCPHI), $CTHCAL(NCY),STHCAL(NCY),CPHCAL(NCPHI),SPHCAL(NCPHI) SAVE /CALOR/ +CDE,L2CAL,T=PASS,IF=LEVEL2. REAL ET,ETEM,CTHCAL,STHCAL,CPHCAL,SPHCAL +KEEP,L2CAL,IF=LEVEL2 LEVEL2,/CALOR/ +KEEP,GETJET INTEGER NJMAX PARAMETER (NJMAX=50) COMMON/GETCOM/JETNO(NCY,NCPHI),NCJET,PCJET(4,NJMAX),ETJET(NJMAX) SAVE /GETCOM/ +CDE,L2GETJ,T=PASS,IF=LEVEL2 INTEGER JETNO,NCJET REAL PCJET,ETJET +KEEP,L2GETJ,IF=LEVEL2 LEVEL2,/GETCOM/ +KEEP,MYHIST COMMON/MYHIST/MXHIST,NHSHFT SAVE /MYHIST/ INTEGER MXHIST,NHSHFT +PATCH,ISADATA. +EOD +DECK,ALDATA. BLOCK DATA ALDATA C INITIALIZE ALL COMMON BLOCKS C....................................................................... C WARNINGS: MANY VARIABLES SET IN ALDATA ARE ALSO SET BY . C SUBROUTINE RESET. . C . C ALDATA SHOULD ALWAYS BE LOADED WHEN USING ISAJET OR WHEN . C READING AN ISAJET TAPE. . C....................................................................... +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,PJETS +CDE,PINITS +CDE,LSTPRT +CDE,DKYTAB +CDE,DYLIM +CDE,EEPAR +CDE,FRGPAR +CDE,IDRUN +CDE,JETLIM +CDE,JETPAR +CDE,JETSET +CDE,JETSIG +CDE,LIMEVL +CDE,LUXPAR +CDE,MBPAR +CDE,NODCAY +CDE,PARTCL +CDE,PRIMAR +CDE,PRTOUT +CDE,QCDPAR +CDE,QLMASS +CDE,Q1Q2 +CDE,SEED +CDE,SSPAR +CDE,TCPAR +CDE,TOTALS +CDE,TYPES +CDE,WCON +CDE,MBGEN +CDE,FORCE +CDE,ZEVEL +CDE,FINAL +CDE,KEYS +CDE,HCON +CDE,XMSSM +CDE,SUGNU +CDE,ISAPW +CDE,SSTYPE +CDE,LISTSS +CDE,SUGXIN +CDE,SSMODE C INTEGER III,JJJ INTEGER MXGOQJ PARAMETER (MXGOQJ=MXGOJ*MXGOQ) INTEGER MXGOWJ PARAMETER (MXGOWJ=25*MXGOJ) INTEGER MXT29 PARAMETER (MXT29=29*MXTYPE) C SUSY IDENT codes from /SSTYPE/ INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) C C DATA FOR IDRUN C IDVER=100*VERSION+CYCLE C DATA IDVER/600/ C C DATA FOR ITAPES DATA ITDKY,ITEVT,ITCOM,ITLIS/1,2,5,6/ C C DATA FOR LUXPAR DATA LUXINT,LUXK1,LUXK2/314159265,0,0/ DATA LUXGO/.TRUE./ C C DATA FOR QLMASS C AMLEP LABELED BY INDEX...SEE FLAVOR C SETW RESETS W+- AND Z0 MASSES DATA AMLEP/.3,.3,.5,1.6,5.0,175.,-1.,-1.,0.,0., $0.,.511003E-3,0.,.105661,0.,1.777,3*-1.,.49767,.49767, $79*0./ DATA NQLEP,NMES,NBARY/61,2,2/ C C DATA FOR PJETS DATA IDJETS/MXJETS*0/,IDENTW/0/ C C DATA FOR PINITS DATA IDINIT/2*0/ C C DATA FOR LSTPRT DATA LSTPRT/0/ C C DATA FOR MBPAR DATA PUD0/.45/,PJSPN,PISPN/2*.5/,SIGQT0/.35/,XGEN0/.9,1./,PMIX01/ $.25,.25,.5,0.,.5,1./,PMIX02/.5,.5,1.,0.,0.,1./ DATA PBARY0/.075/ C C DATA FOR MBGEN DATA MNPOM,MXPOM/1,LIMPOM/ C C DATA FOR SEED DATA XSEED/'0'/ C C DATA FOR TCPAR DATA TCMRHO,TCGRHO/1000.,100./ C C DATA FOR FRGPAR C F(X)=1-XGEN(1)+XGEN(1)*(XGEN(2)+1)*(1-X)**XGEN(2) FOR U,D,S C PETERSON FRAGMENTATION, EPSILON=XGEN(I)*M(I)**2 FOR C,B,T DATA PUD,PBARY/.43,.10/ DATA SIGQT,PEND/.35,.14/ DATA XGEN/.96,3.,0.,.8,.5,.5,.5,.5/ DATA PSPIN1/.5,.5,.5,.75,.75,.75,.75,.75/ DATA PMIX1/.25,.25,.5,0.,.5,1./,PMIX2/.5,.5,1.,0.,0.,1./ DATA XGENSS/9*.5/ C C DATA FOR JETLIM DATA BLIMS/MXLX12*-1.E9/ C C DATA FOR NODCAY DATA NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR/6*.FALSE./ DATA NOGRAV/.FALSE./ C C DATA FOR TYPES DATA LOC/100*0/,NTYP/100/ DATA NJTTYP/MXTYPE*0/ DATA (JETYP(1,JJJ),JJJ=1,MXTYPE)/MXTYPE*'ALL '/, $((JETYP(III,JJJ),III=2,30),JJJ=1,MXTYPE)/MXT29*' '/ DATA NWWTYP/2*0/ DATA (WWTYP(1,JJJ),JJJ=1,2)/2*'ALL '/, $((WWTYP(III,JJJ),III=2,30),JJJ=1,2)/58*' '/ DATA JWTYP/4/ C C DATA FOR PRIMAR DATA IDIN/1120,1120/ DATA NTRIES/1000/ DATA NSIGMA/20/ C C DATA FOR DKYTAB DATA LOOK/MXLOOK*0/ DATA CBR/MXDKY*0./ DATA MODE/MXDKY*0,MXDKY*0,MXDKY*0,MXDKY*0,MXDKY*0/ C C DATA FOR Q1Q2 DATA GOQ/MXGOQJ*.TRUE./ DATA GOALL/MXGOJ*.TRUE./ DATA GODY/.TRUE.,.FALSE.,.FALSE.,.TRUE./ DATA GOWW/50*.TRUE./,ALLWW/2*.TRUE./ DATA GOWMOD/MXGOWJ*.TRUE./ DATA WRTLHE/.FALSE./ C C DATA FOR WCON DATA MATCH/ $0,3,2,5,4,7,6,9,8,11,10,13,12,0,0,17,16,0,0,21,20,0,0,25,24, $0,5,0,0,2,0,8,7,0,0,12,11,0,17,0,0,14,21,0,0,18,25,0,0,22, $0,0,4,3,0,9,0,0,6,13,0,0,10,0,16,15,0,0,20,19,0,0,24,23,0, $0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,19,18,21,20,23,22,25,24/ DATA CUTOFF,CUTPOW/.200,1.0/ DATA WMASS/0.,80.2,80.2,91.19/ DATA WFUDGE/1.85/ C C DATA FOR TOTALS DATA NKINPT,NWGEN,NKEEP/3*0/,SUMWT/0./ C C DATA FOR DYLIM DATA BLIM1/12*-1.E9/ C C DATA FOR EEPAR DATA PLEP/0./,PLEM/0./,IBREM/.FALSE./,IBEAM/.FALSE./ DATA GAMGAM/.FALSE./ C C DATA FOR PARTCL DATA NPTCL/0/ C C DATA FOR PRTOUT DATA NEVPRT,NJUMP/1,1/ C C DATA FOR JETSET DATA NJSET/0/ C C DATA FOR QCDPAR DATA ALAM,ALAM2/.2,.04/,CUTJET/6./,ISTRUC/7/ C C DATA FOR FORCE DATA NFORCE/0/ C C DATA FOR NRECS DATA NRECS/0/ C C DATA FOR KEYS DATA KEYS/MXKEYS*.FALSE./ C C DATA FOR MATCHH DATA MATCHH/ $1,3,2,5,4,7,6,9,8,11,10,13,12, $15,14,17,16,19,18,21,20,23,22,25,24, $26,28,27,29/ DATA USELIM/.FALSE./ DATA CONCUT/1.0/ C C DATA FOR SUGXIN DATA XSUGIN/7*0/ DATA XNRIN/0.,1.E20,0.,0./ C C DATA FOR SSPAR DATA AMGVSS/1.E20/,GORGE/.FALSE./ C C DATA FOR XMSSM DATA GOMSSM/.FALSE./,GOSUG/.FALSE./,GOGMSB/.FALSE./ DATA GOAMSB/.FALSE./,GOMMAM/.FALSE./,GOHCAM/.FALSE./ DATA AL3UNI/.FALSE./ DATA XM1SS,XM2SS/1.E20,1.E20/ DATA XMGVTO/1.E20/ DATA XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS/1.E20,1.E20,1.E20,1.E20,1.E20/ DATA XRSLGM,XDHDGM,XDHUGM,XDYGM/1.,0.,0.,0./ DATA XN51GM,XN52GM,XN53GM/0.,0.,0./ DATA XMN3NR/0./,XMAJNR/1.E20/,XANSS/0./,XNRSS/0./,XSBCS/0./ DATA XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM,XL1AM,XL2AM,XL3AM $/1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ C DATA FOR SUGNU DATA XNUSUG/20*1.E20/,INUHM/0/ C C DATA FOR ISAPW DATA ISAPW1/'ALDATA REQUIRED BY FORTRAN G,H'/ C C DATA FOR LISTSS DATA LISTSS/ISGL, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2, $ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4, $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,ISNTL,MSNTL, $ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,ISTAU2,MSTAU2, $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13, $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/ C C DATA FOR SSMODE DATA NSSMOD/0/ C END +EOD +PATCH,ISAJET. +EOD +DECK,ALQCD FUNCTION ALQCD(Q2) C----------------------------------------------------------------------- C Strong coupling formula from page 201 of Barger and Phillips: C (using ALQCD4 for 4 flavor Lambda) C----------------------------------------------------------------------- REAL Q2,AS,TH5,TH6,PI,ALQCD4 LOGICAL FIRST SAVE FIRST,PI,TH5,TH6,ALQCD4 DATA FIRST/.TRUE./ C IF(FIRST) THEN PI=4.*ATAN(1.) TH5=4*AMASS(5)**2 TH6=4*AMASS(6)**2 ALQCD4=0.177 FIRST=.FALSE. ENDIF IF (Q2.LE.TH5)THEN AS=12*PI/(25*LOG(Q2/ALQCD4**2)) ELSE IF(Q2.GT.TH5.AND.Q2.LE.TH6) THEN AS=25*LOG(Q2/ALQCD4**2)-2*LOG(Q2/TH5) AS=12*PI/AS ELSEIF(Q2.GT.TH6)THEN AS=25*LOG(Q2/ALQCD4**2) AS=AS-2*(LOG(Q2/TH5)+LOG(Q2/TH6)) AS=12*PI/AS ENDIF ALQCD=AS RETURN END +EOD +DECK,AMASS. FUNCTION AMASS(ID) C C Returns the mass of the particle with IDENT code ID. C Quark-based IDENT code. C Ver 7.10: Update masses and split B baryon degeneracy. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QLMASS +CDE,SSTYPE C INTEGER ID REAL AMASS REAL AMMES0(10),AMMES1(10),AMBAR0(30),AMBAR1(30) INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,IFL1A,IFL2A,IFL3A,IDA C C 0- meson mass table C pi0, pi+, eta, k+, k0, etap, ad0, d-, ds-, etac C DATA AMMES0/.13496,.13957,.54745,.49367,.49767,.95775,1.8645 $,1.8693,1.9688,2.9788/ C C 1- meson mass table C rho0, rho+, omega, k*+, k*0, phi, ad*0, d*-, d*s-, jpsi C DATA AMMES1/.7681,.7681,.78195,.89159,.89610,1.0194,2.0071 $,2.0101,2.1103,3.0969/ C C 1/2+ baryon mass table C x,p,n,-,-,s+,s0,s-,l,xi0,xi-,x,x,x C sc++,sc+,sc0,lc+,usc.,dsc.,ssc.,sdc.,suc.,ucc.,dcc.,scc. C DATA AMBAR0/-1.,.93828,.93957,2*-1.,1.1894,1.1925,1.1974 $,1.1156,1.3149,1.3213,3*-1.,2.4527,2.4529,2.4525,2.2849 $,2.50,2.50,2.60,2.40,2.40,3.55,3.55,3.70,4*-1./ C C 3/2+ baryon mass table C dl++,dl+,dl0,dl-,-,s*+,s*0,s*-,x,xi*0,xi*-,om-,x,x C uuc*,udc*,ddc*,x,usc*,dsc*,ssc*,x,x,,ucc*,dcc*,scc*,ccc* C DATA AMBAR1/1.232,1.232,1.232,1.232,-1.,1.3823,1.3820 $,1.3875,-1.,1.5318,1.5350,1.6722,2*-1. $,2.63,2.63,2.63,-1.,2.70,2.70,2.80,2*-1.,3.75,3.75 $,3.90,4.80,3*-1./ C C Entry C AMASS=-1. CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX) IDA=IABS(ID) IFL1A=IABS(IFL1) IFL2A=IABS(IFL2) IFL3A=IABS(IFL3) IF(IDA.GT.10000.OR.JSPIN.GT.1) GO TO 500 C C Diquarks C IF(ID.NE.0.AND.MOD(ID,100).EQ.0) THEN AMASS=AMLEP(IFL1A)+AMLEP(IFL2A) C C b and t particles. Only a few b masses are known, but we C guess a few others to make sure decays are allowed: C ELSEIF(IFL3A.GT.4) THEN IF(IDA.EQ.150.OR.IDA.EQ.250) THEN AMASS=5.2786 ELSEIF(IDA.EQ.151.OR.IDA.EQ.251) THEN AMASS=5.3246 ELSEIF(IDA.EQ.350) THEN AMASS=5.3693 ELSEIF(IDA.EQ.351) THEN AMASS=5.3693+0.04 ELSEIF(IDA.EQ.2150) THEN AMASS=5.641 ELSEIF(IDA.EQ.1150.OR.IDA.EQ.1250.OR.IDA.EQ.2250) THEN AMASS=5.641+0.171 ELSEIF(IDA.EQ.2151) THEN AMASS=5.641+.04 ELSEIF(IDA.EQ.1151.OR.IDA.EQ.1251.OR.IDA.EQ.2251) THEN AMASS=5.641+0.171+0.04 ELSE AMASS=AMLEP(IFL2A)+AMLEP(IFL3A)-.03+.04*JSPIN IF(IFL1.NE.0) AMASS=AMASS+AMLEP(IFL1A) ENDIF C C Quarks and leptons C ELSEIF(IFL2.EQ.0) THEN AMASS=AMLEP(INDEX) C C Mesons C ELSEIF(IFL1.EQ.0) THEN INDEX=INDEX-36*JSPIN-NQLEP INDEX=INDEX-13 AMASS=(1-JSPIN)*AMMES0(INDEX)+JSPIN*AMMES1(INDEX) C C Baryons C ELSE INDEX=INDEX-109*JSPIN-36*NMES-NQLEP INDEX=INDEX-13 AMASS=(1-JSPIN)*AMBAR0(INDEX)+JSPIN*AMBAR1(INDEX) ENDIF RETURN C C Special hadrons - used only in B decays C 500 IF(IDA.EQ.10121.OR.IDA.EQ.10111) THEN AMASS=1.230 ELSEIF(IDA.EQ.10131.OR.IDA.EQ.10231) THEN AMASS=1.273 ELSEIF(IDA.EQ.30131.OR.IDA.EQ.30231) THEN AMASS=1.412 ELSEIF(IDA.EQ.132) THEN AMASS=1.4254 ELSEIF(IDA.EQ.232) THEN AMASS=1.4324 ELSEIF(IDA.EQ.10110) THEN AMASS=0.980+0.020 ELSEIF(IDA.EQ.112) THEN AMASS=1.275 ELSEIF(IDA.EQ.10441) THEN AMASS=3.686 ELSEIF(IDA.EQ.20440) THEN AMASS=3.4151 ELSEIF(IDA.EQ.20441) THEN AMASS=3.51053 ELSEIF(IDA.EQ.20442) THEN AMASS=3.56617 ELSEIF(IDA.EQ.IDTAUL.OR.IDA.EQ.IDTAUR) THEN AMASS=AMLEP(16) ELSE AMASS=0 ENDIF RETURN END +EOD +DECK,AMGMW FUNCTION AMGMW(I,J) C C Get masses and widths from ISAJET commons for MadGraph C I = particle IDENT C J = 1 for mass C = 2 for width C = 3 for sin^2(theta) C Needed to avoid common block name clashes with MadGraph C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,WCON +CDE,HCON +CDE,SSTYPE INTEGER I,J REAL AMGMW,AMASS C IF(J.EQ.1) THEN AMGMW=AMASS(I) ELSEIF(J.EQ.2.AND.I.EQ.IDW) THEN AMGMW=WGAM(2) ELSEIF(J.EQ.2.AND.I.EQ.IDZ) THEN AMGMW=WGAM(4) ELSEIF(J.EQ.2.AND.I.EQ.IDH) THEN AMGMW=HGAM ELSEIF(J.EQ.3.AND.I.EQ.1) THEN AMGMW=SIN2W ELSE WRITE(ITLIS,*) 'ERROR IN AMGMW: I,J =',I,J STOP99 ENDIF RETURN END +EOD +DECK,CHARGE. FUNCTION CHARGE(ID) C C COMPUTE CHARGE OF PARTICLE WITH IDENT CODE ID C ICHRG MUST BE DIMENSIONED NQLEP+13 C +CDE,ITAPES DIMENSION ICHRG(75),IFL(3) C 3 * charge DATA ICHRG/0 $,2,-1,-1,2,-1,2,-1,2,0,0, 0,-3,0,-3,0,-3,0,-3,0,0,0 $,2,-1,-1,2,-1,2,-1,2,0,0, 0,-3,0,-3,0,-3,0,-3,3,0 $,2,-1,-1,2,-1,2,-1,2,3,0, 0,-3,0,-3,0,-3,0,-3,3,0 $,3,0,0,0,0,0,3,3,6,6,0,0,0/ C IDABS=IABS(ID) CALL FLAVOR(ID,IFL(1),IFL(2),IFL(3),JSPIN,INDEX) IF(IDABS.LT.100) GO TO 200 C ISUM=0 DO 100 I=1,3 ISUM=ISUM+ICHRG(IABS(IFL(I))+1)*ISIGN(1,IFL(I)) 100 CONTINUE CHARGE=ISUM/3. RETURN C 200 CHARGE=ICHRG(INDEX+1)*ISIGN(1,ID) CHARGE=CHARGE/3. RETURN END +EOD +DECK,COLR12 SUBROUTINE COLR12(I1,L1,I2,L2,I3,L3,ICOLOR) C C Set color flow lines for 1-> 2 decay C I1,I2,I3 = particle IDs C L1,L2,L3 = line number in PARTCL where they occur REAL X INTEGER I1,I2,I3,L1,L2,L3,ICOLOR(2,100) INTEGER J(3),IC(3),IC23 J(1)=I1 J(2)=I2 J(3)=I3 C Set QCD color labels DO I=1,3 IC(I)=1 IF (J(I).EQ.9.OR.J(I).EQ.29) THEN IC(I)=8 END IF IF ((J(I).GE.1.AND.J(I).LE.6).OR.(J(I).GE.21.AND.J(I).LE.26).OR. $(J(I).GE.41.AND.J(I).LE.46)) THEN IC(I)=3 END IF IF ((-J(I).GE.1.AND.-J(I).LE.6).OR.(-J(I).GE.21.AND.-J(I).LE.26) $.OR.(-J(I).GE.41.AND.-J(I).LE.46)) THEN IC(I)=-3 END IF END DO IC23=IC(2)*IC(3) C Do nothing for case of 1 -> 1 1 C 1 -> 3 -3 C Note: lines in ICOLOR offset from lines in PPTCL by 2 L1=L1+2 L2=L2+2 L3=L3+2 IF (IC(1).EQ.1.AND.IC(2).EQ.3) THEN ICOLOR(1,L2)=200+L1 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=200+L1 ELSE IF (IC(1).EQ.1.AND.IC(2).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=200+L1 ICOLOR(1,L3)=200+L1 ICOLOR(2,L3)=0 END IF C 3 -> 3 1 IF (IC(1).EQ.3.AND.IC23.EQ.3) THEN IF (IC(2).EQ.3) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ELSE IF (IC(2).EQ.1) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=0 END IF END IF C 3* -> 3* 1 IF (IC(1).EQ.-3.AND.IC23.EQ.-3) THEN IF (IC(2).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ELSE IF (IC(2).EQ.1) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=ICOLOR(2,L1) END IF END IF C 3 -> 3 8 IF (IC(1).EQ.3.AND.IC23.EQ.24) THEN IF (IC(2).EQ.3) THEN ICOLOR(1,L2)=200+L1 ICOLOR(2,L2)=0 ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=200+L1 ELSE IF (IC(2).EQ.8) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=200+L1 ICOLOR(1,L3)=200+L1 ICOLOR(2,L3)=0 END IF END IF C 3* -> 3* 8 IF (IC(1).EQ.-3.AND.IC23.EQ.-24) THEN IF (IC(2).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=200+L1 ICOLOR(1,L3)=200+L1 ICOLOR(2,L3)=ICOLOR(2,L1) ELSE IF (IC(2).EQ.8) THEN ICOLOR(1,L2)=200+L1 ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=0 ICOLOR(2,L3)=200+L1 END IF END IF C 8 -> 3 3* IF (IC(1).EQ.8.AND.IC(2).EQ.3) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=ICOLOR(2,L1) ELSE IF (IC(1).EQ.8.AND.IC(2).EQ.-3) THEN ICOLOR(1,L2)=O ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=0 END IF C 8 -> 8 1 IF (IC(1).EQ.8.AND.IC(2).EQ.8) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ELSE IF (IC(1).EQ.8.AND.IC(2).EQ.1) THEN ICOLOR(1,L2)=O ICOLOR(2,L2)=0 ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=ICOLOR(2,L1) END IF RETURN END +EOD +DECK,COLR13 SUBROUTINE COLR13(I1,L1,I2,L2,I3,L3,I4,L4,ICOLOR) C C Set color flow lines for 1-> 3 decay C I1,I2,I3,I4 = particle IDs C L1,L2,L3,L4 = line number in PARTCL where they occur C Isajet convention is that colored particles occur first C in any decay string INTEGER I1,I2,I3,I4,L1,L2,L3,L4,ICOLOR(2,100) INTEGER J(4),IC(4),IC12,IC34,IC23 J(1)=I1 J(2)=I2 J(3)=I3 J(4)=I4 C Set QCD color labels DO I=1,4 IC(I)=1 IF (J(I).EQ.9.OR.J(I).EQ.29) THEN IC(I)=8 END IF IF ((J(I).GE.1.AND.J(I).LE.6).OR.(J(I).GE.21.AND.J(I).LE.26).OR. $(J(I).GE.41.AND.J(I).LE.46)) THEN IC(I)=3 END IF IF ((-J(I).GE.1.AND.-J(I).LE.6).OR.(-J(I).GE.21.AND.-J(I).LE.26) $.OR.(-J(I).GE.41.AND.-J(I).LE.46)) THEN IC(I)=-3 END IF END DO C Do nothing for case of 1 -> 1 1 1 C 1 -> 3 3* 1 C Note lines in ICOLOR offset from PPTCL lines by 2 L1=L1+2 L2=L2+2 L3=L3+2 L4=L4+2 IC12=IC(1)*IC(2) IC34=IC(3)*IC(4) IC23=IC(2)*IC(3) IF (IC(1).EQ.1.AND.IC(2).EQ.3) THEN ICOLOR(1,L2)=300+L1 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=300+L1 ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 ELSE IF (IC(1).EQ.1.AND.IC(2).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=300+L1 ICOLOR(1,L3)=300+L1 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 END IF C 1 -> 1 3 3* IF (IC12.EQ.1.AND.IC(3).EQ.3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=300+L1 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=300+L1 ELSE IF (IC12.EQ.1.AND.IC(3).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=300+L1 ICOLOR(1,L4)=300+L1 ICOLOR(2,L4)=0 END IF C 3 -> 3 1 1 IF (IC(1).EQ.3.AND.IC(2).EQ.3.AND.IC34.EQ.1) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 END IF C 3* -> 3* 1 1 IF (IC(1).EQ.-3.AND.IC(2).EQ.-3.AND.IC34.EQ.1) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 END IF C 3 -> 3 3* 3 C These next two decays seem only necessary for top in isalhe, C which goes t-> q+qb+b in the Isajet decay table ISADECAY.DAT IF (IC(1).EQ.3.AND.IC(2).EQ.3.AND.IC34.EQ.-9) THEN ICOLOR(1,L2)=300+L1 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=300+L1 ICOLOR(1,L4)=ICOLOR(1,L1) ICOLOR(2,L4)=0 END IF C 3* -> 3* 3 3* IF (IC(1).EQ.-3.AND.IC(2).EQ.-3.AND.IC34.EQ.-9) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=300+L1 ICOLOR(1,L3)=300+L1 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=ICOLOR(2,L1) END IF C 3 -> 1 1 3 IF (IC(1).EQ.3.AND.IC(4).EQ.3.AND.IC23.EQ.1) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ICOLOR(1,L4)=ICOLOR(1,L1) ICOLOR(2,L4)=0 END IF C 3* -> 1 1 3* IF (IC(1).EQ.-3.AND.IC(4).EQ.-3.AND.IC23.EQ.1) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=ICOLOR(2,L1) END IF C 8 -> 3 3* 1 IF (IC(1).EQ.8.AND.IC(2).EQ.3) THEN ICOLOR(1,L2)=ICOLOR(1,L1) ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=ICOLOR(2,L1) ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 END IF C 8 -> 3* 3 1 IF (IC(1).EQ.8.AND.IC(2).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=ICOLOR(2,L1) ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=0 END IF C 8 -> 1 3 3* IF (IC12.EQ.8.AND.IC(3).EQ.3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=ICOLOR(1,L1) ICOLOR(2,L3)=0 ICOLOR(1,L4)=0 ICOLOR(2,L4)=ICOLOR(2,L1) END IF C 8 -> 1 3* 3 IF (IC12.EQ.8.AND.IC(3).EQ.-3) THEN ICOLOR(1,L2)=0 ICOLOR(2,L2)=0 ICOLOR(1,L3)=0 ICOLOR(2,L3)=ICOLOR(2,L1) ICOLOR(1,L4)=ICOLOR(1,L1) ICOLOR(2,L4)=0 END IF RETURN END +EOD +DECK,COLR22 SUBROUTINE COLR22(I1,I2,I3,I4,ICOLOR) C C Set color flow lines for 2-> 2 subprocesses C REAL X INTEGER I1,I2,I3,I4,IC12,IC34,ICOLOR(2,100) INTEGER J(4),IC(4) DO I=1,100 ICOLOR(1,I)=0 ICOLOR(2,I)=0 END DO J(1)=I1 J(2)=I2 J(3)=I3 J(4)=I4 DO I=1,4 IC(I)=1 IF (J(I).EQ.9.OR.J(I).EQ.29) THEN IC(I)=8 END IF IF ((J(I).GE.1.AND.J(I).LE.6).OR.(J(I).GE.21.AND.J(I).LE.26).OR. $(J(I).GE.41.AND.J(I).LE.46)) THEN IC(I)=3 END IF IF ((-J(I).GE.1.AND.-J(I).LE.6).OR.(-J(I).GE.21.AND.-J(I).LE.26) $.OR.(-J(I).GE.41.AND.-J(I).LE.46)) THEN IC(I)=-3 END IF END DO C Do nothing for case of 1 1 -> 1 1 C For now, Select random number to determine color flow X=RANF() IC12=IC(1)*IC(2) IC34=IC(3)*IC(4) C 1 1 -> 3 3* IF (IC12.EQ.1.AND.IC34.EQ.-9) THEN IF (IC(3).EQ.3) THEN ICOLOR(1,3)=101 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=101 ELSE IF (IC(3).EQ.-3) THEN ICOLOR(1,3)=0 ICOLOR(2,3)=101 ICOLOR(1,4)=101 ICOLOR(2,4)=0 END IF END IF C 3 3 -> 3 3 IF (IC12.EQ.9.AND.IC34.EQ.9.AND.IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=101 ICOLOR(2,3)=0 ICOLOR(1,4)=102 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=0 END IF END IF C 3* 3* -> 3* 3* IF (IC12.EQ.9.AND.IC34.EQ.9.AND.IC(3).EQ.-3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=101 ICOLOR(1,4)=0 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=101 END IF END IF C 3 3* -> 3 3* IF (IC12.EQ.-9.AND.IC34.EQ.-9) THEN IF (IC(1).EQ.3.AND.IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=101 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 END IF END IF IF (IC(1).EQ.3.AND.IC(4).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=102 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=101 ICOLOR(2,4)=0 END IF END IF IF (IC(2).EQ.3.AND.IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=101 END IF END IF IF (IC(2).EQ.3.AND.IC(4).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=0 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=102 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=0 ICOLOR(2,3)=101 ICOLOR(1,4)=102 ICOLOR(2,4)=0 END IF END IF END IF C 3 3* -> 1 1 IF (IC12.EQ.-9.AND.IC34.EQ.1) THEN IF (IC(1).EQ.3) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ELSE IF (IC(1).EQ.-3) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=0 END IF END IF C 3 3* -> 8 8 IF (IC12.EQ.-9.AND.IC34.EQ.64) THEN IF (IC(1).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=103 ICOLOR(2,3)=102 ICOLOR(1,4)=101 ICOLOR(2,4)=103 END IF END IF IF (IC(2).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=103 ICOLOR(2,3)=101 ICOLOR(1,4)=102 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=101 END IF END IF END IF C 3 3* -> 1 8 IF (IC12.EQ.-9.AND.IC34.EQ.8) THEN IF (IC(1).EQ.3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=102 ELSE IF (IC(1).EQ.3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=0 ICOLOR(2,2)=102 ICOLOR(1,3)=101 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=0 ELSE IF (IC(1).EQ.-3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=102 ICOLOR(2,4)=101 ELSE IF (IC(1).EQ.-3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=101 ICOLOR(1,4)=0 ICOLOR(2,4)=0 END IF END IF C 3 8 -> 1 3 IF (IC12.EQ.24.AND.IC34.EQ.3) THEN IF (IC(1).EQ.3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=102 ICOLOR(2,4)=0 ELSE IF (IC(1).EQ.3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=101 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=0 ELSE IF (IC(2).EQ.3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=0 ELSE IF (IC(2).EQ.3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=101 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=0 END IF END IF C 3* 8 -> 1 3* IF (IC12.EQ.-24.AND.IC34.EQ.-3) THEN IF (IC(1).EQ.-3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 ELSE IF (IC(1).EQ.-3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=0 ELSE IF (IC(2).EQ.-3.AND.IC(3).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 ELSE IF (IC(2).EQ.-3.AND.IC(4).EQ.1) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=0 END IF END IF C 3 8 -> 3 8 IF (IC12.EQ.24.AND.IC34.EQ.24) THEN IF (IC(1).EQ.3.AND.IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=101 ICOLOR(1,3)=103 ICOLOR(2,3)=0 ICOLOR(1,4)=102 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=103 END IF END IF IF (IC(1).EQ.3.AND.IC(4).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=101 ICOLOR(1,3)=102 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=0 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=102 ICOLOR(2,4)=0 END IF END IF IF (IC(2).EQ.3.AND.IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=103 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=102 ICOLOR(2,1)=103 ICOLOR(1,2)=101 ICOLOR(2,2)=0 ICOLOR(1,3)=102 ICOLOR(2,3)=0 ICOLOR(1,4)=101 ICOLOR(2,4)=103 END IF END IF IF (IC(2).EQ.3.AND.IC(4).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=0 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=102 ICOLOR(2,1)=103 ICOLOR(1,2)=101 ICOLOR(2,2)=0 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=102 ICOLOR(2,4)=0 END IF END IF END IF C 3* 8 -> 3* 8 IF (IC12.EQ.-24.AND.IC34.EQ.-24) THEN IF (IC(1).EQ.-3.AND.IC(3).EQ.-3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=102 ICOLOR(1,3)=0 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=0 ICOLOR(2,3)=103 ICOLOR(1,4)=102 ICOLOR(2,4)=101 END IF END IF IF (IC(1).EQ.-3.AND.IC(4).EQ.-3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=101 ICOLOR(2,2)=102 ICOLOR(1,3)=103 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=0 ICOLOR(2,1)=101 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=102 ICOLOR(2,3)=101 ICOLOR(1,4)=0 ICOLOR(2,4)=103 END IF END IF IF (IC(2).EQ.-3.AND.IC(3).EQ.-3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=102 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=103 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=101 ICOLOR(2,4)=103 END IF END IF IF (IC(2).EQ.-3.AND.IC(4).EQ.-3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=101 ICOLOR(1,3)=103 ICOLOR(2,3)=102 ICOLOR(1,4)=0 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=0 ICOLOR(2,2)=103 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=0 ICOLOR(2,4)=102 END IF END IF END IF C 8 8 -> 3 3* IF (IC12.EQ.64.AND.IC34.EQ.-9) THEN IF (IC(3).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=101 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=103 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=103 ICOLOR(2,2)=101 ICOLOR(1,3)=103 ICOLOR(2,3)=0 ICOLOR(1,4)=0 ICOLOR(2,4)=102 END IF END IF IF (IC(4).EQ.3) THEN IF (X.LT..5) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=0 ICOLOR(2,3)=103 ICOLOR(1,4)=101 ICOLOR(2,4)=0 ELSE ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=103 ICOLOR(2,2)=101 ICOLOR(1,3)=0 ICOLOR(2,3)=102 ICOLOR(1,4)=103 ICOLOR(2,4)=0 END IF END IF END IF C 8 8 -> 8 8 IF (IC12.EQ.64.AND.IC34.EQ.64) THEN IF (X.LT..167) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=103 ICOLOR(2,2)=101 ICOLOR(1,3)=104 ICOLOR(2,3)=102 ICOLOR(1,4)=103 ICOLOR(2,4)=104 ELSE IF (X.GE..167.AND.X.LT..334) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=101 ICOLOR(2,3)=104 ICOLOR(1,4)=104 ICOLOR(2,4)=103 ELSE IF (X.GE..334.AND.X.LT..501) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=103 ICOLOR(2,2)=104 ICOLOR(1,3)=103 ICOLOR(2,3)=102 ICOLOR(1,4)=101 ICOLOR(2,4)=104 ELSE IF (X.GE..501.AND.X.LT..668) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=103 ICOLOR(2,2)=101 ICOLOR(1,3)=103 ICOLOR(2,3)=104 ICOLOR(1,4)=104 ICOLOR(2,4)=102 ELSE IF (X.GE..668.AND.X.LT..825) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=104 ICOLOR(2,2)=103 ICOLOR(1,3)=101 ICOLOR(2,3)=103 ICOLOR(1,4)=104 ICOLOR(2,4)=102 ELSE IF (X.GE..825.AND.X.LE.1.) THEN ICOLOR(1,1)=101 ICOLOR(2,1)=102 ICOLOR(1,2)=102 ICOLOR(2,2)=103 ICOLOR(1,3)=104 ICOLOR(2,3)=103 ICOLOR(1,4)=101 ICOLOR(2,4)=104 END IF END IF RETURN END +EOD +DECK,CTEQ5L DOUBLE PRECISION FUNCTION CTEQ5L(IFL,X,Q) C ---------------------------------------------------------------------- C Parameterization of CTEQ5l parton distributions f(ifl,x,q) C IFL: 1=u,2=d,3=s,4=c,5=b C 0=g C -1=ubar,-2=dbar,-3=sbar,-4=cbar,-5=bbar C Was faux5l by J. Pumplin, 9/99 C Converted to strict Fortran 77 and Patchy by F. Paige C ---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF DOUBLE PRECISION X,Q INTEGER IFL INTEGER NEX,NLF PARAMETER (NEX=8, NLF=2) DOUBLE PRECISION AM(0:NEX,0:NLF,-5:2) DOUBLE PRECISION ALFVEC(-5:2), QMAVEC(-5:2) DOUBLE PRECISION MEXVEC(-5:2) DOUBLE PRECISION UT1VEC(-5:2), UT2VEC(-5:2) DOUBLE PRECISION AF(0:NEX) DOUBLE PRECISION TMP,SB,SB1,SB2,SBX,Y,U,PART1,PART2,PART3,PART4 INTEGER MLFVEC(-5:2) INTEGER I,K C DATA MEXVEC( 2) / 8 / DATA MLFVEC( 2) / 2 / DATA UT1VEC( 2) / 0.4971265E+01 / DATA UT2VEC( 2) / -0.1105128E+01 / DATA ALFVEC( 2) / 0.2987216E+00 / DATA QMAVEC( 2) / 0.0000000E+00 / DATA (AM( 0,K, 2),K=0, 2) $ / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 / DATA (AM( 1,K, 2),K=0, 2) $ / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 / DATA (AM( 2,K, 2),K=0, 2) $ / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 / DATA (AM( 3,K, 2),K=0, 2) $ / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 / DATA (AM( 4,K, 2),K=0, 2) $ / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 / DATA (AM( 5,K, 2),K=0, 2) $ / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 / DATA (AM( 6,K, 2),K=0, 2) $ / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 / DATA (AM( 7,K, 2),K=0, 2) $ / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 / DATA (AM( 8,K, 2),K=0, 2) $ / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 / C DATA MEXVEC( 1) / 8 / DATA MLFVEC( 1) / 2 / DATA UT1VEC( 1) / 0.2612618E+01 / DATA UT2VEC( 1) / -0.1258304E+06 / DATA ALFVEC( 1) / 0.3407552E+00 / DATA QMAVEC( 1) / 0.0000000E+00 / DATA (AM( 0,K, 1),K=0, 2) $ / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 / DATA (AM( 1,K, 1),K=0, 2) $ / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 / DATA (AM( 2,K, 1),K=0, 2) $ / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 / DATA (AM( 3,K, 1),K=0, 2) $ / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 / DATA (AM( 4,K, 1),K=0, 2) $ / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 / DATA (AM( 5,K, 1),K=0, 2) $ / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 / DATA (AM( 6,K, 1),K=0, 2) $ / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 / DATA (AM( 7,K, 1),K=0, 2) $ / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 / DATA (AM( 8,K, 1),K=0, 2) $ / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 / C DATA MEXVEC( 0) / 8 / DATA MLFVEC( 0) / 2 / DATA UT1VEC( 0) / -0.4656819E+00 / DATA UT2VEC( 0) / -0.2742390E+03 / DATA ALFVEC( 0) / 0.4491863E+00 / DATA QMAVEC( 0) / 0.0000000E+00 / DATA (AM( 0,K, 0),K=0, 2) $ / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 / DATA (AM( 1,K, 0),K=0, 2) $ / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 / DATA (AM( 2,K, 0),K=0, 2) $ / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 / DATA (AM( 3,K, 0),K=0, 2) $ / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 / DATA (AM( 4,K, 0),K=0, 2) $ / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 / DATA (AM( 5,K, 0),K=0, 2) $ / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 / DATA (AM( 6,K, 0),K=0, 2) $ / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 / DATA (AM( 7,K, 0),K=0, 2) $ / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 / DATA (AM( 8,K, 0),K=0, 2) $ / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 / C DATA MEXVEC(-1) / 8 / DATA MLFVEC(-1) / 2 / DATA UT1VEC(-1) / 0.3862583E+01 / DATA UT2VEC(-1) / -0.1265969E+01 / DATA ALFVEC(-1) / 0.2457668E+00 / DATA QMAVEC(-1) / 0.0000000E+00 / DATA (AM( 0,K,-1),K=0, 2) $ / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 / DATA (AM( 1,K,-1),K=0, 2) $ / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 / DATA (AM( 2,K,-1),K=0, 2) $ / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 / DATA (AM( 3,K,-1),K=0, 2) $ / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 / DATA (AM( 4,K,-1),K=0, 2) $ / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 / DATA (AM( 5,K,-1),K=0, 2) $ / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 / DATA (AM( 6,K,-1),K=0, 2) $ / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 / DATA (AM( 7,K,-1),K=0, 2) $ / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 / DATA (AM( 8,K,-1),K=0, 2) $ / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 / C DATA MEXVEC(-2) / 7 / DATA MLFVEC(-2) / 2 / DATA UT1VEC(-2) / 0.1895615E+00 / DATA UT2VEC(-2) / -0.3069097E+01 / DATA ALFVEC(-2) / 0.5293999E+00 / DATA QMAVEC(-2) / 0.0000000E+00 / DATA (AM( 0,K,-2),K=0, 2) $ / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 / DATA (AM( 1,K,-2),K=0, 2) $ / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 / DATA (AM( 2,K,-2),K=0, 2) $ / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 / DATA (AM( 3,K,-2),K=0, 2) $ / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 / DATA (AM( 4,K,-2),K=0, 2) $ / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 / DATA (AM( 5,K,-2),K=0, 2) $ / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 / DATA (AM( 6,K,-2),K=0, 2) $ / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 / DATA (AM( 7,K,-2),K=0, 2) $ / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 / C DATA MEXVEC(-3) / 7 / DATA MLFVEC(-3) / 2 / DATA UT1VEC(-3) / 0.3753257E+01 / DATA UT2VEC(-3) / -0.1113085E+01 / DATA ALFVEC(-3) / 0.3713141E+00 / DATA QMAVEC(-3) / 0.0000000E+00 / DATA (AM( 0,K,-3),K=0, 2) $ / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 / DATA (AM( 1,K,-3),K=0, 2) $ / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 / DATA (AM( 2,K,-3),K=0, 2) $ / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 / DATA (AM( 3,K,-3),K=0, 2) $ / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 / DATA (AM( 4,K,-3),K=0, 2) $ / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 / DATA (AM( 5,K,-3),K=0, 2) $ / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 / DATA (AM( 6,K,-3),K=0, 2) $ / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 / DATA (AM( 7,K,-3),K=0, 2) $ / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 / C DATA MEXVEC(-4) / 7 / DATA MLFVEC(-4) / 2 / DATA UT1VEC(-4) / 0.4400772E+01 / DATA UT2VEC(-4) / -0.1356116E+01 / DATA ALFVEC(-4) / 0.3712017E-01 / DATA QMAVEC(-4) / 0.1300000E+01 / DATA (AM( 0,K,-4),K=0, 2) $ / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 / DATA (AM( 1,K,-4),K=0, 2) $ / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 / DATA (AM( 2,K,-4),K=0, 2) $ / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 / DATA (AM( 3,K,-4),K=0, 2) $ / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 / DATA (AM( 4,K,-4),K=0, 2) $ / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 / DATA (AM( 5,K,-4),K=0, 2) $ / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 / DATA (AM( 6,K,-4),K=0, 2) $ / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 / DATA (AM( 7,K,-4),K=0, 2) $ / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 / C DATA MEXVEC(-5) / 6 / DATA MLFVEC(-5) / 2 / DATA UT1VEC(-5) / 0.5562568E+01 / DATA UT2VEC(-5) / -0.1801317E+01 / DATA ALFVEC(-5) / 0.4952010E-02 / DATA QMAVEC(-5) / 0.4500000E+01 / DATA (AM( 0,K,-5),K=0, 2) $ / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 / DATA (AM( 1,K,-5),K=0, 2) $ / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 / DATA (AM( 2,K,-5),K=0, 2) $ / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 / DATA (AM( 3,K,-5),K=0, 2) $ / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 / DATA (AM( 4,K,-5),K=0, 2) $ / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 / DATA (AM( 5,K,-5),K=0, 2) $ / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 / DATA (AM( 6,K,-5),K=0, 2) $ / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 / C IF(Q.LE.QMAVEC(IFL).OR.X.GE.1D0) THEN CTEQ5L = 0.D0 RETURN ENDIF TMP = LOG(Q/ALFVEC(IFL)) IF(TMP .LE. 0.D0) THEN CTEQ5L = 0.D0 RETURN ENDIF SB = LOG(TMP) SB1 = SB - 1.2D0 SB2 = SB1*SB1 DO 100 I = 0, NEX AF(I) = 0.D0 SBX = 1.D0 DO 110 K = 0, MLFVEC(IFL) AF(I) = AF(I) + SBX*AM(I,K,IFL) SBX = SB1*SBX 110 CONTINUE 100 CONTINUE Y = -LOG(X) U = LOG(X/0.00001D0) PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) PART2 = AF(0)*(1.D0 - X) + AF(3)*X PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) PART4 = UT1VEC(IFL)*LOG(1.D0-X) + $ AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) CTEQ5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) C Include threshold factor... CTEQ5L = CTEQ5L * (1.D0 - QMAVEC(IFL)/Q) C RETURN END +EOD +DECK,CTXC2I SUBROUTINE CTXC2I(CVAL,IVAL,NSIZE) C----------------------------------------------------------------------- C Convert character variable CVAL to integer array IVAL C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF CHARACTER*(*) CVAL INTEGER I,NSIZE INTEGER IVAL(NSIZE) C DO 100 I=1,NSIZE 100 IVAL(I)=ICHAR(CVAL(I:I)) C RETURN END +EOD +DECK,CTXI2C SUBROUTINE CTXI2C(IVAL,CVAL,NSIZE) C----------------------------------------------------------------------- C Convert integer array IVAL to character variable CVAL C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF CHARACTER*(*) CVAL INTEGER I,NSIZE INTEGER IVAL(NSIZE) C DO 100 I=1,NSIZE 100 CVAL(I:I)=CHAR(IVAL(I)) C RETURN END +EOD +DECK,CTXIN SUBROUTINE CTXIN(NVC,VC,MXVC) C----------------------------------------------------------------------- C Purpose: C Restore the context for an ISAJET job: C Restore NVC words of VC all common blocks NOT associated only C with a single event. Call CTXOUT and this to generate mixed C events. C PARAMETER (MXVC=20000) C REAL VC(MXVC) C ... C CALL CTXIN(NVC,VC,MXVC) C C Note that the MSSM common blocks are not saved, so different C SUSY runs cannot be mixed. C C Ver. 7.02: Equivalenced dummy variables to avoid mixed C arguments in MOVLEV or multiple EQUIVALENCEd C arguments to CTXIN/CTXOUT. C C Author: C F.E. Paige, April 1992 C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,DKYTAB +CDE,DYLIM +CDE,DYPAR +CDE,EEPAR +CDE,FINAL +CDE,FORCE +CDE,FRGPAR +CDE,HCON +CDE,IDRUN +CDE,ISLOOP +CDE,ITAPES +CDE,JETLIM +CDE,KEYS +CDE,LIMEVL +CDE,LSTPRT +CDE,MBGEN +CDE,MBPAR +CDE,NODCAY +CDE,PRIMAR +CDE,PRTOUT +CDE,PTPAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,QLMASS +CDE,TCPAR +CDE,TIMES +CDE,TOTALS +CDE,TYPES +CDE,WCON C INTEGER NVC,MXVC,NC,NN,I REAL VC(MXVC) CHARACTER*8 CLIST(290) EQUIVALENCE (CLIST(1),PARTYP(1)) C C Dummy real variables for integers REAL VLOOK(MXLOOK+6*MXDKY) EQUIVALENCE (VLOOK(1),LOOK(1)) REAL VNKINF(5) EQUIVALENCE (VNKINF(1),NKINF) REAL VFORCE(9*MXFORC+1) EQUIVALENCE (VFORCE(1),NFORCE) REAL VIDVER(5) EQUIVALENCE (VIDVER(1),IDVER) REAL VEVOLV(4) EQUIVALENCE (VEVOLV(1),NEVOLV) REAL VITDKY(4) EQUIVALENCE (VITDKY(1),ITDKY) REAL VIKEYS(12) EQUIVALENCE (VIKEYS(1),IKEYS) REAL VSTPRT EQUIVALENCE (VSTPRT,LSTPRT) REAL VNJET(9) EQUIVALENCE (VNJET(1),NJET) REAL VEVPRT(2) EQUIVALENCE (VEVPRT(1),NEVPRT) REAL VKINPT(5) EQUIVALENCE (VKINPT(1),NKINPT) REAL VLOC(100) EQUIVALENCE (VLOC(1),LOC(1)) C Dummy real variables for logicals REAL VFLW(13) EQUIVALENCE (VFLW(1),FLW) REAL VNODCY(6) EQUIVALENCE (VNODCY(1),NODCAY) REAL VGOQ(3*MXGOQ+135) EQUIVALENCE (VGOQ(1),GOQ(1,1)) C NC=0 C DKYTAB NN=MXLOOK+6*MXDKY CALL MOVLEV(VC(NC+1),VLOOK(1),NN) NC=NC+NN C DYLIM CALL MOVLEV(VC(NC+1),QMIN,24) NC=NC+24 C DYPAR CALL MOVLEV(VC(NC+1),VFLW(1),13) NC=NC+13 C EEPAR CALL MOVLEV(VC(NC+1),SGMXEE,1) NC=NC+1 C FINAL CALL MOVLEV(VC(NC+1),VNKINF(1),5) NC=NC+5 C FORCE NN=9*MXFORC+1 CALL MOVLEV(VC(NC+1),VFORCE(1),NN) NC=NC+NN C FRGPAR CALL MOVLEV(VC(NC+1),PUD,41) NC=NC+41 C HCON CALL MOVLEV(VC(NC+1),HMASS,69) NC=NC+69 C IDRUN CALL MOVLEV(VC(NC+1),VIDVER(1),5) NC=NC+5 C ISLOOP CALL MOVLEV(VC(NC+1),VEVOLV(1),4) NC=NC+4 C ITAPES CALL MOVLEV(VC(NC+1),VITDKY(1),4) NC=NC+4 C JETLIM CALL MOVLEV(VC(NC+1),PMIN(1),72) NC=NC+72 C KEYS CALL MOVLEV(VC(NC+1),VIKEYS(1),12) NC=NC+12 CALL CTXI2C(VC(NC+1),REAC,8) NC=NC+8 C LIMEVL CALL MOVLEV(VC(NC+1),ETTHRS,3) NC=NC+3 C LSTPRT CALL MOVLEV(VC(NC+1),VSTPRT,1) NC=NC+1 C MBGEN NN=4*LIMPOM+8 CALL MOVLEV(VC(NC+1),POMWT(1),NN) NC=NC+NN C MBPAR CALL MOVLEV(VC(NC+1),PUD0,19) NC=NC+19 C NODCAY CALL MOVLEV(VC(NC+1),VNODCY(1),6) NC=NC+6 C PRIMAR CALL MOVLEV(VC(NC+1),VNJET(1),9) NC=NC+9 C PRTOUT CALL MOVLEV(VC(NC+1),VEVPRT(1),2) NC=NC+2 C PTPAR CALL MOVLEV(VC(NC+1),PTFUN1,6) NC=NC+6 C Q1Q2 CALL MOVLEV(VC(NC+1),VGOQ(1),3*MXGOQ+135) NC=NC+3*MXGOQ+135 C QCDPAR CALL MOVLEV(VC(NC+1),ALAM,4) NC=NC+4 C QLMASS CALL MOVLEV(VC(NC+1),AMLEP(1),55) NC=NC+55 C TCPAR CALL MOVLEV(VC(NC+1),TCMRHO,2) NC=NC+2 C TIMES CALL MOVLEV(VC(NC+1),TIME1,2) NC=NC+2 C TOTALS CALL MOVLEV(VC(NC+1),VKINPT(1),5) NC=NC+5 C TYPES CALL MOVLEV(VC(NC+1),VLOC(1),100) NC=NC+100 DO 100 I=1,290 CALL CTXI2C(VC(NC+1),CLIST(I),8) NC=NC+8 100 CONTINUE C WCON +SELF,IF=SINGLE NN=514 +SELF,IF=DOUBLE NN=514+97 +SELF CALL MOVLEV(VC(NC+1),SIN2W,NN) NC=NC+NN C NVC=NC RETURN END +EOD +DECK,CTXOUT SUBROUTINE CTXOUT(NVC,VC,MXVC) C----------------------------------------------------------------------- C Purpose: C Save the context for an ISAJET job: C Save in NVC words of VC all common blocks NOT associated only C with a single event. Call this and CTXIN to generate mixed C events. C PARAMETER (MXVC=20000) C REAL VC(MXVC) C ... C CALL CTXIN(NVC,VC,MXVC) C C Note that the MSSM common blocks are not saved, so different C SUSY runs cannot be mixed. C C Ver. 7.02: Equivalenced dummy variables to avoid mixed C arguments in MOVLEV or multiple EQUIVALENCEd C arguments to CTXIN/CTXOUT. C C Author: C F.E. Paige, April 1992 C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,DKYTAB +CDE,DYLIM +CDE,DYPAR +CDE,EEPAR +CDE,FINAL +CDE,FORCE +CDE,FRGPAR +CDE,HCON +CDE,IDRUN +CDE,ISLOOP +CDE,ITAPES +CDE,JETLIM +CDE,KEYS +CDE,LIMEVL +CDE,LSTPRT +CDE,MBGEN +CDE,MBPAR +CDE,NODCAY +CDE,PRIMAR +CDE,PRTOUT +CDE,PTPAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,QLMASS +CDE,TCPAR +CDE,TIMES +CDE,TOTALS +CDE,TYPES +CDE,WCON C INTEGER NVC,MXVC,NC,NN,I REAL VC(MXVC) CHARACTER*8 CLIST(290) EQUIVALENCE (CLIST(1),PARTYP(1)) C C Dummy real variables for integers REAL VLOOK(MXLOOK+6*MXDKY) EQUIVALENCE (VLOOK(1),LOOK(1)) REAL VNKINF(5) EQUIVALENCE (VNKINF(1),NKINF) REAL VFORCE(9*MXFORC+1) EQUIVALENCE (VFORCE(1),NFORCE) REAL VIDVER(5) EQUIVALENCE (VIDVER(1),IDVER) REAL VEVOLV(4) EQUIVALENCE (VEVOLV(1),NEVOLV) REAL VITDKY(4) EQUIVALENCE (VITDKY(1),ITDKY) REAL VIKEYS(12) EQUIVALENCE (VIKEYS(1),IKEYS) REAL VSTPRT EQUIVALENCE (VSTPRT,LSTPRT) REAL VNJET(9) EQUIVALENCE (VNJET(1),NJET) REAL VEVPRT(2) EQUIVALENCE (VEVPRT(1),NEVPRT) REAL VKINPT(5) EQUIVALENCE (VKINPT(1),NKINPT) REAL VLOC(100) EQUIVALENCE (VLOC(1),LOC(1)) C Dummy real variables for logicals REAL VFLW(13) EQUIVALENCE (VFLW(1),FLW) REAL VNODCY(6) EQUIVALENCE (VNODCY(1),NODCAY) REAL VGOQ(3*MXGOQ+135) EQUIVALENCE (VGOQ(1),GOQ(1,1)) C NC=0 C DKYTAB NN=MXLOOK+6*MXDKY CALL MOVLEV(VLOOK(1),VC(NC+1),NN) NC=NC+NN C DYLIM CALL MOVLEV(QMIN,VC(NC+1),24) NC=NC+24 C DYPAR CALL MOVLEV(VFLW(1),VC(NC+1),13) NC=NC+13 C EEPAR CALL MOVLEV(SGMXEE,VC(NC+1),1) NC=NC+1 C FINAL CALL MOVLEV(VNKINF(1),VC(NC+1),5) NC=NC+5 C FORCE NN=9*MXFORC+1 CALL MOVLEV(VFORCE(1),VC(NC+1),NN) NC=NC+NN C FRGPAR CALL MOVLEV(PUD,VC(NC+1),41) NC=NC+41 C HCON CALL MOVLEV(HMASS,VC(NC+1),69) NC=NC+69 C IDRUN CALL MOVLEV(VIDVER(1),VC(NC+1),5) NC=NC+5 C ISLOOP CALL MOVLEV(VEVOLV(1),VC(NC+1),4) NC=NC+4 C ITAPES CALL MOVLEV(VITDKY(1),VC(NC+1),4) NC=NC+4 C JETLIM CALL MOVLEV(PMIN(1),VC(NC+1),72) NC=NC+72 C KEYS CALL MOVLEV(VIKEYS(1),VC(NC+1),12) NC=NC+12 CALL CTXC2I(REAC,VC(NC+1),8) NC=NC+8 C LIMEVL CALL MOVLEV(ETTHRS,VC(NC+1),3) NC=NC+3 C LSTPRT CALL MOVLEV(VSTPRT,VC(NC+1),1) NC=NC+1 C MBGEN NN=4*LIMPOM+8 CALL MOVLEV(POMWT(1),VC(NC+1),NN) NC=NC+NN C MBPAR CALL MOVLEV(PUD0,VC(NC+1),19) NC=NC+19 C NODCAY CALL MOVLEV(VNODCY(1),VC(NC+1),6) NC=NC+6 C PRIMAR CALL MOVLEV(VNJET(1),VC(NC+1),9) NC=NC+9 C PRTOUT CALL MOVLEV(VEVPRT(1),VC(NC+1),2) NC=NC+2 C PTPAR CALL MOVLEV(PTFUN1,VC(NC+1),6) NC=NC+6 C Q1Q2 CALL MOVLEV(VGOQ(1),VC(NC+1),3*MXGOQ+135) NC=NC+3*MXGOQ+135 C QCDPAR CALL MOVLEV(ALAM,VC(NC+1),4) NC=NC+4 C QLMASS CALL MOVLEV(AMLEP(1),VC(NC+1),55) NC=NC+55 C TCPAR CALL MOVLEV(TCMRHO,VC(NC+1),2) NC=NC+2 C TIMES CALL MOVLEV(TIME1,VC(NC+1),2) NC=NC+2 C TOTALS CALL MOVLEV(VKINPT(1),VC(NC+1),5) NC=NC+5 C TYPES CALL MOVLEV(VLOC(1),VC(NC+1),100) NC=NC+100 DO 100 I=1,290 CALL CTXC2I(CLIST(I),VC(NC+1),8) NC=NC+8 100 CONTINUE C WCON +SELF,IF=SINGLE NN=514 +SELF,IF=DOUBLE NN=514+97 +SELF CALL MOVLEV(SIN2W,VC(NC+1),NN) NC=NC+NN C IF(NC.LE.MXVC) THEN NVC=NC RETURN ELSE WRITE(ITLIS,9000) NC 9000 FORMAT(//' ERROR IN CTXOUT, NC = ',I5) STOP99 ENDIF END +EOD +DECK,DATIME,IF=VAX,IF=NOCERN. SUBROUTINE DATIME(ID,IT) C CALL VAX DATE AND TIME. +CDE,ITAPES CHARACTER*8 BUF CALL IDATE(IMON,IDAY,IYR) CALL TIME(BUF) ID=10000*IYR+100*IMON+IDAY READ(BUF,'(I2,1X,I2,1X,I2)') K1,K2,K3 IT=10000*K1+100*K2+K3 RETURN END +EOD +DECK,DBLDOT. +EOD +DECK,DBLPCM. FUNCTION DBLPCM(A,B,C) C Calculate com momentum for A-->B+C with double precision. C Needed to fix bug on 32-bit machines at high energy. C Ver. 7.27: Rewrite order and then take abs value to be sure. +CDE,ITAPES +SELF,IF=DOUBLE. DOUBLE PRECISION DA,DB,DC,DVAL +SELF. C Convert to double precision DA=A DB=B DC=C DVAL=(DA-(DB+DC))*(DA+(DB+DC))*(DA-(DB-DC))*(DA+(DB-DC)) C Convert back to single precision VAL=DVAL DBLPCM=SQRT(ABS(VAL))/(2.*A) RETURN END +EOD +DECK,DBLVEC SUBROUTINE DBLVEC(P,DP) C C Calculate double precision vector DP for 5-vector P. C Exact components are 1,2,5 and larger of +,- C Ver 6.44: Always use this, even if IF=SINGLE. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL P(5) DOUBLE PRECISION DP(5),DPPL,DPMN INTEGER K C DO 100 K=1,5 100 DP(K)=P(K) IF(DP(4)+ABS(DP(3)).EQ.0.) RETURN IF(DP(3).GT.0.) THEN DPPL=DP(4)+DP(3) DPMN=(DP(1)**2+DP(2)**2+DP(5)**2)/DPPL ELSE DPMN=DP(4)-DP(3) DPPL=(DP(1)**2+DP(2)**2+DP(5)**2)/DPMN ENDIF DP(3)=0.5D0*(DPPL-DPMN) DP(4)=0.5D0*(DPPL+DPMN) RETURN END +EOD +DECK,DBOOST. SUBROUTINE DBOOST(ISIGN,F,P) C C DOUBLE PRECISION BOOST OF 5-VECTOR P BY 5-VECTOR F WITH SIGN C OF ISIGN. EXACT COMPONENTS ARE 1,2,5 AND LARGER OF +,- C DIMENSION F(5),P(5) DOUBLE PRECISION DF(5),DFPL,DFMN,DP(5),DPPL,DPMN,DBP,DSIGN C COPY TO DOUBLE PRECISION DO 100 K=1,5 DF(K)=F(K) 100 DP(K)=P(K) IF(ISIGN.GT.0) THEN DSIGN=1.D0 ELSE DSIGN=-1.D0 ENDIF C PUT ON DOUBLE PRECISION SHELL CALL DBLVEC(P,DP) C BOOST DBP=0.D0 DO 110 K=1,3 110 DBP=DBP+DF(K)*DP(K) DBP=DBP/DF(5) DO 120 K=1,3 120 DP(K)=DP(K)+DSIGN*DF(K)*DP(4)/DF(5)+DF(K)*DBP/(DF(4)+DF(5)) DP(4)=DF(4)*DP(4)/DF(5)+DSIGN*DBP C COPY BACK DO 130 K=1,4 130 P(K)=DP(K) RETURN END +EOD +DECK,DECAY SUBROUTINE DECAY(IP) C C Decay particle IP from /PARTCL/ using /DKYTAB/ branching C ratios and add decay products to /PARTCL/ with IORIG=IP. C Forced decay modes are flagged by LOOK<0. C C Auxiliary routines: C DECPS1: generate masses for phase space C DECPS2: generate 2-body decays and boosts for phase space C DECVA: V-A matrix elements C DECTAU: tau decay matrix elements with polarization C DECSS3: 3-body SUSY matrix element using /DKYSS3/ C DECJET: Hadronize partons from decay. C C Matrix element for Dalitz decays and W mass for TP -> W BT C are generated explicitly. W width is included. C C Requirements for decay modes: C (1) For Dalitz decays, particle 1 must be GM. C (2) For V-A quark or lepton decays, particles 1 and 2 must C be from (virtual) W. C (3) For any decay into quarks, they must appear last. C C Matrix element flags: C MELEM=0 phase space C 1 Dalitz C 2 omega/phi C 3 V-A C 4 top C 5 tau -> e nu nu C 6 tau -> pi nu C 7 tau -> rho nu C 8 tau -> tau (for NOTAU) C 9 H -> W f fbar C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,WCON +CDE,PARTCL +CDE,DKYTAB +CDE,JETSET +CDE,JWORK +CDE,CONST +CDE,PRIMAR +CDE,IDRUN +CDE,FORCE +CDE,SSTYPE +CDE,DKYSS3 C REAL PGEN(5,5),BETA(3),REDUCE(5),WPROP,Z,TRY,RANF,AMASS,TWOME REAL PSUM(5),SUM,PREST(4,6),DOT,PCM REAL AMEE,REE,WTEE,SWAP,WT,A,B,C,GAMMA REAL SMAX,SMIN,SVAL,TANMAX,TANMIN,TANVAL LOGICAL WDECAY,DECVA,DECTAU,DECJET INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IPOINT,ID1,I1,I2 INTEGER NADD,NSTART,NEW,NADD1,J,IP,I,IDABS(5) INTEGER K,JETIP,IDANTI,NPASS,MEIP,MEA REAL DBLPCM,DECSS3,VAL REAL ZZSTAR INTEGER IW C DATA REDUCE/1.,1.,2.,5.,15./ DATA PSUM/5*0./ DATA TWOME/1.022006E-3/ DATA PREST/24*0./ C C Function definitions. C Use double precision for PCM on 32-bit machines C +SELF,IF=SINGLE. PCM(A,B,C)=SQRT((A**2-B**2-C**2)**2-(2.*B*C)**2)/(2.*A) +SELF,IF=DOUBLE. PCM(A,B,C)=DBLPCM(A,B,C) +SELF. DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2) $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2) C Charged W propagator. WPROP(Z)=(Z-WMASS(2)**2)**2+(WMASS(2)*WGAM(2))**2 C---------------------------------------------------------------------- C Select decay mode. Note IDENT(NPTCL+1)...IDENT(NPTCL+5) C are always defined even if zero. C---------------------------------------------------------------------- IF(IDCAY(IP).NE.0) RETURN IDLV1=IDENT(IP) CALL FLAVOR(IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX) C FLAVOR returns 0 for quark, but want IFL3=6 for top IF(IABS(IDLV1).LT.10) IFL3=IDLV1 NPASS=0 1 CONTINUE NPASS=NPASS+1 WDECAY=.FALSE. IF(NPASS.GT.NTRIES) GO TO 9998 IPOINT=LOOK(INDEX) IF(IPOINT.EQ.0) RETURN C IPOINT<0 flags a forced decay. IF(IPOINT.LT.0) THEN I=1 IF(IDENT(IP).LT.0) I=2 IPOINT=LOOK2(I,IABS(IPOINT)) ENDIF C C Select mode. C TRY=RANF() IPOINT=IPOINT-1 100 IPOINT=IPOINT+1 IF(TRY.GT.CBR(IPOINT)) GO TO 100 NADD=0 SUM=0. NSTART=NPTCL+1 IF(NPTCL+5.GT.MXPTCL) GO TO 9999 C C Set up masses and IDENT codes. C MEIP=MELEM(IPOINT) DO 110 I=1,5 NEW=NPTCL+I IDENT(NEW)=MODE(I,IPOINT) IDABS(I)=IABS(IDENT(NEW)) IF(MODE(I,IPOINT).EQ.0) GO TO 110 NADD=NADD+1 IDLV1=IDENT(NEW) PPTCL(5,NEW)=AMASS(IDLV1) SUM=SUM+PPTCL(5,NEW) 110 CONTINUE NADD1=NADD-1 DO 120 J=1,5 PGEN(J,1)=PPTCL(J,IP) 120 CONTINUE PGEN(5,NADD)=PPTCL(5,NPTCL+NADD) C---------------------------------------------------------------------- C Carry out appropriate decay C---------------------------------------------------------------------- C C 1-body decays. C Determine polarization mode for 1-body tau decays C IF(NADD.EQ.1) THEN DO 200 J=1,5 PPTCL(J,NPTCL+1)=PPTCL(J,IP) 200 CONTINUE IF(MEIP.EQ.8) THEN IF(DECTAU(IP,NADD,MEIP,IDABS,PREST)) THEN IDENT(NPTCL+1)=IDTAUL ELSE IDENT(NPTCL+1)=IDTAUR ENDIF ENDIF GO TO 300 ENDIF C C 2-body phase space decays C IF(NADD.EQ.2.AND.MEIP.EQ.0) THEN CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) GO TO 300 ENDIF C C N-body phase space decays C IF(NADD.GT.2.AND.MEIP.EQ.0) THEN CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) GO TO 300 ENDIF C C Dalitz decays C IF(NADD.EQ.3.AND.MEIP.EQ.1) THEN 210 AMEE=TWOME*(PPTCL(5,IP)/TWOME)**RANF() REE=(TWOME/AMEE)**2 WTEE=(1.-(AMEE/PPTCL(5,IP))**2)**3*SQRT(1.-REE)*(1.+.5*REE) IF(WTEE.LT.RANF()) GO TO 210 PGEN(5,2)=AMEE CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) GO TO 300 ENDIF C C omega/phi decays (for reasons lost in history...) C IF(NADD.EQ.3.AND.MEIP.EQ.2) THEN 220 CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) WT=(PPTCL(5,NPTCL+1)*PPTCL(5,NPTCL+2)*PPTCL(5,NPTCL+3))**2 $ -(PPTCL(5,NPTCL+1)*DOT(2,3))**2 $ -(PPTCL(5,NPTCL+2)*DOT(1,3))**2 $ -(PPTCL(5,NPTCL+3)*DOT(1,2))**2 $ +2.*DOT(1,2)*DOT(2,3)*DOT(1,3) IF(WT.LT.RANF()*PPTCL(5,IP)**6/108.) GO TO 220 GO TO 300 ENDIF C C V-A decays C IF(NADD.EQ.3.AND.MEIP.EQ.3) THEN 230 CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) IF(.NOT.DECVA(IP,NADD,IDABS,PREST)) GO TO 230 GO TO 300 ENDIF C C Top decays C Generate mass for TP -> W BT with Breit-Wigner. C W couples to 1+2 so swap 1<->3. Then m2+m3 < m < m0-m1. C IF(NADD.EQ.3.AND.MEIP.EQ.4) THEN WDECAY=.TRUE. SWAP=PPTCL(5,NPTCL+1) PPTCL(5,NPTCL+1)=PPTCL(5,NPTCL+3) PPTCL(5,NPTCL+3)=SWAP SMAX=(PPTCL(5,IP)-PPTCL(5,NPTCL+1))**2 SMIN=(PPTCL(5,NPTCL+2)+PPTCL(5,NPTCL+3))**2 TANMAX=ATAN((SMAX-WMASS(2)**2)/(WMASS(2)*WGAM(2))) TANMIN=ATAN((SMIN-WMASS(2)**2)/(WMASS(2)*WGAM(2))) 240 TANVAL=RANF()*(TANMAX-TANMIN)+TANMIN SVAL=WMASS(2)**2+WMASS(2)*WGAM(2)*TAN(TANVAL) IF(SVAL.LT.SMIN.OR.SVAL.GT.SMAX) GO TO 240 PGEN(5,2)=SQRT(SVAL) PGEN(5,3)=PPTCL(5,NPTCL+3) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) IF(.NOT.DECVA(IP,NADD,IDABS,PREST)) GO TO 240 DO 241 K=1,5 SWAP=PPTCL(K,NPTCL+1) PPTCL(K,NPTCL+1)=PPTCL(K,NPTCL+3) PPTCL(K,NPTCL+3)=SWAP 241 CONTINUE PGEN(5,3)=PPTCL(5,NPTCL+3) DO 242 K=1,4 SWAP=PREST(K,1) PREST(K,1)=PREST(K,3) PREST(K,3)=SWAP 242 CONTINUE GO TO 300 ENDIF C C TAU decays. These are special because they take polarization C into account. C IF(MEIP.EQ.5.OR.MEIP.EQ.6.OR.MEIP.EQ.7) THEN 250 CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) IF(.NOT.DECTAU(IP,NADD,MEIP,IDABS,PREST)) GO TO 250 GO TO 300 ENDIF C C 3-body SUSY decays C IF(MEIP.LT.0.AND.NADD.EQ.3) THEN MEA=IABS(MEIP) IF(WTSS3(MEA).LE.0) THEN DO 260 I=1,1000 CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) VAL=DECSS3(IP,MEA) WTSS3(MEA)=MAX(WTSS3(MEA),VAL) 260 CONTINUE IF(WTSS3(MEA).LE.0) GO TO 9998 ENDIF 261 CALL DECPS1(IP,NADD,PGEN) CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) VAL=DECSS3(IP,MEA) WTSS3(MEA)=MAX(WTSS3(MEA),VAL) IF(VAL.LT.WTSS3(MEA)*RANF()) GO TO 261 GO TO 300 ENDIF C C H -> W f fbar decays C Generate f fbar mass using ZZSTAR function C IF(NADD.EQ.3.AND.MEIP.EQ.9) THEN IF(IDENT(NPTCL+1).EQ.80) THEN IW=2 ELSEIF(IDENT(NPTCL+1).EQ.-80) THEN IW=3 ELSEIF(IDENT(NPTCL+1).EQ.90) THEN IW=4 ELSE WRITE(ITLIS,*) 'ERROR IN DECAY ... BAD H -> W F FBAR' STOP99 ENDIF PGEN(5,2)=ZZSTAR(PPTCL(5,IP),IW) IF(PGEN(5,2).LT.PPTCL(5,NPTCL+2)+PPTCL(5,NPTCL+3)+1.0) $ GO TO 1 CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) GO TO 300 ENDIF C C Should never fall through C GO TO 9998 C---------------------------------------------------------------------- C Swap particles and antiparticles if IDENT(IP)<0 C Note forced modes for antiparticles are conjugated in table. C---------------------------------------------------------------------- 300 CONTINUE IF(IDENT(IP).LT.0.AND.IDENT(IP).NE.-20) THEN DO 310 I=1,NADD ID1=IDENT(NPTCL+I) IDENT(NPTCL+I)=IDANTI(ID1) 310 CONTINUE ENDIF C C Set IORIG and IDCAY. C NPTCL=NPTCL+NADD IDCAY(IP)=IPACK*NSTART+NPTCL JETIP=IABS(IORIG(IP))/IPACK DO 320 I=NSTART,NPTCL IORIG(I)=IP IDCAY(I)=0 320 CONTINUE C C Evolve and hadronize partons. If it fails, start over. C IF (.NOT.WRTLHE) THEN IF(IDABS(NADD).LT.10.OR.MOD(IDENT(NPTCL),100).EQ.0) THEN IF(.NOT.DECJET(IP,NADD,IDABS,PREST,WDECAY,BETA,GAMMA)) $ GO TO 1 ENDIF END IF C RETURN C---------------------------------------------------------------------- C Error messages. C---------------------------------------------------------------------- 9999 CALL PRTEVT(0) WRITE(ITLIS,99990) NPTCL 99990 FORMAT(//5X,'ERROR IN DECAY...NPTCL > ',I6) RETURN 9998 CALL PRTEVT(0) WRITE(ITLIS,99980) IP 99980 FORMAT(//5X,'ERROR IN DECAY...NO DECAY FOUND FOR PARTICLE',I6) RETURN END +EOD +DECK,DECJET LOGICAL FUNCTION DECJET(IP,NADD,IDABS,PREST,WDECAY,BETA,GAMMA) C C Auxiliary routine for DECAY. Evolve and hadronize partons. C Check conservation laws. Return TRUE if OK, FALSE otherwise. C C IP = particle to be decayed. C NADD = number of products (NPTCL+1, ..., NPTCL+NADD). C IDABS = absolute values of decay IDENT's. C PREST = 4-momenta in rest frame. C WDECAY = logical flag for real W decay. C BETA,GAMMA = boost parameters. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,WCON +CDE,PARTCL +CDE,DKYTAB +CDE,JETSET +CDE,JWORK +CDE,CONST C REAL PGEN(5,5),RND(5),U(3),BETA(3),IDQK(3),ROT(3,3),PSAVE(3) 1,REDUCE(5),WPROP,Z,TRY,RANF,AMASS,TWOME,CHARGE REAL PSUM(5),POLD(4),PNEW(4),SUM,WTMAX,SUM1,SUM2 REAL PREST(4,6),PWREST(5),BETAW(3),DOT,PCM REAL AMEE,REE,WTEE,SWAP,RNEW,WT,QCM,PHI,S12,S12MAX,GAMMAW,BP REAL PJET,CTHQK,STHQK,CPHIQK,SPHIQK,SUMQ,A,B,C,GAMMA REAL CHARGW LOGICAL WDECAY INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IPOINT,ID1,I1,I2,I3 INTEGER NADD,NSTART,NEW,NADD1,J,IP,I,IDABS(5),NEXT INTEGER JJ1,II,K1,K,NJSAVE,NJSAV1,NJSAV2,NJ1,NPRTN,KK,NHDRN1 INTEGER IFAIL,JSAVE,JETIP,JET,NJADD,NPTLV1,IDANTI,NPJET(5) INTEGER NHDRN,NPJET3,NPTCLW,NPBEG(5) C C Copy decay products into /JETSET/ and do QCD evolution. C IF(NJSET+NADD.GT.MXJSET) GO TO 9998 NJSAVE=NJSET NSTART=NPTCL-NADD+1 NPTCL=NSTART-1 DO 100 I=1,NADD NJSET=NJSET+1 DO 110 K=1,4 110 PJSET(K,NJSET)=PREST(K,I) PJSET(5,NJSET)=PPTCL(5,NPTCL+I) JORIG(NJSET)=JPACK*I JTYPE(NJSET)=IDENT(NPTCL+I) JDCAY(NJSET)=0 JMATCH(NJSET)=JPACK*(NJSAVE+1)+NJSAVE+NADD 100 CONTINUE C C For heavy quarks match 1+2 and 3+(1+2). Boost 1+2 to rest. C IF(WDECAY) THEN JMATCH(NJSAVE+1)=NJSAVE+2 JMATCH(NJSAVE+2)=NJSAVE+1 NJSET=NJSET+1 DO 120 K=1,4 PWREST(K)=PJSET(K,NJSAVE+1)+PJSET(K,NJSAVE+2) PJSET(K,NJSET)=PWREST(K) 120 CONTINUE PWREST(5)=SQRT(PWREST(4)**2-PWREST(1)**2-PWREST(2)**2 $ -PWREST(3)**2) PJSET(5,NJSET)=PWREST(5) JMATCH(NJSAVE+3)=NJSAVE+4 JMATCH(NJSAVE+4)=NJSAVE+3 JORIG(NJSAVE+4)=-1 IDLV1=JTYPE(NJSAVE+1) CHARGW=CHARGE(IDLV1) IDLV1=JTYPE(NJSAVE+2) CHARGW=CHARGW+CHARGE(IDLV1) JTYPE(NJSAVE+4)=80*SIGN(1.,CHARGW) JDCAY(NJSAVE+4)=0 C Boost W vectors to rest. DO 130 K=1,3 130 BETAW(K)=PWREST(K)/PWREST(4) GAMMAW=PWREST(4)/PWREST(5) NJSAV1=NJSAVE+1 NJSAV2=NJSAVE+2 DO 140 J=NJSAV1,NJSAV2 BP=BETAW(1)*PJSET(1,J)+BETAW(2)*PJSET(2,J)+BETAW(3)*PJSET(3,J) DO 141 K=1,3 141 PJSET(K,J)=PJSET(K,J)-GAMMAW*BETAW(K)*(PJSET(4,J) $ -BP*GAMMAW/(GAMMAW+1.)) PJSET(4,J)=GAMMAW*(PJSET(4,J)-BP) 140 CONTINUE ENDIF C C Do evolution and save new W momentum. Start from parent C mass or NADD*energy. NJSAV1=NJSAVE+1 DO 150 J=NJSAV1,NJSET IF(IABS(JTYPE(J)).LT.10.OR.MOD(JTYPE(J),100).EQ.0) THEN JDCAY(J)=-1 PJSET(5,J)=AMIN1(PPTCL(5,IP),NADD*PJSET(4,J)) ENDIF 150 CONTINUE C CALL QCDJET(NJSAVE+1) C IF(WDECAY) THEN PWREST(4)=PJSET(4,NJSAVE+4) GAMMAW=PWREST(4)/PWREST(5) DO 200 K=1,3 PWREST(K)=PJSET(K,NJSAVE+4) BETAW(K)=PWREST(K)/PWREST(4) 200 CONTINUE ENDIF C C Put final partons in particle table - temporary IORIG. C Also include virtual or real W momentum for quark decays. C NJ1=NJSAVE+1 IF(WDECAY) THEN C Real or virtual W. NPTCL=NPTCL+1 NPTCLW=NPTCL DO 210 K=1,5 210 PPTCL(K,NPTCL)=PJSET(K,NJSAVE+4) IORIG(NPTCL)=IP IDENT(NPTCL)=JTYPE(NJSAVE+4) IDCAY(NPTCL)=0 C Jet 3 NPBEG(3)=NPTCL+1 DO 220 J=NJ1,NJSET IF(JDCAY(J).NE.0) GO TO 220 IF(JORIG(J)/JPACK.NE.3) GO TO 220 NPTCL=NPTCL+1 DO 221 K=1,5 221 PPTCL(K,NPTCL)=PJSET(K,J) IORIG(NPTCL)=3*IPACK+IP IDENT(NPTCL)=JTYPE(J) IDCAY(NPTCL)=0 220 CONTINUE C Jets 1 and 2 NPJET3=NPTCL DO 230 JET=1,2 NPBEG(JET)=NPTCL+1 DO 240 J=NJ1,NJSET IF(JDCAY(J).NE.0) GO TO 240 IF(JORIG(J)/JPACK.NE.JET) GO TO 240 NPTCL=NPTCL+1 BP=BETAW(1)*PJSET(1,J)+BETAW(2)*PJSET(2,J) $ +BETAW(3)*PJSET(3,J) DO 241 K=1,3 241 PPTCL(K,NPTCL)=PJSET(K,J)+GAMMAW*BETAW(K)*(PJSET(4,J) $ +BP*GAMMAW/(GAMMAW+1.)) PPTCL(4,NPTCL)=GAMMAW*(PJSET(4,J)+BP) PPTCL(5,NPTCL)=PJSET(5,J) IORIG(NPTCL)=IPACK*(JORIG(J)/JPACK)+NPTCLW IDENT(NPTCL)=JTYPE(J) IDCAY(NPTCL)=0 240 CONTINUE 230 CONTINUE C Quark decays to W plus jet 3; then W decays. IDCAY(IP)=IPACK*NPTCLW+NPJET3 IDCAY(NPTCLW)=IPACK*(NPJET3+1)+NPTCL ELSE C Not quark decay, so just copy partons. DO 250 JET=1,NADD NPBEG(JET)=NPTCL+1 DO 260 J=NJ1,NJSET IF(JDCAY(J).NE.0) GO TO 260 IF(JORIG(J)/JPACK.NE.JET) GO TO 260 NPTCL=NPTCL+1 DO 261 K=1,5 261 PPTCL(K,NPTCL)=PJSET(K,J) IORIG(NPTCL)=IPACK*(JORIG(J)/JPACK)+IP IDENT(NPTCL)=JTYPE(J) IDCAY(NPTCL)=0 260 CONTINUE 250 CONTINUE IDCAY(IP)=NSTART*IPACK+NPTCL ENDIF NHDRN=NPTCL C C Hadronize quarks and rotate to proper angles. C DO 300 JET=1,NADD NPRTN=NPBEG(JET)-1 DO 310 I=NJ1,NJSET IF(JDCAY(I).NE.0) GO TO 310 IF(JORIG(I)/JPACK.NE.JET) GO TO 310 NPRTN=NPRTN+1 IF(IABS(JTYPE(I)).GE.10.AND.MOD(JTYPE(I),100).NE.0) $ GO TO 330 C C Fragment parton: NEXT=NPTCL+1 PJET=SQRT(PJSET(1,I)**2+PJSET(2,I)**2+PJSET(3,I)**2) CTHQK=PJSET(3,I)/PJET STHQK=1.-CTHQK**2 IF(STHQK.LT.1) THEN STHQK=SQRT(STHQK) CPHIQK=PJSET(1,I)/(PJET*STHQK) SPHIQK=PJSET(2,I)/(PJET*STHQK) ELSE STHQK=0 CPHIQK=1 SPHIQK=0 ENDIF CALL JETGEN(I) IF(NEXT.GT.NPTCL) GO TO 310 ROT(1,1)=CPHIQK*CTHQK ROT(2,1)=SPHIQK*CTHQK ROT(3,1)=-STHQK ROT(1,2)=-SPHIQK ROT(2,2)=CPHIQK ROT(3,2)=0. ROT(1,3)=CPHIQK*STHQK ROT(2,3)=SPHIQK*STHQK ROT(3,3)=CTHQK C DO 320 II=NEXT,NPTCL DO 321 K=1,3 PSAVE(K)=PPTCL(K,II) PPTCL(K,II)=0. 321 CONTINUE DO 322 K=1,3 DO 322 KK=1,3 322 PPTCL(K,II)=PPTCL(K,II)+ROT(K,KK)*PSAVE(KK) IORIG(II)=IPACK*JET+NPRTN IDCAY(II)=0 320 CONTINUE IDCAY(NPRTN)=NEXT*IPACK+NPTCL GO TO 310 C C or add lepton: 330 NPTCL=NPTCL+1 DO 331 K=1,5 331 PPTCL(K,NPTCL)=PJSET(K,I) IORIG(NPTCL)=IPACK*JET+NPRTN IDENT(NPTCL)=JTYPE(I) IDCAY(NPTCL)=0 IDCAY(NPRTN)=NPTCL*IPACK+NPTCL 310 CONTINUE NPJET(JET)=NPTCL 300 CONTINUE C C Reset NJSET so decay jets do not appear in /JETSET/ NJADD=NJSET NJSET=NJSAVE C C Check for at least two particles IF(NPTCL.LT.NHDRN+2) THEN NPTCL=NSTART-1 DECJET=.FALSE. RETURN ENDIF C C Conserve charge C SUMQ=0. NHDRN1=NHDRN+1 DO 400 I=NHDRN1,NPTCL IDLV1=IDENT(I) SUMQ=SUMQ+CHARGE(IDLV1) 400 CONTINUE IDLV1=IDENT(IP) SUMQ=SUMQ-CHARGE(IDLV1) C IF(ABS(SUMQ).LT.0.99) GO TO 500 C C Charge wrong--fix it by swapping UP and DN quarks. DO 410 I=NHDRN1,NPTCL ID1=IDENT(I) IF(IABS(ID1).GT.1000) GO TO 410 I1=MOD(IABS(ID1)/100,10) I2=MOD(IABS(ID1)/10,10) I3=MOD(IABS(ID1),10) IF(I1.EQ.1.AND.I2.GT.2.AND.SUMQ*ID1.GT.0.) THEN IDENT(I)=ISIGN(200+10*I2+I3,ID1) ELSEIF(I1.EQ.2.AND.I2.GT.2.AND.SUMQ*ID1.LT.0.) THEN IDENT(I)=ISIGN(100+10*I2+I3,ID1) ELSEIF(I1.EQ.1.AND.I2.EQ.2.AND.SUMQ*ID1.GT.0.) THEN IDENT(I)=110+I3 ELSEIF(I1.EQ.1.AND.I2.EQ.1) THEN IDENT(I)=(120+I3)*(-SIGN(1.,SUMQ)) ELSE GO TO 410 ENDIF SUMQ=SIGN(ABS(SUMQ)-1.,SUMQ) IDLV1=IDENT(I) PPTCL(5,I)=AMASS(IDLV1) PPTCL(4,I)=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2+PPTCL(3,I)**2 $ +PPTCL(5,I)**2) C Sum cannot vanish for fractionally charged initial particle. IF(ABS(SUMQ).LT.0.99) GO TO 500 410 CONTINUE C Failed to conserve charge. NPTCL=NSTART-1 DECJET=.FALSE. RETURN C C Rescale momenta for correct mass C 500 CONTINUE IF(WDECAY) THEN C Quark decay. First rescale jet3 + W DO 510 K=1,5 510 PPTCL(K,NPTCL+1)=PPTCL(K,NPTCLW) NPTLV1=NPTCL+1 DO 520 K=1,3 520 PSUM(K)=0. PSUM(4)=PPTCL(5,IP) PSUM(5)=PSUM(4) CALL RESCAL(NPJET(2)+1,NPTLV1,PSUM,IFAIL) IF(IFAIL.NE.0) THEN NPTCL=NSTART-1 DECJET=.FALSE. RETURN ENDIF DO 530 K=1,3 530 BETAW(K)=PPTCL(K,NPTCL+1)/PPTCL(4,NPTCL+1) GAMMAW=PPTCL(4,NPTCL+1)/PPTCL(5,NPTCL+1) C Then rescale W PSUM(4)=PPTCL(5,NPTCLW) PSUM(5)=PSUM(4) CALL RESCAL(NHDRN1,NPJET(2),PSUM,IFAIL) IF(IFAIL.NE.0) THEN NPTCL=NSTART-1 DECJET=.FALSE. RETURN ENDIF ELSE C General decay with no W. DO 550 K=1,3 550 PSUM(K)=0. PSUM(4)=PPTCL(5,IP) PSUM(5)=PSUM(4) NPTLV1=NPTCL CALL RESCAL(NHDRN1,NPTLV1,PSUM,IFAIL) IF(IFAIL.NE.0) THEN NPTCL=NSTART-1 DECJET=.FALSE. RETURN ENDIF ENDIF C C Boost back to lab frame. Reset IORIG. C IF(WDECAY) THEN DO 600 I=NHDRN1,NPTCL JET=IORIG(I)/IPACK IF(JET.NE.1.AND.JET.NE.2) GO TO 600 BP=BETAW(1)*PPTCL(1,I)+BETAW(2)*PPTCL(2,I)+BETAW(3)*PPTCL(3,I) DO 610 J=1,3 610 PPTCL(J,I)=PPTCL(J,I)+GAMMAW*BETAW(J)*(PPTCL(4,I) $ +BP*GAMMAW/(GAMMAW+1.)) PPTCL(4,I)=GAMMAW*(PPTCL(4,I)+BP) 600 CONTINUE ENDIF C DO 620 I=NSTART,NPTCL IORIG(I)=MOD(IORIG(I),IPACK) BP=BETA(1)*PPTCL(1,I)+BETA(2)*PPTCL(2,I)+BETA(3)*PPTCL(3,I) DO 621 J=1,3 PPTCL(J,I)=PPTCL(J,I)+GAMMA*BETA(J)*(PPTCL(4,I) $ +BP*GAMMA/(GAMMA+1.)) 621 CONTINUE PPTCL(4,I)=GAMMA*(PPTCL(4,I)+BP) 620 CONTINUE C C Normal exit C DECJET=.TRUE. RETURN C C Error messages. C 9998 DECJET=.FALSE. CALL PRTEVT(0) WRITE(ITLIS,99980) NJSET 99980 FORMAT(//5X,'ERROR IN DECJET...NJSET > ',I5) RETURN END +EOD +DECK,DECME +EOD +DECK,DECPS1 SUBROUTINE DECPS1(IP,NADD,PGEN) C C Generate masses for uniform NADD-body phase space in DECPS2. C Auxiliary routine for DECAY. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. C +CDE,ITAPES +CDE,PARTCL C INTEGER IP,NADD REAL PGEN(5,5) REAL REDUCE(5),RND(5) REAL RANF,PCM,DBLPCM REAL WTMAX,SUM1,SUM2,SUM,RNEW,WT,A,B,C INTEGER I,NADD1,J,I1,JJ1,JSAVE C C Function definitions. C +SELF,IF=SINGLE. PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A) +SELF,IF=DOUBLE. PCM(A,B,C)=DBLPCM(A,B,C) +SELF. C DATA REDUCE/1.,1.,2.,5.,15./ C C Calculate maximum phase-space weight. C IF(NADD.LE.2) RETURN NADD1=NADD-1 WTMAX=1./REDUCE(NADD) SUM=0 DO 100 I=1,NADD SUM=SUM+PPTCL(5,NPTCL+I) 100 CONTINUE SUM1=PGEN(5,1) SUM2=SUM-PPTCL(5,NPTCL+1) DO 110 I=1,NADD1 WTMAX=WTMAX*PCM(SUM1,SUM2,PPTCL(5,NPTCL+I)) SUM1=SUM1-PPTCL(5,NPTCL+I) SUM2=SUM2-PPTCL(5,NPTCL+I+1) 110 CONTINUE C C Generate masses for uniform NADD-body phase space. C 200 CONTINUE RND(1)=1. DO 210 I=2,NADD1 RNEW=RANF() I1=I-1 DO 220 JJ1=1,I1 J=I-JJ1 JSAVE=J+1 IF(RNEW.LE.RND(J)) GO TO 210 RND(JSAVE)=RND(J) 220 CONTINUE 210 RND(JSAVE)=RNEW RND(NADD)=0. WT=1. SUM1=SUM DO 230 I=2,NADD SUM1=SUM1-PPTCL(5,NPTCL+I-1) PGEN(5,I)=SUM1+RND(I)*(PGEN(5,1)-SUM) IF(PGEN(5,I-1).LE.PGEN(5,I)+PPTCL(5,NPTCL+I-1)) GO TO 200 WT=WT*PCM(PGEN(5,I-1),PGEN(5,I),PPTCL(5,NPTCL+I-1)) 230 CONTINUE IF(WT.LT.RANF()*WTMAX) GO TO 200 C RETURN END +EOD +DECK,DECPS2 SUBROUTINE DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA) C C Carry out decays using masses from DECPS1 or special matrix C elements. C Auxiliary routine for DECAY. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. C +CDE,ITAPES +CDE,PARTCL +CDE,CONST C INTEGER IP,NADD REAL PGEN(5,5),PREST(4,6) REAL PCM,DBLPCM,RANF REAL U(3),BETA(3) REAL QCM,PHI,A,B,C,GAMMA,BP INTEGER I,J,NADD1,II,K,K1 C C Function definitions. C +SELF,IF=SINGLE. PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A) +SELF,IF=DOUBLE. PCM(A,B,C)=DBLPCM(A,B,C) +SELF. C C Carry out two-body decays in PGEN frames. C NADD1=NADD-1 100 CONTINUE DO 110 I=1,NADD1 QCM=PCM(PGEN(5,I),PGEN(5,I+1),PPTCL(5,NPTCL+I)) U(3)=2.*RANF()-1. PHI=2.*PI*RANF() U(1)=SQRT(1.-U(3)**2)*COS(PHI) U(2)=SQRT(1.-U(3)**2)*SIN(PHI) DO 120 J=1,3 PPTCL(J,NPTCL+I)=QCM*U(J) PGEN(J,I+1)=-PPTCL(J,NPTCL+I) 120 CONTINUE PPTCL(4,NPTCL+I)=SQRT(QCM**2+PPTCL(5,NPTCL+I)**2) PGEN(4,I+1)=SQRT(QCM**2+PGEN(5,I+1)**2) 110 CONTINUE C DO 130 J=1,4 PPTCL(J,NPTCL+NADD)=PGEN(J,NADD) 130 CONTINUE C C Boost PGEN frames to lab frame, saving momenta in rest frame. C DO 200 II=1,NADD1 I=NADD-II DO 210 J=1,3 BETA(J)=PGEN(J,I)/PGEN(4,I) 210 CONTINUE GAMMA=PGEN(4,I)/PGEN(5,I) DO 220 K=I,NADD K1=NPTCL+K BP=BETA(1)*PPTCL(1,K1)+BETA(2)*PPTCL(2,K1)+BETA(3)*PPTCL(3,K1) DO 230 J=1,3 PREST(J,K)=PPTCL(J,K1) PPTCL(J,K1)=PPTCL(J,K1)+GAMMA*BETA(J)*(PPTCL(4,K1) $ +BP*GAMMA/(GAMMA+1.)) 230 CONTINUE PREST(4,K)=PPTCL(4,K1) PPTCL(4,K1)=GAMMA*(PPTCL(4,K1)+BP) 220 CONTINUE 200 CONTINUE C RETURN END +EOD +DECK,DECSS3 FUNCTION DECSS3(IP,MEA) C C Compute matrix element for mode MEA of particle IP using C poles and couplings in /DKYSS3/. C Auxiliary routine for DECAY. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. C +CDE,ITAPES +CDE,PARTCL +CDE,CONST +CDE,DKYSS3 C LOGICAL KIN(4),KINP(4) INTEGER IP,MEA,I,J,JP,II,PTYPE1,PTYPE2 REAL DECSS3 REAL AM0SQ,AM1SQ,AM2SQ,AM3SQ,S12,S13,S23 REAL D12,D13,D23,D01,D02,D03,AS,BS,CS,DS,MSQ REAL DOT4 COMPLEX A,B,C,D,AC,BC,CC,DC,AP,BP,CP,DP,APC,BPC,CPC,DPC,MMPD C DOT4(I,J)=PPTCL(4,I)*PPTCL(4,J)-PPTCL(1,I)*PPTCL(1,J)- $PPTCL(2,I)*PPTCL(2,J)-PPTCL(3,I)*PPTCL(3,J) C C Kinematics C AM0SQ=PPTCL(5,IP)**2 AM1SQ=PPTCL(5,NPTCL+1)**2 AM2SQ=PPTCL(5,NPTCL+2)**2 AM3SQ=PPTCL(5,NPTCL+3)**2 D12=DOT4(NPTCL+1,NPTCL+2) D13=DOT4(NPTCL+1,NPTCL+3) D23=DOT4(NPTCL+2,NPTCL+3) D01=DOT4(IP,NPTCL+1) D02=DOT4(IP,NPTCL+2) D03=DOT4(IP,NPTCL+3) S12=2*D12+AM1SQ+AM2SQ S13=2*D13+AM1SQ+AM3SQ S23=2*D23+AM2SQ+AM3SQ C C Generic matrix element C C Loop over diagrams DECSS3=0. DO J=J1SS3(MEA),J2SS3(MEA) PTYPE1=KSS3(J) A=ZISS3(1,J) B=ZISS3(2,J) C=ZFSS3(1,J) D=ZFSS3(2,J) AC=CONJG(A) BC=CONJG(B) CC=CONJG(C) DC=CONJG(D) AS=A*AC BS=B*BC CS=C*CC DS=D*DC DO JP=J,J2SS3(MEA) MSQ=0. DO II=1,4 KIN(II)=.FALSE. KINP(II)=.FALSE. END DO IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(J)) KIN(1)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+3)).LT.AMSS3(J)) KIN(2)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+2)).LT.AMSS3(J)) KIN(3)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(J)) KIN(4)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(JP)) KINP(1)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+3)).LT.AMSS3(JP)) KINP(2)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+2)).LT.AMSS3(JP)) KINP(3)=.TRUE. IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(JP)) KINP(4)=.TRUE. IF (J.EQ.JP) THEN IF (PTYPE1.EQ.1.AND.KIN(1)) THEN MSQ=32*(((AS+BS)*(CS+DS)+4*REAL(A*BC)*REAL(C*DC))*D03*D12+ $ ((AS+BS)*(CS+DS)-4*REAL(A*BC)*REAL(C*DC))*D02*D13+ $ (BS-AS)*(CS+DS)*SQRT(AM0SQ*AM1SQ)*D23)/ $ (S23-AMSS3(J)**2)**2 ELSE IF (PTYPE1.EQ.2.AND.KIN(2)) THEN MSQ=16*(AS+BS)*(CS+DS)*D03*D12/(S12-AMSS3(J)**2)**2 ELSE IF (PTYPE1.EQ.3.AND.KIN(3)) THEN MSQ=16*(AS+BS)*(CS+DS)*D02*D13/(S13-AMSS3(J)**2)**2 ELSE IF (PTYPE1.EQ.4.AND.KIN(4)) THEN MSQ=16*((AS+BS)*(CS+DS)*D01*D23+(AS-BS)*(CS+DS)*D23* $ SQRT(AM0SQ*AM1SQ))/(S23-AMSS3(J)**2)**2 END IF END IF IF (J.NE.JP) THEN PTYPE2=KSS3(JP) AP=ZISS3(1,JP) BP=ZISS3(2,JP) CP=ZFSS3(1,JP) DP=ZFSS3(2,JP) APC=CONJG(AP) BPC=CONJG(BP) CPC=CONJG(CP) DPC=CONJG(DP) IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.2.AND.KIN(2).AND.KINP(2)) THEN MMPD=16*D12*D03*(A*APC+B*BPC)*(C*CPC+D*DPC)/ $ (S12-AMSS3(J)**2)/(S12-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.3.AND.PTYPE2.EQ.3.AND.KIN(3).AND.KINP(3)) THEN MMPD=16*D13*D02*(A*APC+B*BPC)*(C*CPC+D*DPC)/ $ (S13-AMSS3(J)**2)/(S13-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.4.AND.PTYPE2.EQ.4.AND.KIN(4).AND.KINP(4)) THEN MMPD=16*D23*(D01*(A*APC+B*BPC)*(C*CPC+D*DPC)+ $ SQRT(AM0SQ*AM1SQ)*(A*APC-B*BPC)*(C*CPC-D*DPC))/ $ (S23-AMSS3(J)**2)/(S23-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.1.AND.PTYPE2.EQ.3.AND.KIN(1).AND.KINP(3)) THEN MMPD=(16*D13*D02*((A*C-B*D)*(-APC*CPC+BPC*DPC)+ $ (A*D-B*C)*(APC*DPC-BPC*CPC))+ $ 8*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)- $ (A*D+B*C)*(APC*DPC-BPC*CPC)))/ $ (S23-AMSS3(J)**2)/(S13-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.1.AND.PTYPE2.EQ.2.AND.KIN(1).AND.KINP(2)) THEN MMPD=(16*D12*D03*((A*C+B*D)*(-APC*CPC+BPC*DPC)+ $ (A*D+B*C)*(APC*DPC-BPC*CPC))+ $ 8*D23*SQRT(AM0SQ*AM1SQ)*((A*C-B*D)*(APC*CPC-BPC*DPC)+ $ (-A*D+B*C)*(APC*DPC-BPC*CPC)))/ $ (S23-AMSS3(J)**2)/(S12-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.3.AND.PTYPE2.EQ.4.AND.KIN(3).AND.KINP(4)) THEN MMPD=((8*D13*D23+4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+ $ (A*D+B*C)*(APC*DPC+BPC*CPC))+ $ 4*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)+ $ (A*D+B*C)*(APC*DPC-BPC*CPC)))/ $ (S13-AMSS3(J)**2)/(S23-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.4.AND.KIN(2).AND.KINP(4)) THEN MMPD=-((8*D12*D23+4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+ $ (A*D+B*C)*(APC*DPC+BPC*CPC))+ $ 4*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)+ $ (A*D+B*C)*(APC*DPC-BPC*CPC)))/ $ (S12-AMSS3(J)**2)/(S23-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.3.AND.KIN(2).AND.KINP(3)) THEN MMPD=((8*D12*D13-4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+ $ (A*D+B*C)*(APC*DPC+BPC*CPC))- $ 4*D23*SQRT(AM0SQ*AM1SQ)*((A*C-B*D)*(APC*CPC-BPC*DPC)+ $ (A*D-B*C)*(APC*DPC-BPC*CPC)))/ $ (S12-AMSS3(J)**2)/(S13-AMSS3(JP)**2) MSQ=2*REAL(MMPD) END IF END IF DECSS3=DECSS3+MSQ END DO END DO C RETURN END +EOD +DECK,DECTAU LOGICAL FUNCTION DECTAU(IP,NADD,MEIP,IDABS,PREST) C C Compute matrix elements for polarized tau decay. C Polarization determined by tau parent. C Auxiliary routine for DECAY. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,WCON +CDE,PARTCL +CDE,DKYTAB +CDE,CONST +CDE,PJETS +CDE,KEYS +CDE,XMSSM +CDE,SSPOLS +CDE,PRIMAR C REAL PREST(4,6),WT,TAUHEL,S12,S12MAX,PIP,CTHNU,PSUM(4),AMV2,WT1 REAL DOT,DOT3,RANF,Z INTEGER IP,NADD,IDABS(5),IPAR,IDPAR,JET,INU,I,K,I1,I2,IDSIB INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IDIP INTEGER MEIP,IPX,IP1,IP2 C DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2) $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2) DOT3(I1,I2)=PREST(1,I1)*PREST(1,I2)+PREST(2,I1)*PREST(2,I2) $+PREST(3,I1)*PREST(3,I2) C IDIP=IDENT(IP) DECTAU=.TRUE. IF(IABS(IDIP).NE.16) GO TO 999 C C Use PREST(K,6) for spin vector C PIP=SQRT(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(3,IP)**2) DO 100 K=1,3 PREST(K,6)=PPTCL(K,IP)/PIP 100 CONTINUE PREST(4,6)=0. C C Take helicity TAUHEL=0 unless TAU parent is TP, W+-, H+-, C or some SUSY particles. C Take account of 1-particle decays! C IPX=IP TAUHEL=0. IPAR=0 IDPAR=0 110 IF(IORIG(IPX).GT.0) THEN IPAR=MOD(IORIG(IPX),IPACK) IDPAR=IDENT(IPAR) IF(IDPAR.EQ.IDIP) THEN IP1=IDCAY(IPAR)/IPACK IP2=MOD(IDCAY(IPAR),IPACK) IF(IP1.EQ.IP2) THEN IPX=IPAR GO TO 110 ENDIF ENDIF IDPAR=IABS(IDPAR) IDSIB=0 C W/top parent IF((IDPAR.GE.6.AND.IDPAR.LE.8).OR. $ (IDPAR.GT.100.AND.MOD(IDPAR/10,10).GE.6)) THEN TAUHEL=-1. ELSEIF(IDPAR.EQ.80) THEN TAUHEL=-1. C Charged Higgs parent ELSEIF(IDPAR.EQ.86) THEN TAUHEL=+1. C SUSY parent - polarization also depends on sibling IDSIB ELSEIF(GOMSSM.AND.IDPAR.GT.20.AND.IDPAR.LT.80) THEN I1=IDCAY(IPAR)/IPACK I2=MOD(IDCAY(IPAR),IPACK) DO 120 I=I1,I2 IF(IABS(IDENT(I)).GT.20.AND.IABS(IDENT(I)).LT.80) $ IDSIB=IABS(IDENT(I)) 120 CONTINUE IF (IDPAR.EQ.35) THEN TAUHEL=-1. ELSEIF (IDPAR.EQ.36) THEN IF (IDSIB.EQ.30) TAUHEL=PTAU1(1) IF (IDSIB.EQ.40) TAUHEL=PTAU1(2) IF (IDSIB.EQ.50) TAUHEL=PTAU1(3) IF (IDSIB.EQ.60) TAUHEL=PTAU1(4) ELSEIF (IDPAR.EQ.56) THEN IF (IDSIB.EQ.30) TAUHEL=PTAU2(1) IF (IDSIB.EQ.40) TAUHEL=PTAU2(2) IF (IDSIB.EQ.50) TAUHEL=PTAU2(3) IF (IDSIB.EQ.60) TAUHEL=PTAU2(4) ELSEIF (IDPAR.EQ.39) THEN IF(IDSIB.EQ.35) TAUHEL=-1. IF(IDSIB.EQ.30) TAUHEL=PTAUWZ ELSEIF (IDPAR.EQ.49.AND.IDSIB.EQ.35) THEN TAUHEL=-1. ELSEIF (IDPAR.EQ.40) THEN IF(IDSIB.EQ.36) TAUHEL=PTAUZ2(1) IF(IDSIB.EQ.56) TAUHEL=PTAUZ2(2) IF(IDSIB.EQ.30) TAUHEL=PTAUZZ ELSEIF (IDPAR.EQ.50) THEN IF(IDSIB.EQ.36) TAUHEL=PTAUZ3(1) IF(IDSIB.EQ.56) TAUHEL=PTAUZ3(2) ELSEIF (IDPAR.EQ.60) THEN IF(IDSIB.EQ.36) TAUHEL=PTAUZ4(1) IF(IDSIB.EQ.56) TAUHEL=PTAUZ4(2) ENDIF END IF ELSE IF(KEYS(3)) THEN IF(IABS(IDENTW).EQ.80) TAUHEL=-1. ELSE JET=IABS(IORIG(IP))/IPACK IF(JET.GT.0.AND.JET.LE.NJET) THEN IF(IDJETS(JET).EQ.80) TAUHEL=-1. ENDIF ENDIF ENDIF C C If NOTAU, just return .TRUE. for TAUL, .FALSE. for TAUR C IF(MEIP.EQ.8) THEN IF(RANF().LT.(TAUHEL+1)/2) THEN DECTAU=.FALSE. ELSE DECTAU=.TRUE. ENDIF RETURN ENDIF C C Leptonic decays. DECTAU is always called for TAU- decay C products, so selection is independent of IDENT(IP). C IF(MEIP.EQ.5) THEN IF(IDENT(NPTCL+1).LT.0) THEN WT=PPTCL(5,IP)*(PREST(4,1)-TAUHEL*DOT(1,6))*DOT(2,3) ELSEIF(IDENT(NPTCL+2).LT.0) THEN WT=PPTCL(5,IP)*(PREST(4,2)-TAUHEL*DOT(2,6))*DOT(1,3) ELSE WT=PPTCL(5,IP)*(PREST(4,3)-TAUHEL*DOT(3,6))*DOT(1,2) ENDIF IF(WT.LT.RANF()*PPTCL(5,IP)**4/8.) THEN DECTAU=.FALSE. ELSE DECTAU=.TRUE. ENDIF RETURN C C Decay to PI + NUT, K + NUT C ELSEIF(MEIP.EQ.6) THEN INU=1 IF(IDABS(2).EQ.15) INU=2 CTHNU=DOT3(INU,6)/SQRT(DOT3(INU,INU)) WT=1.-TAUHEL*CTHNU IF(WT.LT.RANF()*2.) THEN DECTAU=.FALSE. ELSE DECTAU=.TRUE. ENDIF RETURN C C Decay to RHO + NUT, A1 + NUT, K* + NUT C ELSEIF(MEIP.EQ.7) THEN DO 210 I=1,NADD 210 IF(IDABS(I).EQ.15) INU=I DO 220 K=1,4 PSUM(K)=0. DO 221 I=1,NADD IF(I.EQ.INU) GO TO 221 PSUM(K)=PSUM(K)+PREST(K,I) 221 CONTINUE 220 CONTINUE AMV2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2 WT1=2.*AMV2/(2.*AMV2+PPTCL(5,IP)**2) CTHNU=DOT3(INU,6)/SQRT(DOT3(INU,INU)) WT=WT1*(1.+TAUHEL*CTHNU)+(1.-WT1)*(1-TAUHEL*CTHNU) IF(WT.LT.RANF()*2.) THEN DECTAU=.FALSE. ELSE DECTAU=.TRUE. ENDIF RETURN C C Ignore matrix element for all other decays C ELSE DECTAU=.TRUE. RETURN ENDIF C C Error C 999 CALL PRTEVT(0) WRITE(ITLIS,99999) IP 99999 FORMAT(//5X,'ERROR IN DECTAU FOR PARTICLE',I6) END +EOD +DECK,DECVA LOGICAL FUNCTION DECVA(IP,NADD,IDABS,PREST) C C Compute matrix element unpolarized for V-A. C Auxiliary routine for DECAY. C C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,WCON +CDE,PARTCL +CDE,DKYTAB +CDE,JETSET +CDE,JWORK +CDE,CONST +CDE,KEYS +CDE,PJETS +CDE,XMSSM +CDE,SSPOLS C REAL PREST(4,6) REAL DOT,RANF,WT INTEGER IP,NADD,IDABS(5),I,K,I1,I2,IDIPA C DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2) $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2) C IDIPA=IABS(IDENT(IP)) IF(IDENT(NPTCL+1).LT.0) THEN WT=PPTCL(5,IP)*PREST(4,1)*DOT(2,3) ELSEIF(IDENT(NPTCL+2).LT.0) THEN WT=PPTCL(5,IP)*PREST(4,2)*DOT(1,3) ELSE WT=PPTCL(5,IP)*PREST(4,3)*DOT(1,2) ENDIF IF(WT.LT.RANF()*PPTCL(5,IP)**4/16.) THEN DECVA=.FALSE. ELSE DECVA=.TRUE. ENDIF RETURN END +EOD +DECK,DHELAS C ********************************************************************* C *** *** C *** coded by H. Murayama & I. Watanabe *** C *** For the formalism and notations, see the following reference: *** C *** H. Murayama, I. Watanabe and K. Hagiwara *** C *** "HELAS: HELicity Amplitude Subroutines *** C *** for Feynman diagram evaluation" *** C *** KEK Report 91-11, December 1991 *** C *** *** C ********************************************************************* C C Converted to double precision by W. Long and T. Seltzer for MadGraph. C C Minor changes for portability by FEP, July 1999. The code is not ANSI C standard, but that cannot be helped if MadGraph compatibility is to C be maintained. C C ====================================================================== C SUBROUTINE BOOSTX(P,Q , PBOOST) C C this subroutine performs the lorentz boost of a four-momentum. the C momentum p is assumed to be given in the rest frame of q. pboost is C the momentum p boosted to the frame in which q is given. q must be a C timelike momentum. C C input: C real p(0:3) : four-momentum p in the q rest frame C real q(0:3) : four-momentum q in the boosted frame C C output: C real pboost(0:3) : four-momentum p in the boosted frame C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 P(0:3),Q(0:3),PBOOST(0:3),PQ,QQ,M,LF REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C QQ=Q(1)**2+Q(2)**2+Q(3)**2 C IF ( QQ .NE. RXZERO ) THEN PQ=P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3) M=SQRT(Q(0)**2-QQ) LF=((Q(0)-M)*PQ/QQ+P(0))/M PBOOST(0) = (P(0)*Q(0)+PQ)/M PBOOST(1) = P(1)+Q(1)*LF PBOOST(2) = P(2)+Q(2)*LF PBOOST(3) = P(3)+Q(3)*LF ELSE PBOOST(0)=P(0) PBOOST(1)=P(1) PBOOST(2)=P(2) PBOOST(3)=P(3) ENDIF C RETURN END C C ********************************************************************** C SUBROUTINE COUP1X(SW2 , GW,GWWA,GWWZ) C C this subroutine sets up the coupling constants of the gauge bosons in C the standard model. C C input: C real sw2 : square of sine of the weak angle C C output: C real gw : weak coupling constant C real gwwa : dimensionless coupling of w-,w+,a C real gwwz : dimensionless coupling of w-,w+,z C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 SW2,GW,GWWA,GWWZ,ALPHA,FOURPI,EE,SW,CW REAL*8 RXONE, RXFOUR, RXOTE, RXPI, RIALPH PARAMETER( RXONE=1.0D0, RXFOUR=4.0D0, RXOTE=128.0D0 ) PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 ) C ALPHA = RXONE / RXOTE C alpha = r_one / r_ialph FOURPI = RXFOUR * RXPI EE=SQRT( ALPHA * FOURPI ) SW=SQRT( SW2 ) CW=SQRT( RXONE - SW2 ) C GW = EE/SW GWWA = EE GWWZ = EE*CW/SW C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE COUP2X(SW2 , GAL,GAU,GAD,GWF,GZN,GZL,GZU,GZD,G1) C C this subroutine sets up the coupling constants for the fermion- C fermion-vector vertices in the standard model. the array of the C couplings specifies the chirality of the flowing-in fermion. g??(1) C denotes a left-handed coupling, and g??(2) a right-handed coupling. C C input: C real sw2 : square of sine of the weak angle C C output: C real gal(2) : coupling with a of charged leptons C real gau(2) : coupling with a of up-type quarks C real gad(2) : coupling with a of down-type quarks C real gwf(2) : coupling with w-,w+ of fermions C real gzn(2) : coupling with z of neutrinos C real gzl(2) : coupling with z of charged leptons C real gzu(2) : coupling with z of up-type quarks C real gzd(2) : coupling with z of down-type quarks C real g1(2) : unit coupling of fermions C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 GAL(2),GAU(2),GAD(2),GWF(2),GZN(2),GZL(2),GZU(2),GZD(2), & G1(2),SW2,ALPHA,FOURPI,EE,SW,CW,EZ,EY C REAL*8 RXZERO, RXHALF, RXONE, RXTWO, RTHREE, RXFOUR, RXOTE REAL*8 RXPI, RIALPH PARAMETER( RXZERO=0.0D0, RXHALF=0.5D0, RXONE=1.0D0, RXTWO=2.0D0, $ RTHREE=3.0D0 ) PARAMETER( RXFOUR=4.0D0, RXOTE=128.0D0 ) PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 ) C ALPHA = RXONE / RXOTE C alpha = r_one / r_ialph FOURPI = RXFOUR * RXPI EE=SQRT( ALPHA * FOURPI ) SW=SQRT( SW2 ) CW=SQRT( RXONE - SW2 ) EZ=EE/(SW*CW) EY=EE*(SW/CW) C GAL(1) = EE GAL(2) = EE GAU(1) = -EE*RXTWO/RTHREE GAU(2) = -EE*RXTWO/RTHREE GAD(1) = EE /RTHREE GAD(2) = EE /RTHREE GWF(1) = -EE/SQRT(RXTWO*SW2) GWF(2) = RXZERO GZN(1) = -EZ* RXHALF GZN(2) = RXZERO GZL(1) = -EZ*(-RXHALF+SW2) GZL(2) = -EY GZU(1) = -EZ*( RXHALF-SW2*RXTWO/RTHREE) GZU(2) = EY* RXTWO/RTHREE GZD(1) = -EZ*(-RXHALF+SW2 /RTHREE) GZD(2) = -EY /RTHREE G1(1) = RXONE G1(2) = RXONE C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE COUP3X(SW2,ZMASS,HMASS , & GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH) C C this subroutine sets up the coupling constants of the gauge bosons and C higgs boson in the standard model. C C input: C real sw2 : square of sine of the weak angle C real zmass : mass of z C real hmass : mass of higgs C C output: C real gwwh : dimensionful coupling of w-,w+,h C real gzzh : dimensionful coupling of z, z, h C real ghhh : dimensionful coupling of h, h, h C real gwwhh : dimensionful coupling of w-,w+,h, h C real gzzhh : dimensionful coupling of z, z, h, h C real ghhhh : dimensionless coupling of h, h, h, h C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 SW2,ZMASS,HMASS,GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH, & ALPHA,FOURPI,EE2,SC2,V C REAL*8 RXHALF, RXONE, RXTWO, RTHREE, RXFOUR, RXOTE REAL*8 RXPI, RIALPH PARAMETER( RXHALF=0.5D0, RXONE=1.0D0, RXTWO=2.0D0, RTHREE=3.0D0 ) PARAMETER( RXFOUR=4.0D0, RXOTE=128.0D0 ) PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 ) C ALPHA = RXONE / RXOTE C alpha = r_one / r_ialph FOURPI = RXFOUR * RXPI EE2=ALPHA*FOURPI SC2=SW2*( RXONE - SW2 ) V = RXTWO * ZMASS*SQRT(SC2)/SQRT(EE2) C GWWH = EE2/SW2*RXHALF*V GZZH = EE2/SC2*RXHALF*V GHHH = -HMASS**2/V*RTHREE GWWHH = EE2/SW2*RXHALF GZZHH = EE2/SC2*RXHALF GHHHH = -(HMASS/V)**2*RTHREE C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE COUP4X(SW2,ZMASS,FMASS , GCHF) C C This subroutine sets up the coupling constant for the fermion-fermion- C Higgs vertex in the STANDARD MODEL. The coupling is COMPLEX and the C array of the coupling specifies the chirality of the flowing-IN C fermion. GCHF(1) denotes a left-handed coupling, and GCHF(2) a right- C handed coupling. C C INPUT: C real SW2 : square of sine of the weak angle C real ZMASS : Z mass C real FMASS : fermion mass C C OUTPUT: C complex GCHF(2) : coupling of fermion and Higgs C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 GCHF(2) REAL*8 SW2,ZMASS,FMASS,ALPHA,FOURPI,EZ,G C ALPHA=1.D0/128.D0 C ALPHA=1./REAL(137.0359895) FOURPI=4.D0*3.14159265358979323846D0 EZ=SQRT(ALPHA*FOURPI)/SQRT(SW2*(1.D0-SW2)) G=EZ*FMASS*0.5D0/ZMASS C GCHF(1) = DCMPLX( -G ) GCHF(2) = DCMPLX( -G ) C RETURN END C C ====================================================================== C SUBROUTINE EAIXXX(EB,EA,SHLF,CHLF,PHI,NHE,NHA , EAI) C C This subroutine computes an off-shell electron wavefunction after C emitting a photon from the electron beam, with a special care for the C small angle region. The momenta are measured in the laboratory frame, C where the e- beam is along the positive z axis. C C INPUT: C real EB : energy (GeV) of beam e- C real EA : energy (GeV) of final photon C real SHLF : sin(theta/2) of final photon C real CHLF : cos(theta/2) of final photon C real PHI : azimuthal angle of final photon C integer NHE = -1 or 1 : helicity of beam e- C integer NHA = -1 or 1 : helicity of final photon C C OUTPUT: C complex EAI(6) : off-shell electron |e',A,e> C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 EAI(6),PHS REAL*8 EB,EA,SHLF,CHLF,PHI,ME,ALPHA,GAL,RNHE,X,C,S,D,COEFF, & XNNP,XNNM,SNP,CSP INTEGER NHE,NHA,NN C ME = 0.51099906D-3 ALPHA=1./128. GAL =SQRT(ALPHA*4.*3.14159265D0) C NN=NHA*NHE RNHE=NHE X=EA/EB C=(CHLF+SHLF)*(CHLF-SHLF) S=2.*CHLF*SHLF D=-1./(EA*EB*(4.*SHLF**2+(ME/EB)**2*C)) COEFF=-NN*GAL*SQRT(EB)*D XNNP=X*(1+NN) XNNM=X*(1-NN) SNP=SIN(PHI) CSP=COS(PHI) PHS=DCMPLX( CSP , RNHE*SNP ) C EAI((5-3*NHE)/2) = -RNHE*COEFF*ME*S*(1.+XNNP*.5) EAI((5-NHE)/2) = XNNP*COEFF*ME*CHLF**2*PHS EAI((5+NHE)/2) = RNHE*COEFF*EB*S*(-2.+XNNM) EAI((5+3*NHE)/2) = XNNM*COEFF*EB*SHLF**2*PHS*2. C EAI(5) = EB*DCMPLX( 1.-X , 1.-X*C ) EAI(6) = -EB*X*S*DCMPLX( CSP , SNP ) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE EAOXXX(EB,EA,SHLF,CHLF,PHI,NHE,NHA , EAO) C C This subroutine computes an off-shell positron wavefunction after C emitting a photon from the positron beam, with a special care for the C small angle region. The momenta are measured in the laboratory frame, C where the e+ beam is along the negative z axis. C C INPUT: C real EB : energy (GeV) of beam e+ C real EA : energy (GeV) of final photon C real SHLF : sin(theta/2) of final photon C real CHLF : cos(theta/2) of final photon C real PHI : azimuthal angle of final photon C integer NHE = -1 or 1 : helicity of beam e+ C integer NHA = -1 or 1 : helicity of final photon C C OUTPUT: C complex EAO(6) : off-shell positron C complex*16 sc(3) : input scalar s C complex*16 gc(2) : coupling constants gchf C real*8 fmass : mass of output fermion f' C real*8 fwidth : width of output fermion f' C C output: C complex fsi(6) : off-shell fermion |f',s,fi> C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),SC(3),FSI(6),GC(2),SL1,SL2,SR1,SR2,DS REAL*8 PF(0:3),FMASS,FWIDTH,PF2,P0P3,P0M3 C FSI(5) = FI(5)-SC(2) FSI(6) = FI(6)-SC(3) C PF(0)=DBLE( FSI(5)) PF(1)=DBLE( FSI(6)) PF(2)=DIMAG(FSI(6)) PF(3)=DIMAG(FSI(5)) PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2) C DS=-SC(1)/DCMPLX(PF2-FMASS**2,MAX(DSIGN(FMASS*FWIDTH ,PF2),0D0)) P0P3=PF(0)+PF(3) P0M3=PF(0)-PF(3) SL1=GC(1)*(P0P3*FI(1)+DCONJG(FSI(6))*FI(2)) SL2=GC(1)*(P0M3*FI(2) +FSI(6) *FI(1)) SR1=GC(2)*(P0M3*FI(3)-DCONJG(FSI(6))*FI(4)) SR2=GC(2)*(P0P3*FI(4) -FSI(6) *FI(3)) C FSI(1) = ( GC(1)*FMASS*FI(1) + SR1 )*DS FSI(2) = ( GC(1)*FMASS*FI(2) + SR2 )*DS FSI(3) = ( GC(2)*FMASS*FI(3) + SL1 )*DS FSI(4) = ( GC(2)*FMASS*FI(4) + SL2 )*DS C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE FSOXXX(FO,SC,GC,FMASS,FWIDTH , FSO) C C this subroutine computes an off-shell fermion wavefunction from a C flowing-out external fermion and a vector boson. C C input: C complex*16 fo(6) : flow-out fermion C complex vc(6) : input vector v C real g(2) : coupling constants gvf C real fmass : mass of output fermion f' C real fwidth : width of output fermion f' C C output: C complex fvi(6) : off-shell fermion |f',v,fi> C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),VC(6),FVI(6),SL1,SL2,SR1,SR2,D REAL*8 G(2),PF(0:3),FMASS,FWIDTH,PF2 REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) COMPLEX*16 CXIMAG C LOGICAL FIRST SAVE CXIMAG,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXIMAG=DCMPLX( RXZERO, RXONE ) ENDIF C FVI(5) = FI(5)-VC(5) FVI(6) = FI(6)-VC(6) C PF(0)=DBLE( FVI(5)) PF(1)=DBLE( FVI(6)) PF(2)=DIMAG(FVI(6)) PF(3)=DIMAG(FVI(5)) PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2) C D=-RXONE/DCMPLX( PF2-FMASS**2,MAX(SIGN(FMASS*FWIDTH,PF2),RXZERO)) SL1= (VC(1)+ VC(4))*FI(1) & +(VC(2)-CXIMAG*VC(3))*FI(2) SL2= (VC(2)+CXIMAG*VC(3))*FI(1) & +(VC(1)- VC(4))*FI(2) C IF ( G(2) .NE. RXZERO ) THEN SR1= (VC(1)- VC(4))*FI(3) & -(VC(2)-CXIMAG*VC(3))*FI(4) SR2=-(VC(2)+CXIMAG*VC(3))*FI(3) & +(VC(1)+ VC(4))*FI(4) C FVI(1) = ( G(1)*((PF(0)-PF(3))*SL1 -DCONJG(FVI(6))*SL2) & +G(2)*FMASS*SR1)*D FVI(2) = ( G(1)*( -FVI(6)*SL1 +(PF(0)+PF(3))*SL2) & +G(2)*FMASS*SR2)*D FVI(3) = ( G(2)*((PF(0)+PF(3))*SR1 +DCONJG(FVI(6))*SR2) & +G(1)*FMASS*SL1)*D FVI(4) = ( G(2)*( FVI(6)*SR1 +(PF(0)-PF(3))*SR2) & +G(1)*FMASS*SL2)*D C ELSE FVI(1) = G(1)*((PF(0)-PF(3))*SL1 -DCONJG(FVI(6))*SL2)*D FVI(2) = G(1)*( -FVI(6)*SL1 +(PF(0)+PF(3))*SL2)*D FVI(3) = G(1)*FMASS*SL1*D FVI(4) = G(1)*FMASS*SL2*D END IF C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE FVOXXX(FO,VC,G,FMASS,FWIDTH , FVO) C C this subroutine computes an off-shell fermion wavefunction from a C flowing-out external fermion and a vector boson. C C input: C complex fo(6) : flow-out fermion C complex fo(6) : flow-out fermion ) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),HIO(3),GC(2),DN REAL*8 Q(0:3),SMASS,SWIDTH,Q2 C HIO(2) = FO(5)-FI(5) HIO(3) = FO(6)-FI(6) C Q(0)=DBLE( HIO(2)) Q(1)=DBLE( HIO(3)) Q(2)=DIMAG(HIO(3)) Q(3)=DIMAG(HIO(2)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C DN=-DCMPLX(Q2-SMASS**2,DMAX1(DSIGN(SMASS*SWIDTH,Q2),0.D0)) C HIO(1) = ( GC(1)*(FO(1)*FI(1)+FO(2)*FI(2)) & +GC(2)*(FO(3)*FI(3)+FO(4)*FI(4)) )/DN C RETURN END C ---------------------------------------------------------------------- C SUBROUTINE HSSSXX(S1,S2,S3,G,SMASS,SWIDTH , HSSS) C C This subroutine computes an off-shell scalar current from the four- C scalar coupling. C C INPUT: C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C complex S3(3) : third scalar S3 C real G : coupling constant GHHHH C real SMASS : mass of OUTPUT scalar S' C real SWIDTH : width of OUTPUT scalar S' C C OUTPUT: C complex HSSS(3) : scalar current J(S':S1,S2,S3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 S1(3),S2(3),S3(3),HSSS(3),DG REAL*8 Q(0:3),G,SMASS,SWIDTH,Q2 C HSSS(2) = S1(2)+S2(2)+S3(2) HSSS(3) = S1(3)+S2(3)+S3(3) C Q(0)=DBLE( HSSS(2)) Q(1)=DBLE( HSSS(3)) Q(2)=DIMAG(HSSS(3)) Q(3)=DIMAG(HSSS(2)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C DG=-G/DCMPLX( Q2-SMASS**2,MAX(SIGN(SMASS*SWIDTH ,Q2),0.D0)) C HSSS(1) = DG * S1(1)*S2(1)*S3(1) C RETURN END C ---------------------------------------------------------------------- C SUBROUTINE HSSXXX(S1,S2,G,SMASS,SWIDTH , HSS) C C This subroutine computes an off-shell scalar current from the three- C scalar coupling. C C INPUT: C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C real G : coupling constant GHHH C real SMASS : mass of OUTPUT scalar S' C real SWIDTH : width of OUTPUT scalar S' C C OUTPUT: C complex HSS(3) : scalar current J(S':S1,S2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 S1(3),S2(3),HSS(3),DG REAL*8 Q(0:3),G,SMASS,SWIDTH,Q2 C HSS(2) = S1(2)+S2(2) HSS(3) = S1(3)+S2(3) C Q(0)=DBLE( HSS(2)) Q(1)=DBLE( HSS(3)) Q(2)=DIMAG(HSS(3)) Q(3)=DIMAG(HSS(2)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C DG=-G/DCMPLX( Q2-SMASS**2, MAX(SIGN(SMASS*SWIDTH ,Q2),0.D0)) C HSS(1) = DG*S1(1)*S2(1) C RETURN END C C ====================================================================== C ---------------------------------------------------------------------- C SUBROUTINE HVSXXX(VC,SC,G,SMASS,SWIDTH , HVS) C C this subroutine computes an off-shell scalar current from the vector- C scalar-scalar coupling. the coupling is absent in the minimal sm in C unitary gauge. C C input: C complex vc(6) : input vector v C complex sc(3) : input scalar s C complex g : coupling constant (s charge) C real smass : mass of output scalar s' C real swidth : width of output scalar s' C C examples of the coupling constant g for susy particles are as follows: C ----------------------------------------------------------- C | s1 | (q,i3) of s1 || v=a | v=z | v=w | C ----------------------------------------------------------- C | nu~_l | ( 0 , +1/2) || --- | gzn(1) | gwf(1) | C | e~_l | ( -1 , -1/2) || gal(1) | gzl(1) | gwf(1) | C | u~_l | (+2/3 , +1/2) || gau(1) | gzu(1) | gwf(1) | C | d~_l | (-1/3 , -1/2) || gad(1) | gzd(1) | gwf(1) | C ----------------------------------------------------------- C | e~_r-bar | ( +1 , 0 ) || -gal(2) | -gzl(2) | -gwf(2) | C | u~_r-bar | (-2/3 , 0 ) || -gau(2) | -gzu(2) | -gwf(2) | C | d~_r-bar | (+1/3 , 0 ) || -gad(2) | -gzd(2) | -gwf(2) | C ----------------------------------------------------------- C where the sc charge is defined by the flowing-out quantum number. C C output: C complex hvs(3) : scalar current j(s':v,s) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 VC(6),SC(3),HVS(3),DG,QVV,QPV,G REAL*8 QV(0:3),QP(0:3),QA(0:3),SMASS,SWIDTH,Q2 C HVS(2) = VC(5)+SC(2) HVS(3) = VC(6)+SC(3) C QV(0)=DBLE( VC(5)) QV(1)=DBLE( VC(6)) QV(2)=DIMAG( VC(6)) QV(3)=DIMAG( VC(5)) QP(0)=DBLE( SC(2)) QP(1)=DBLE( SC(3)) QP(2)=DIMAG( SC(3)) QP(3)=DIMAG( SC(2)) QA(0)=DBLE( HVS(2)) QA(1)=DBLE( HVS(3)) QA(2)=DIMAG(HVS(3)) QA(3)=DIMAG(HVS(2)) Q2=QA(0)**2-(QA(1)**2+QA(2)**2+QA(3)**2) C DG=-G/DCMPLX( Q2-SMASS**2 , MAX(DSIGN( SMASS*SWIDTH ,Q2),0D0) ) QVV=QV(0)*VC(1)-QV(1)*VC(2)-QV(2)*VC(3)-QV(3)*VC(4) QPV=QP(0)*VC(1)-QP(1)*VC(2)-QP(2)*VC(3)-QP(3)*VC(4) C HVS(1) = DG*(2D0*QPV+QVV)*SC(1) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE HVVXXX(V1,V2,G,SMASS,SWIDTH , HVV) C C this subroutine computes an off-shell scalar current from the vector- C vector-scalar coupling. C C input: C complex v1(6) : first vector v1 C complex v2(6) : second vector v2 C real g : coupling constant gvvh C real smass : mass of output scalar s C real swidth : width of output scalar s C C output: C complex hvv(3) : off-shell scalar current j(s:v1,v2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 V1(6),V2(6),HVV(3),DG REAL*8 Q(0:3),G,SMASS,SWIDTH,Q2 REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C HVV(2) = V1(5)+V2(5) HVV(3) = V1(6)+V2(6) C Q(0)=DBLE( HVV(2)) Q(1)=DBLE( HVV(3)) Q(2)=DIMAG(HVV(3)) Q(3)=DIMAG(HVV(2)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C DG=-G/DCMPLX( Q2-SMASS**2 , MAX(SIGN( SMASS*SWIDTH ,Q2),RXZERO) ) C HVV(1) = DG*(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4)) C RETURN END C C ====================================================================== C SUBROUTINE IOSXXX(FI,FO,SC,GC , VERTEX) C C This subroutine computes an amplitude of the fermion-fermion-scalar C coupling. C C INPUT: C complex FI(6) : flow-in fermion |FI> C complex FO(6) : flow-out fermion C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),SC(3),GC(2),VERTEX C VERTEX = SC(1)*( GC(1)*(FI(1)*FO(1)+FI(2)*FO(2)) & +GC(2)*(FI(3)*FO(3)+FI(4)*FO(4)) ) C RETURN END C C ====================================================================== C SUBROUTINE IOVXXX(FI,FO,VC,G , VERTEX) C C this subroutine computes an amplitude of the fermion-fermion-vector C coupling. C C input: C complex fi(6) : flow-in fermion |fi> C complex fo(6) : flow-out fermion C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),VC(6),VERTEX REAL*8 G(2) REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) COMPLEX*16 CXIMAG LOGICAL FIRST SAVE CXIMAG,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXIMAG=DCMPLX( RXZERO, RXONE ) ENDIF C VERTEX = G(1)*( (FO(3)*FI(1)+FO(4)*FI(2))*VC(1) & +(FO(3)*FI(2)+FO(4)*FI(1))*VC(2) & -(FO(3)*FI(2)-FO(4)*FI(1))*VC(3)*CXIMAG & +(FO(3)*FI(1)-FO(4)*FI(2))*VC(4) ) C IF ( G(2) .NE. RXZERO ) THEN VERTEX = VERTEX & + G(2)*( (FO(1)*FI(3)+FO(2)*FI(4))*VC(1) & -(FO(1)*FI(4)+FO(2)*FI(3))*VC(2) & +(FO(1)*FI(4)-FO(2)*FI(3))*VC(3)*CXIMAG & -(FO(1)*FI(3)-FO(2)*FI(4))*VC(4) ) END IF C RETURN END C C Subroutine returns the desired fermion or C anti-fermion spinor. ie., |f> C A replacement for the HELAS routine IXXXXX C C Adam Duff, 1992 August 31 C C SUBROUTINE IXXXXX(P,FMASS,NHEL,NSF,FI) C P IN: FOUR VECTOR MOMENTUM C FMASS IN: FERMION MASS C NHEL IN: SPINOR HELICITY, -1 OR 1 C NSF IN: -1=ANTIFERMION, 1=FERMION C FI OUT: FERMION WAVEFUNCTION C C declare input/output variables C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6) INTEGER*4 NHEL, NSF REAL*8 P(0:3), FMASS REAL*8 RXZERO, RXONE, RXTWO PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 ) REAL*8 PLAT, PABS, OMEGAP, OMEGAM, RS2PA, SPAZ COMPLEX*16 CXZERO C C declare local variables C LOGICAL FIRST SAVE CXZERO,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXZERO=DCMPLX( RXZERO, RXZERO ) ENDIF C C define kinematic parameters C FI(5) = DCMPLX( P(0), P(3) ) * NSF FI(6) = DCMPLX( P(1), P(2) ) * NSF PLAT = SQRT( P(1)**2 + P(2)**2 ) PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 ) OMEGAP = SQRT( P(0) + PABS ) C C do massive fermion case C IF ( FMASS .NE. RXZERO ) THEN OMEGAM = FMASS / OMEGAP IF ( NSF .EQ. 1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( OMEGAM, RXZERO ) FI(2) = CXZERO FI(3) = DCMPLX( OMEGAP, RXZERO ) FI(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FI(1) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(2) = OMEGAM * RS2PA / SPAZ & * DCMPLX( P(1), P(2) ) FI(3) = OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(4) = OMEGAP * RS2PA / SPAZ & * DCMPLX( P(1), P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( OMEGAM, RXZERO ) FI(3) = CXZERO FI(4) = DCMPLX( OMEGAP, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FI(1) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(2) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), P(2) ) FI(3) = OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(4) = OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), P(2) ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( OMEGAP, RXZERO ) FI(3) = CXZERO FI(4) = DCMPLX( OMEGAM, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FI(1) = OMEGAP * RS2PA / SPAZ & * DCMPLX( -P(1), P(2) ) FI(2) = OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(3) = OMEGAM * RS2PA / SPAZ & * DCMPLX( -P(1), P(2) ) FI(4) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( -OMEGAP, RXZERO ) FI(2) = CXZERO FI(3) = DCMPLX( -OMEGAM, RXZERO ) FI(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FI(1) = OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(2) = OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(3) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(4) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE STOP 'IXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE IF ( NSF .EQ. -1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( -OMEGAP, RXZERO ) FI(3) = CXZERO FI(4) = DCMPLX( OMEGAM, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FI(1) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( -P(1), P(2) ) FI(2) = -OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(3) = OMEGAM * RS2PA / SPAZ & * DCMPLX( -P(1), P(2) ) FI(4) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( OMEGAP, RXZERO ) FI(2) = CXZERO FI(3) = DCMPLX( -OMEGAM, RXZERO ) FI(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FI(1) = -OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(2) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(3) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(4) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( OMEGAM, RXZERO ) FI(2) = CXZERO FI(3) = DCMPLX( -OMEGAP, RXZERO ) FI(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FI(1) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(2) = OMEGAM * RS2PA / SPAZ & * DCMPLX( P(1), P(2) ) FI(3) = -OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FI(4) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( P(1), P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( OMEGAM, RXZERO ) FI(3) = CXZERO FI(4) = DCMPLX( -OMEGAP, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FI(1) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(2) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), P(2) ) FI(3) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(4) = -OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), P(2) ) END IF END IF ELSE STOP 'IXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE STOP 'IXXXXX: FERMION TYPE MUST BE +1,-1' END IF C C do massless fermion case C ELSE IF ( NSF .EQ. 1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = CXZERO FI(3) = DCMPLX( OMEGAP, RXZERO ) FI(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FI(1) = CXZERO FI(2) = CXZERO FI(3) = DCMPLX( SPAZ, RXZERO ) FI(4) = RXONE / SPAZ & * DCMPLX( P(1), P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = CXZERO FI(3) = CXZERO FI(4) = DCMPLX( OMEGAP, RXZERO ) ELSE SPAZ = SQRT( PABS - P(3) ) FI(1) = CXZERO FI(2) = CXZERO FI(3) = RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(4) = SPAZ / PLAT & * DCMPLX( P(1), P(2) ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( OMEGAP, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FI(1) = RXONE / SPAZ & * DCMPLX( -P(1), P(2) ) FI(2) = DCMPLX( SPAZ, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( -OMEGAP, RXZERO ) FI(2) = CXZERO FI(3) = CXZERO FI(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FI(1) = SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(2) = RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO END IF END IF ELSE STOP 'IXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE IF ( NSF .EQ. -1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = DCMPLX( -OMEGAP, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FI(1) = -RXONE / SPAZ & * DCMPLX( -P(1), P(2) ) FI(2) = DCMPLX( -SPAZ, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = DCMPLX( OMEGAP, RXZERO ) FI(2) = CXZERO FI(3) = CXZERO FI(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FI(1) = -SPAZ / PLAT & * DCMPLX( -P(1), P(2) ) FI(2) = -RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(3) = CXZERO FI(4) = CXZERO END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = CXZERO FI(3) = DCMPLX( -OMEGAP, RXZERO ) FI(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FI(1) = CXZERO FI(2) = CXZERO FI(3) = DCMPLX( -SPAZ, RXZERO ) FI(4) = -RXONE / SPAZ & * DCMPLX( P(1), P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FI(1) = CXZERO FI(2) = CXZERO FI(3) = CXZERO FI(4) = DCMPLX( -OMEGAP, RXZERO ) ELSE SPAZ = SQRT( PABS - P(3) ) FI(1) = CXZERO FI(2) = CXZERO FI(3) = -RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FI(4) = -SPAZ / PLAT & * DCMPLX( P(1), P(2) ) END IF END IF ELSE STOP 'IXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE STOP 'IXXXXX: FERMION TYPE MUST BE +1,-1' END IF END IF C C done C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE J3XXXX(FI,FO,GAF,GZF,ZMASS,ZWIDTH , J3) C C this subroutine computes the sum of photon and z currents with the C suitable weights ( j(w3) = cos(theta_w) j(z) + sin(theta_w) j(a) ). C the output j3 is useful as an input of vvvxxx, jvvxxx or w3w3xx. C the photon propagator is given in feynman gauge, and the z propagator C is given in unitary gauge. C C input: C complex fi(6) : flow-in fermion |fi> C complex fo(6) : flow-out fermion ) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),J3(6), & C0L,C1L,C2L,C3L,CSL,C0R,C1R,C2R,C3R,CSR,DZ,DDIF REAL*8 GAF(2),GZF(2),Q(0:3),ZMASS,ZWIDTH,ZM2,ZMW,Q2,DA,WW, & CW,SW,GN,GZ3L,GA3L C REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) COMPLEX*16 CXIMAG LOGICAL FIRST SAVE CXIMAG,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXIMAG=DCMPLX( RXZERO, RXONE ) ENDIF C J3(5) = FO(5)-FI(5) J3(6) = FO(6)-FI(6) C Q(0)=-DBLE( J3(5)) Q(1)=-DBLE( J3(6)) Q(2)=-DIMAG(J3(6)) Q(3)=-DIMAG(J3(5)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) ZM2=ZMASS**2 ZMW=ZMASS*ZWIDTH C DA=RXONE/Q2 WW=MAX(DSIGN( ZMW ,Q2),RXZERO) DZ=RXONE/DCMPLX( Q2-ZM2 , WW ) DDIF=DCMPLX( -ZM2 , WW )*DA*DZ C C ddif is the difference : ddif=da-dz C for the running width, use below instead of the above ww,dz and ddif. C ww=max( zwidth*q2/zmass ,r_zero) C dz=r_one/dcmplx( q2-zm2 , ww ) C ddif=dcmplx( -zm2 , ww )*da*dz C CW=RXONE/SQRT(RXONE+(GZF(2)/GAF(2))**2) SW=SQRT((RXONE-CW)*(RXONE+CW)) GN=GAF(2)*SW GZ3L=GZF(1)*CW GA3L=GAF(1)*SW C0L= FO(3)*FI(1)+FO(4)*FI(2) C0R= FO(1)*FI(3)+FO(2)*FI(4) C1L=-(FO(3)*FI(2)+FO(4)*FI(1)) C1R= FO(1)*FI(4)+FO(2)*FI(3) C2L= (FO(3)*FI(2)-FO(4)*FI(1))*CXIMAG C2R=(-FO(1)*FI(4)+FO(2)*FI(3))*CXIMAG C3L= -FO(3)*FI(1)+FO(4)*FI(2) C3R= FO(1)*FI(3)-FO(2)*FI(4) CSL=(Q(0)*C0L-Q(1)*C1L-Q(2)*C2L-Q(3)*C3L)/ZM2 CSR=(Q(0)*C0R-Q(1)*C1R-Q(2)*C2R-Q(3)*C3R)/ZM2 C J3(1) = GZ3L*DZ*(C0L-CSL*Q(0))+GA3L*C0L*DA & + GN*(C0R*DDIF-CSR*Q(0)*DZ) J3(2) = GZ3L*DZ*(C1L-CSL*Q(1))+GA3L*C1L*DA & + GN*(C1R*DDIF-CSR*Q(1)*DZ) J3(3) = GZ3L*DZ*(C2L-CSL*Q(2))+GA3L*C2L*DA & + GN*(C2R*DDIF-CSR*Q(2)*DZ) J3(4) = GZ3L*DZ*(C3L-CSL*Q(3))+GA3L*C3L*DA & + GN*(C3R*DDIF-CSR*Q(3)*DZ) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JEEXXX(EB,EF,SHLF,CHLF,PHI,NHB,NHF,NSF , JEE) C C This subroutine computes an off-shell photon wavefunction emitted from C the electron or positron beam, with a special care for the small angle C region. The momenta are measured in the laboratory frame, where the C e- (e+) beam is along the positive (negative) z axis. C C INPUT: C real EB : energy (GeV) of beam e-/e+ C real EF : energy (GeV) of final e-/e+ C real SHLF : sin(theta/2) of final e-/e+ C real CHLF : cos(theta/2) of final e-/e+ C real PHI : azimuthal angle of final e-/e+ C integer NHB = -1 or 1 : helicity of beam e-/e+ C integer NHF = -1 or 1 : helicity of final e-/e+ C integer NSF = -1 or 1 : +1 for electron, -1 for positron C C OUTPUT: C complex JEE(6) : off-shell photon J^mu() C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 JEE(6),COEFF REAL*8 CS(2),EB,EF,SHLF,CHLF,PHI,ME,ALPHA,GAL,HI,SF,SFH,X,ME2,Q2, & RFP,RFM,SNP,CSP,RXC,C,S INTEGER NHB,NHF,NSF C ME =0.51099906D-3 ALPHA=1./128. GAL =SQRT(ALPHA*4.*3.14159265D0) C HI =NHB SF =NSF SFH=NHB*NSF CS((3+NSF)/2)=SHLF CS((3-NSF)/2)=CHLF C CS(1)=CHLF and CS(2)=SHLF for electron C CS(1)=SHLF and CS(2)=CHLF for positron X=EF/EB ME2=ME**2 Q2=-4.*CS(2)**2*(EF*EB-ME2) & +SF*(1.-X)**2/X*(SHLF+CHLF)*(SHLF-CHLF)*ME2 RFP=(1+NSF) RFM=(1-NSF) SNP=SIN(PHI) CSP=COS(PHI) C IF (NHB.EQ.NHF) THEN RXC=2.*X/(1.-X)*CS(1)**2 COEFF= GAL*2.*EB*SQRT(X)*CS(2)/Q2 & *(DCMPLX( RFP )-RFM*DCMPLX( CSP ,-SNP*HI ))*.5 JEE(1) = DCMPLX( 0.D0 ) JEE(2) = COEFF*DCMPLX( (1.+RXC)*CSP ,-SFH*SNP ) JEE(3) = COEFF*DCMPLX( (1.+RXC)*SNP , SFH*CSP ) JEE(4) = COEFF*(-SF*RXC/CS(1)*CS(2)) ELSE COEFF= GAL*ME/Q2/SQRT(X) & *(DCMPLX( RFP )+RFM*DCMPLX( CSP , SNP*HI ))*.5*HI JEE(1) = -COEFF*(1.+X)*CS(2)*DCMPLX( CSP , SFH*SNP ) JEE(2) = COEFF*(1.-X)*CS(1) JEE(3) = JEE(2)*DCMPLX( 0.D0 , SFH ) JEE(4) = JEE(1)*SF*(1.-X)/(1.+X) ENDIF C C=(CHLF+SHLF)*(CHLF-SHLF) S=2.*CHLF*SHLF C JEE(5) = -EB*DCMPLX( 1.-X , SF-X*C ) JEE(6) = EB*X*S*DCMPLX( CSP , SNP ) C RETURN END C C C ---------------------------------------------------------------------- C SUBROUTINE JGGGXX(W1,W2,W3,G, JW3W) C C this subroutine computes an off-shell w+, w-, w3, z or photon current C from the four-point gauge boson coupling, including the contributions C of w exchange diagrams. the vector propagator is given in feynman C gauge for a photon and in unitary gauge for w and z bosons. if one C sets wmass=0.0, then the ggg-->g current is given (see sect 2.9.1 of C the manual). C C input: C complex w1(6) : first vector w1 C complex w2(6) : second vector w2 C complex w3(6) : third vector w3 C real g : first coupling constant C (see the table below) C C output: C complex jw3w(6) : w current j^mu(w':w1,w2,w3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 W1(6),W2(6),W3(6),JW3W(6) COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3), & JJ(0:3),DV,W32,W13 REAL*8 P1(0:3),P2(0:3),P3(0:3),Q(0:3),G,DG2,Q2 C REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C JW3W(5) = W1(5)+W2(5)+W3(5) JW3W(6) = W1(6)+W2(6)+W3(6) C DW1(0)=DCMPLX(W1(1)) DW1(1)=DCMPLX(W1(2)) DW1(2)=DCMPLX(W1(3)) DW1(3)=DCMPLX(W1(4)) DW2(0)=DCMPLX(W2(1)) DW2(1)=DCMPLX(W2(2)) DW2(2)=DCMPLX(W2(3)) DW2(3)=DCMPLX(W2(4)) DW3(0)=DCMPLX(W3(1)) DW3(1)=DCMPLX(W3(2)) DW3(2)=DCMPLX(W3(3)) DW3(3)=DCMPLX(W3(4)) P1(0)=DBLE( W1(5)) P1(1)=DBLE( W1(6)) P1(2)=DBLE(DIMAG(W1(6))) P1(3)=DBLE(DIMAG(W1(5))) P2(0)=DBLE( W2(5)) P2(1)=DBLE( W2(6)) P2(2)=DBLE(DIMAG(W2(6))) P2(3)=DBLE(DIMAG(W2(5))) P3(0)=DBLE( W3(5)) P3(1)=DBLE( W3(6)) P3(2)=DBLE(DIMAG(W3(6))) P3(3)=DBLE(DIMAG(W3(5))) Q(0)=-(P1(0)+P2(0)+P3(0)) Q(1)=-(P1(1)+P2(1)+P3(1)) Q(2)=-(P1(2)+P2(2)+P3(2)) Q(3)=-(P1(3)+P2(3)+P3(3)) C Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2) C DG2=DBLE(G)*DBLE(G) C DV = 1.0D0/DCMPLX( Q2 ) C C for the running width, use below instead of the above dv. C dv = 1.0d0/dcmplx( q2 -mv2 , dmax1(dwv*q2/dmv,0.d0) ) C W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3) C C W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3) C JJ(0)=DG2*( DW1(0)*W32 - DW2(0)*W13 ) JJ(1)=DG2*( DW1(1)*W32 - DW2(1)*W13 ) JJ(2)=DG2*( DW1(2)*W32 - DW2(2)*W13 ) JJ(3)=DG2*( DW1(3)*W32 - DW2(3)*W13 ) C JW3W(1) = DCMPLX( JJ(0)*DV ) JW3W(2) = DCMPLX( JJ(1)*DV ) JW3W(3) = DCMPLX( JJ(2)*DV ) JW3W(4) = DCMPLX( JJ(3)*DV ) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JGGXXX(V1,V2,G, JVV) C C this subroutine computes an off-shell vector current from the three- C point gauge boson coupling. the vector propagator is given in feynman C gauge for a massless vector and in unitary gauge for a massive vector. C C input: C complex v1(6) : first vector v1 C complex v2(6) : second vector v2 C real g : coupling constant (see the table below) C C output: C complex jvv(6) : vector current j^mu(v:v1,v2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 V1(6),V2(6),JVV(6),J12(0:3), & SV1,SV2,V12 REAL*8 P1(0:3),P2(0:3),Q(0:3),G,GS,S C REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C JVV(5) = V1(5)+V2(5) JVV(6) = V1(6)+V2(6) C P1(0)=DBLE( V1(5)) P1(1)=DBLE( V1(6)) P1(2)=DIMAG(V1(6)) P1(3)=DIMAG(V1(5)) P2(0)=DBLE( V2(5)) P2(1)=DBLE( V2(6)) P2(2)=DIMAG(V2(6)) P2(3)=DIMAG(V2(5)) Q(0)=-DBLE( JVV(5)) Q(1)=-DBLE( JVV(6)) Q(2)=-DIMAG(JVV(6)) Q(3)=-DIMAG(JVV(5)) S=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C V12=V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4) SV1= (P2(0)-Q(0))*V1(1) -(P2(1)-Q(1))*V1(2) & -(P2(2)-Q(2))*V1(3) -(P2(3)-Q(3))*V1(4) SV2=-(P1(0)-Q(0))*V2(1) +(P1(1)-Q(1))*V2(2) & +(P1(2)-Q(2))*V2(3) +(P1(3)-Q(3))*V2(4) J12(0)=(P1(0)-P2(0))*V12 +SV1*V2(1) +SV2*V1(1) J12(1)=(P1(1)-P2(1))*V12 +SV1*V2(2) +SV2*V1(2) J12(2)=(P1(2)-P2(2))*V12 +SV1*V2(3) +SV2*V1(3) J12(3)=(P1(3)-P2(3))*V12 +SV1*V2(4) +SV2*V1(4) C GS=-G/S C JVV(1) = GS*J12(0) JVV(2) = GS*J12(1) JVV(3) = GS*J12(2) JVV(4) = GS*J12(3) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JIOXXX(FI,FO,G,VMASS,VWIDTH , JIO) C C this subroutine computes an off-shell vector current from an external C fermion pair. the vector boson propagator is given in feynman gauge C for a massless vector and in unitary gauge for a massive vector. C C input: C complex fi(6) : flow-in fermion |fi> C complex fo(6) : flow-out fermion ) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),JIO(6),C0,C1,C2,C3,CS,D REAL*8 G(2),Q(0:3),VMASS,VWIDTH,Q2,VM2,DD C REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) COMPLEX*16 CXIMAG LOGICAL FIRST SAVE CXIMAG,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXIMAG=DCMPLX( RXZERO, RXONE ) ENDIF C JIO(5) = FO(5)-FI(5) JIO(6) = FO(6)-FI(6) C Q(0)=DBLE( JIO(5)) Q(1)=DBLE( JIO(6)) Q(2)=DIMAG(JIO(6)) Q(3)=DIMAG(JIO(5)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) VM2=VMASS**2 C IF (VMASS.NE.RXZERO) THEN C D=RXONE/DCMPLX( Q2-VM2 , MAX(SIGN( VMASS*VWIDTH ,Q2),RXZERO) ) C for the running width, use below instead of the above d. C d=r_one/dcmplx( q2-vm2 , max( vwidth*q2/vmass ,r_zero) ) C IF (G(2).NE.RXZERO) THEN C C0= G(1)*( FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)+FO(2)*FI(4)) C1= -G(1)*( FO(3)*FI(2)+FO(4)*FI(1)) & +G(2)*( FO(1)*FI(4)+FO(2)*FI(3)) C2=( G(1)*( FO(3)*FI(2)-FO(4)*FI(1)) & +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3)))*CXIMAG C3= G(1)*(-FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)-FO(2)*FI(4)) ELSE C D=D*G(1) C0= FO(3)*FI(1)+FO(4)*FI(2) C1= -FO(3)*FI(2)-FO(4)*FI(1) C2=( FO(3)*FI(2)-FO(4)*FI(1))*CXIMAG C3= -FO(3)*FI(1)+FO(4)*FI(2) END IF C CS=(Q(0)*C0-Q(1)*C1-Q(2)*C2-Q(3)*C3)/VM2 C JIO(1) = (C0-CS*Q(0))*D JIO(2) = (C1-CS*Q(1))*D JIO(3) = (C2-CS*Q(2))*D JIO(4) = (C3-CS*Q(3))*D C ELSE DD=RXONE/Q2 C IF (G(2).NE.RXZERO) THEN JIO(1) = ( G(1)*( FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)+FO(2)*FI(4)) )*DD JIO(2) = (-G(1)*( FO(3)*FI(2)+FO(4)*FI(1)) & +G(2)*( FO(1)*FI(4)+FO(2)*FI(3)) )*DD JIO(3) = ( G(1)*( FO(3)*FI(2)-FO(4)*FI(1)) & +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3))) $ *DCMPLX(RXZERO,DD) JIO(4) = ( G(1)*(-FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)-FO(2)*FI(4)) )*DD C ELSE DD=DD*G(1) C JIO(1) = ( FO(3)*FI(1)+FO(4)*FI(2))*DD JIO(2) = -( FO(3)*FI(2)+FO(4)*FI(1))*DD JIO(3) = ( FO(3)*FI(2)-FO(4)*FI(1))*DCMPLX(RXZERO,DD) JIO(4) = (-FO(3)*FI(1)+FO(4)*FI(2))*DD END IF END IF C RETURN END C ---------------------------------------------------------------------- C SUBROUTINE JSSXXX(S1,S2,G,VMASS,VWIDTH , JSS) C C This subroutine computes an off-shell vector current from the vector- C scalar-scalar coupling. The coupling is absent in the minimal SM in C unitary gauge. The propagator is given in Feynman gauge for a C massless vector and in unitary gauge for a massive vector. C C INPUT: C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C real G : coupling constant (S1 charge) C real VMASS : mass of OUTPUT vector V C real VWIDTH : width of OUTPUT vector V C C Examples of the coupling constant G for SUSY particles are as follows: C ----------------------------------------------------------- C | S1 | (Q,I3) of S1 || V=A | V=Z | V=W | C ----------------------------------------------------------- C | nu~_L | ( 0 , +1/2) || --- | GZN(1) | GWF(1) | C | e~_L | ( -1 , -1/2) || GAL(1) | GZL(1) | GWF(1) | C | u~_L | (+2/3 , +1/2) || GAU(1) | GZU(1) | GWF(1) | C | d~_L | (-1/3 , -1/2) || GAD(1) | GZD(1) | GWF(1) | C ----------------------------------------------------------- C | e~_R-bar | ( +1 , 0 ) || -GAL(2) | -GZL(2) | -GWF(2) | C | u~_R-bar | (-2/3 , 0 ) || -GAU(2) | -GZU(2) | -GWF(2) | C | d~_R-bar | (+1/3 , 0 ) || -GAD(2) | -GZD(2) | -GWF(2) | C ----------------------------------------------------------- C where the S1 charge is defined by the flowing-OUT quantum number. C C OUTPUT: C complex JSS(6) : vector current J^mu(V:S1,S2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 S1(3),S2(3),JSS(6),DG,ADG REAL*8 PP(0:3),PA(0:3),Q(0:3),G,VMASS,VWIDTH,Q2,VM2,MP2,MA2,M2D C JSS(5) = S1(2)+S2(2) JSS(6) = S1(3)+S2(3) C Q(0)=DBLE( JSS(5)) Q(1)=DBLE( JSS(6)) Q(2)=DIMAG(JSS(6)) Q(3)=DIMAG(JSS(5)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) VM2=VMASS**2 C IF (VMASS.EQ.0.) GOTO 10 C DG=G/DCMPLX( Q2-VM2, MAX(SIGN( VMASS*VWIDTH ,Q2),0.D0)) C For the running width, use below instead of the above DG. C DG=G/dCMPLX( Q2-VM2 , MAX( VWIDTH*Q2/VMASS ,0.) ) C ADG=DG*S1(1)*S2(1) C PP(0)=DBLE( S1(2)) PP(1)=DBLE( S1(3)) PP(2)=DIMAG(S1(3)) PP(3)=DIMAG(S1(2)) PA(0)=DBLE( S2(2)) PA(1)=DBLE( S2(3)) PA(2)=DIMAG(S2(3)) PA(3)=DIMAG(S2(2)) MP2=PP(0)**2-(PP(1)**2+PP(2)**2+PP(3)**2) MA2=PA(0)**2-(PA(1)**2+PA(2)**2+PA(3)**2) M2D=MP2-MA2 C JSS(1) = ADG*( (PP(0)-PA(0)) - Q(0)*M2D/VM2) JSS(2) = ADG*( (PP(1)-PA(1)) - Q(1)*M2D/VM2) JSS(3) = ADG*( (PP(2)-PA(2)) - Q(2)*M2D/VM2) JSS(4) = ADG*( (PP(3)-PA(3)) - Q(3)*M2D/VM2) C RETURN C 10 ADG=G*S1(1)*S2(1)/Q2 C JSS(1) = ADG*DBLE( S1(2)-S2(2)) JSS(2) = ADG*DBLE( S1(3)-S2(3)) JSS(3) = ADG*DIMAG(S1(3)-S2(3)) JSS(4) = ADG*DIMAG(S1(2)-S2(2)) C RETURN END C C C ---------------------------------------------------------------------- C SUBROUTINE JTIOXX(FI,FO,G , JIO) C C this subroutine computes an off-shell vector current from an external C fermion pair. the vector boson propagator is not included in this C routine. C C input: C complex fi(6) : flow-in fermion |fi> C complex fo(6) : flow-out fermion ) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FI(6),FO(6),JIO(6) REAL*8 G(2) C REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) COMPLEX*16 CXIMAG LOGICAL FIRST SAVE CXIMAG,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXIMAG=DCMPLX( RXZERO, RXONE ) ENDIF C JIO(5) = FO(5)-FI(5) JIO(6) = FO(6)-FI(6) C IF ( G(2) .NE. RXZERO ) THEN JIO(1) = ( G(1)*( FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)+FO(2)*FI(4)) ) JIO(2) = (-G(1)*( FO(3)*FI(2)+FO(4)*FI(1)) & +G(2)*( FO(1)*FI(4)+FO(2)*FI(3)) ) JIO(3) = ( G(1)*( FO(3)*FI(2)-FO(4)*FI(1)) & +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3)) )*CXIMAG JIO(4) = ( G(1)*(-FO(3)*FI(1)+FO(4)*FI(2)) & +G(2)*( FO(1)*FI(3)-FO(2)*FI(4)) ) C ELSE JIO(1) = ( FO(3)*FI(1)+FO(4)*FI(2))*G(1) JIO(2) = -( FO(3)*FI(2)+FO(4)*FI(1))*G(1) JIO(3) = ( FO(3)*FI(2)-FO(4)*FI(1))*DCMPLX(RXZERO,G(1)) JIO(4) = (-FO(3)*FI(1)+FO(4)*FI(2))*G(1) END IF C RETURN END C ---------------------------------------------------------------------- C SUBROUTINE JVSSXX(VC,S1,S2,G,VMASS,VWIDTH , JVSS) C C This subroutine computes an off-shell vector current from the vector- C vector-scalar-scalar coupling. The vector propagator is given in C Feynman gauge for a massless vector and in unitary gauge for a massive C vector. C C INPUT: C complex VC(6) : input vector V C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C real G : coupling constant GVVHH C real VMASS : mass of OUTPUT vector V' C real VWIDTH : width of OUTPUT vector V' C C OUTPUT: C complex JVSS(6) : vector current J^mu(V':V,S1,S2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 VC(6),S1(3),S2(3),JVSS(6),DG REAL*8 Q(0:3),G,VMASS,VWIDTH,Q2,VK,VM2 C JVSS(5) = VC(5)+S1(2)+S2(2) JVSS(6) = VC(6)+S1(3)+S2(3) C Q(0)=DBLE( JVSS(5)) Q(1)=DBLE( JVSS(6)) Q(2)=DIMAG(JVSS(6)) Q(3)=DIMAG(JVSS(5)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) VM2=VMASS**2 C IF (VMASS.EQ.0.) GOTO 10 C DG=G*S1(1)*S2(1)/DCMPLX( Q2-VM2,MAX(SIGN( VMASS*VWIDTH,Q2),0.D0)) C For the running width, use below instead of the above DG. C DG=G*S1(1)*S2(1)/CMPLX( Q2-VM2 , MAX( VWIDTH*Q2/VMASS ,0.)) C VK=(Q(0)*VC(1)-Q(1)*VC(2)-Q(2)*VC(3)-Q(3)*VC(4))/VM2 C JVSS(1) = DG*(VC(1)-VK*Q(0)) JVSS(2) = DG*(VC(2)-VK*Q(1)) JVSS(3) = DG*(VC(3)-VK*Q(2)) JVSS(4) = DG*(VC(4)-VK*Q(3)) C RETURN C 10 DG= G*S1(1)*S2(1)/Q2 C JVSS(1) = DG*VC(1) JVSS(2) = DG*VC(2) JVSS(3) = DG*VC(3) JVSS(4) = DG*VC(4) C RETURN END C C C ---------------------------------------------------------------------- C SUBROUTINE JVSXXX(VC,SC,G,VMASS,VWIDTH , JVS) C C this subroutine computes an off-shell vector current from the vector- C vector-scalar coupling. the vector propagator is given in feynman C gauge for a massless vector and in unitary gauge for a massive vector. C C input: C complex vc(6) : input vector v C complex sc(3) : input scalar s C real g : coupling constant gvvh C real vmass : mass of output vector v' C real vwidth : width of output vector v' C C output: C complex jvs(6) : vector current j^mu(v':v,s) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 VC(6),SC(3),JVS(6),DG,VK REAL*8 Q(0:3),VMASS,VWIDTH,Q2,VM2,G C JVS(5) = VC(5)+SC(2) JVS(6) = VC(6)+SC(3) C Q(0)=DBLE( JVS(5)) Q(1)=DBLE( JVS(6)) Q(2)=DIMAG(JVS(6)) Q(3)=DIMAG(JVS(5)) Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) VM2=VMASS**2 C IF (VMASS.EQ.0.) GOTO 10 C DG=G*SC(1)/DCMPLX( Q2-VM2 , MAX(DSIGN( VMASS*VWIDTH ,Q2),0.D0) ) C for the running width, use below instead of the above dg. C dg=g*sc(1)/dcmplx( q2-vm2 , max( vwidth*q2/vmass ,0.) ) C VK=(-Q(0)*VC(1)+Q(1)*VC(2)+Q(2)*VC(3)+Q(3)*VC(4))/VM2 C JVS(1) = DG*(Q(0)*VK+VC(1)) JVS(2) = DG*(Q(1)*VK+VC(2)) JVS(3) = DG*(Q(2)*VK+VC(3)) JVS(4) = DG*(Q(3)*VK+VC(4)) C RETURN C 10 DG=G*SC(1)/Q2 C JVS(1) = DG*VC(1) JVS(2) = DG*VC(2) JVS(3) = DG*VC(3) JVS(4) = DG*VC(4) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JVVXXX(V1,V2,G,VMASS,VWIDTH , JVV) C C this subroutine computes an off-shell vector current from the three- C point gauge boson coupling. the vector propagator is given in feynman C gauge for a massless vector and in unitary gauge for a massive vector. C C input: C complex v1(6) : first vector v1 C complex v2(6) : second vector v2 C real g : coupling constant (see the table below) C real vmass : mass of output vector v C real vwidth : width of output vector v C C the possible sets of the inputs are as follows: C ------------------------------------------------------------------ C | v1 | v2 | jvv | g | vmass | vwidth | C ------------------------------------------------------------------ C | w- | w+ | a/z | gwwa/gwwz | 0./zmass | 0./zwidth | C | w3/a/z | w- | w+ | gw/gwwa/gwwz | wmass | wwidth | C | w+ | w3/a/z | w- | gw/gwwa/gwwz | wmass | wwidth | C ------------------------------------------------------------------ C where all the bosons are defined by the flowing-out quantum number. C C output: C complex jvv(6) : vector current j^mu(v:v1,v2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 V1(6),V2(6),JVV(6),J12(0:3),JS,DG, & SV1,SV2,S11,S12,S21,S22,V12 REAL*8 P1(0:3),P2(0:3),Q(0:3),G,VMASS,VWIDTH,GS,S,VM2,M1,M2 C REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C JVV(5) = V1(5)+V2(5) JVV(6) = V1(6)+V2(6) C P1(0)=DBLE( V1(5)) P1(1)=DBLE( V1(6)) P1(2)=DIMAG(V1(6)) P1(3)=DIMAG(V1(5)) P2(0)=DBLE( V2(5)) P2(1)=DBLE( V2(6)) P2(2)=DIMAG(V2(6)) P2(3)=DIMAG(V2(5)) Q(0)=-DBLE( JVV(5)) Q(1)=-DBLE( JVV(6)) Q(2)=-DIMAG(JVV(6)) Q(3)=-DIMAG(JVV(5)) S=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2) C V12=V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4) SV1= (P2(0)-Q(0))*V1(1) -(P2(1)-Q(1))*V1(2) & -(P2(2)-Q(2))*V1(3) -(P2(3)-Q(3))*V1(4) SV2=-(P1(0)-Q(0))*V2(1) +(P1(1)-Q(1))*V2(2) & +(P1(2)-Q(2))*V2(3) +(P1(3)-Q(3))*V2(4) J12(0)=(P1(0)-P2(0))*V12 +SV1*V2(1) +SV2*V1(1) J12(1)=(P1(1)-P2(1))*V12 +SV1*V2(2) +SV2*V1(2) J12(2)=(P1(2)-P2(2))*V12 +SV1*V2(3) +SV2*V1(3) J12(3)=(P1(3)-P2(3))*V12 +SV1*V2(4) +SV2*V1(4) C IF ( VMASS .NE. RXZERO ) THEN VM2=VMASS**2 M1=P1(0)**2-(P1(1)**2+P1(2)**2+P1(3)**2) M2=P2(0)**2-(P2(1)**2+P2(2)**2+P2(3)**2) S11=P1(0)*V1(1)-P1(1)*V1(2)-P1(2)*V1(3)-P1(3)*V1(4) S12=P1(0)*V2(1)-P1(1)*V2(2)-P1(2)*V2(3)-P1(3)*V2(4) S21=P2(0)*V1(1)-P2(1)*V1(2)-P2(2)*V1(3)-P2(3)*V1(4) S22=P2(0)*V2(1)-P2(1)*V2(2)-P2(2)*V2(3)-P2(3)*V2(4) JS=(V12*(-M1+M2) +S11*S12 -S21*S22)/VM2 C DG=-G/DCMPLX( S-VM2 , MAX(SIGN( VMASS*VWIDTH ,S),RXZERO) ) C C for the running width, use below instead of the above dg. C dg=-g/dcmplx( s-vm2 , max( vwidth*s/vmass ,r_zero) ) C JVV(1) = DG*(J12(0)-Q(0)*JS) JVV(2) = DG*(J12(1)-Q(1)*JS) JVV(3) = DG*(J12(2)-Q(2)*JS) JVV(4) = DG*(J12(3)-Q(3)*JS) C ELSE GS=-G/S C JVV(1) = GS*J12(0) JVV(2) = GS*J12(1) JVV(3) = GS*J12(2) JVV(4) = GS*J12(3) END IF C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JW3WXX(W1,W2,W3,G1,G2,WMASS,WWIDTH,VMASS,VWIDTH , JW3W) C C this subroutine computes an off-shell w+, w-, w3, z or photon current C from the four-point gauge boson coupling, including the contributions C of w exchange diagrams. the vector propagator is given in feynman C gauge for a photon and in unitary gauge for w and z bosons. if one C sets wmass=0.0, then the ggg-->g current is given (see sect 2.9.1 of C the manual). C C input: C complex w1(6) : first vector w1 C complex w2(6) : second vector w2 C complex w3(6) : third vector w3 C real g1 : first coupling constant C real g2 : second coupling constant C (see the table below) C real wmass : mass of internal w C real wwidth : width of internal w C real vmass : mass of output w' C real vwidth : width of output w' C C the possible sets of the inputs are as follows: C ------------------------------------------------------------------- C | w1 | w2 | w3 | g1 | g2 |wmass|wwidth|vmass|vwidth || jw3w | C ------------------------------------------------------------------- C | w- | w3 | w+ | gw |gwwz|wmass|wwidth|zmass|zwidth || z | C | w- | w3 | w+ | gw |gwwa|wmass|wwidth| 0. | 0. || a | C | w- | z | w+ |gwwz|gwwz|wmass|wwidth|zmass|zwidth || z | C | w- | z | w+ |gwwz|gwwa|wmass|wwidth| 0. | 0. || a | C | w- | a | w+ |gwwa|gwwz|wmass|wwidth|zmass|zwidth || z | C | w- | a | w+ |gwwa|gwwa|wmass|wwidth| 0. | 0. || a | C ------------------------------------------------------------------- C | w3 | w- | w3 | gw | gw |wmass|wwidth|wmass|wwidth || w+ | C | w3 | w+ | w3 | gw | gw |wmass|wwidth|wmass|wwidth || w- | C | w3 | w- | z | gw |gwwz|wmass|wwidth|wmass|wwidth || w+ | C | w3 | w+ | z | gw |gwwz|wmass|wwidth|wmass|wwidth || w- | C | w3 | w- | a | gw |gwwa|wmass|wwidth|wmass|wwidth || w+ | C | w3 | w+ | a | gw |gwwa|wmass|wwidth|wmass|wwidth || w- | C | z | w- | z |gwwz|gwwz|wmass|wwidth|wmass|wwidth || w+ | C | z | w+ | z |gwwz|gwwz|wmass|wwidth|wmass|wwidth || w- | C | z | w- | a |gwwz|gwwa|wmass|wwidth|wmass|wwidth || w+ | C | z | w+ | a |gwwz|gwwa|wmass|wwidth|wmass|wwidth || w- | C | a | w- | a |gwwa|gwwa|wmass|wwidth|wmass|wwidth || w+ | C | a | w+ | a |gwwa|gwwa|wmass|wwidth|wmass|wwidth || w- | C ------------------------------------------------------------------- C where all the bosons are defined by the flowing-out quantum number. C C output: C complex jw3w(6) : w current j^mu(w':w1,w2,w3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 W1(6),W2(6),W3(6),JW3W(6) COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3), & JJ(0:3),J4(0:3), & DV,W12,W32,W13, & JQ REAL*8 G1,G2,WMASS,WWIDTH,VMASS,VWIDTH REAL*8 P1(0:3),P2(0:3),P3(0:3),Q(0:3), & DG2,DMV,DWV,MV2,Q2 C REAL*8 RXZERO PARAMETER( RXZERO=0.0D0 ) C JW3W(5) = W1(5)+W2(5)+W3(5) JW3W(6) = W1(6)+W2(6)+W3(6) C DW1(0)=DCMPLX(W1(1)) DW1(1)=DCMPLX(W1(2)) DW1(2)=DCMPLX(W1(3)) DW1(3)=DCMPLX(W1(4)) DW2(0)=DCMPLX(W2(1)) DW2(1)=DCMPLX(W2(2)) DW2(2)=DCMPLX(W2(3)) DW2(3)=DCMPLX(W2(4)) DW3(0)=DCMPLX(W3(1)) DW3(1)=DCMPLX(W3(2)) DW3(2)=DCMPLX(W3(3)) DW3(3)=DCMPLX(W3(4)) P1(0)=DBLE( W1(5)) P1(1)=DBLE( W1(6)) P1(2)=DBLE(DIMAG(W1(6))) P1(3)=DBLE(DIMAG(W1(5))) P2(0)=DBLE( W2(5)) P2(1)=DBLE( W2(6)) P2(2)=DBLE(DIMAG(W2(6))) P2(3)=DBLE(DIMAG(W2(5))) P3(0)=DBLE( W3(5)) P3(1)=DBLE( W3(6)) P3(2)=DBLE(DIMAG(W3(6))) P3(3)=DBLE(DIMAG(W3(5))) Q(0)=-(P1(0)+P2(0)+P3(0)) Q(1)=-(P1(1)+P2(1)+P3(1)) Q(2)=-(P1(2)+P2(2)+P3(2)) Q(3)=-(P1(3)+P2(3)+P3(3)) C Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2) DG2=DBLE(G1)*DBLE(G2) DMV=DBLE(VMASS) DWV=DBLE(VWIDTH) MV2=DMV**2 IF (VMASS.EQ. RXZERO) THEN DV = 1.0D0/DCMPLX( Q2 ) ELSE DV = 1.0D0/DCMPLX( Q2 -MV2 , DMAX1(DSIGN(DMV*DWV,Q2 ),0.D0) ) ENDIF C for the running width, use below instead of the above dv. C dv = 1.0d0/dcmplx( q2 -mv2 , dmax1(dwv*q2/dmv,0.d0) ) C W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3) W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3) C IF ( WMASS .NE. RXZERO ) THEN W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3) C J4(0)=DG2*( DW1(0)*W32 + DW3(0)*W12 - 2.D0*DW2(0)*W13 ) J4(1)=DG2*( DW1(1)*W32 + DW3(1)*W12 - 2.D0*DW2(1)*W13 ) J4(2)=DG2*( DW1(2)*W32 + DW3(2)*W12 - 2.D0*DW2(2)*W13 ) J4(3)=DG2*( DW1(3)*W32 + DW3(3)*W12 - 2.D0*DW2(3)*W13 ) C JJ(0)=J4(0) JJ(1)=J4(1) JJ(2)=J4(2) JJ(3)=J4(3) C ELSE C W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3) W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3) W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3) C J4(0)=DG2*( DW1(0)*W32 - DW2(0)*W13 ) J4(1)=DG2*( DW1(1)*W32 - DW2(1)*W13 ) J4(2)=DG2*( DW1(2)*W32 - DW2(2)*W13 ) J4(3)=DG2*( DW1(3)*W32 - DW2(3)*W13 ) C JJ(0)=J4(0) JJ(1)=J4(1) JJ(2)=J4(2) JJ(3)=J4(3) C END IF C IF ( VMASS .NE. RXZERO ) THEN C JQ=(JJ(0)*Q(0)-JJ(1)*Q(1)-JJ(2)*Q(2)-JJ(3)*Q(3))/MV2 C JW3W(1) = DCMPLX( (JJ(0)-JQ*Q(0))*DV ) JW3W(2) = DCMPLX( (JJ(1)-JQ*Q(1))*DV ) JW3W(3) = DCMPLX( (JJ(2)-JQ*Q(2))*DV ) JW3W(4) = DCMPLX( (JJ(3)-JQ*Q(3))*DV ) C ELSE C JW3W(1) = DCMPLX( JJ(0)*DV ) JW3W(2) = DCMPLX( JJ(1)*DV ) JW3W(3) = DCMPLX( JJ(2)*DV ) JW3W(4) = DCMPLX( JJ(3)*DV ) END IF C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE JWWWXX(W1,W2,W3,GWWA,GWWZ,ZMASS,ZWIDTH,WMASS,WWIDTH , & JWWW) C C this subroutine computes an off-shell w+/w- current from the four- C point gauge boson coupling, including the contributions of photon and C z exchanges. the vector propagators for the output w and the internal C z bosons are given in unitary gauge, and that of the internal photon C is given in feynman gauge. C C input: C complex w1(6) : first vector w1 C complex w2(6) : second vector w2 C complex w3(6) : third vector w3 C real gwwa : coupling constant of w and a gwwa C real gwwz : coupling constant of w and z gwwz C real zmass : mass of internal z C real zwidth : width of internal z C real wmass : mass of output w C real wwidth : width of output w C C the possible sets of the inputs are as follows: C ------------------------------------------------------------------- C | w1 | w2 | w3 |gwwa|gwwz|zmass|zwidth|wmass|wwidth || jwww | C ------------------------------------------------------------------- C | w- | w+ | w- |gwwa|gwwz|zmass|zwidth|wmass|wwidth || w+ | C | w+ | w- | w+ |gwwa|gwwz|zmass|zwidth|wmass|wwidth || w- | C ------------------------------------------------------------------- C where all the bosons are defined by the flowing-out quantum number. C C output: C complex jwww(6) : w current j^mu(w':w1,w2,w3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 W1(6),W2(6),W3(6),JWWW(6) COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3), & JJ(0:3),JS(0:3),JT(0:3),J4(0:3), & JT12(0:3),JT32(0:3),J12(0:3),J32(0:3), & DZS,DZT,DW,W12,W32,W13,P1W2,P2W1,P3W2,P2W3, & JK12,JK32,JSW3,JTW1,P3JS,KSW3,P1JT,KTW1,JQ REAL*8 GWWA,GWWZ,ZMASS,ZWIDTH,WMASS,WWIDTH REAL*8 P1(0:3),P2(0:3),P3(0:3),Q(0:3),KS(0:3),KT(0:3), & DGWWA2,DGWWZ2,DGW2,DMZ,DWZ,DMW,DWW,MZ2,MW2,Q2,KS2,KT2, & DAS,DAT C JWWW(5) = W1(5)+W2(5)+W3(5) JWWW(6) = W1(6)+W2(6)+W3(6) C DW1(0)=DCMPLX(W1(1)) DW1(1)=DCMPLX(W1(2)) DW1(2)=DCMPLX(W1(3)) DW1(3)=DCMPLX(W1(4)) DW2(0)=DCMPLX(W2(1)) DW2(1)=DCMPLX(W2(2)) DW2(2)=DCMPLX(W2(3)) DW2(3)=DCMPLX(W2(4)) DW3(0)=DCMPLX(W3(1)) DW3(1)=DCMPLX(W3(2)) DW3(2)=DCMPLX(W3(3)) DW3(3)=DCMPLX(W3(4)) P1(0)=DBLE( W1(5)) P1(1)=DBLE( W1(6)) P1(2)=DBLE(DIMAG(W1(6))) P1(3)=DBLE(DIMAG(W1(5))) P2(0)=DBLE( W2(5)) P2(1)=DBLE( W2(6)) P2(2)=DBLE(DIMAG(W2(6))) P2(3)=DBLE(DIMAG(W2(5))) P3(0)=DBLE( W3(5)) P3(1)=DBLE( W3(6)) P3(2)=DBLE(DIMAG(W3(6))) P3(3)=DBLE(DIMAG(W3(5))) Q(0)=-(P1(0)+P2(0)+P3(0)) Q(1)=-(P1(1)+P2(1)+P3(1)) Q(2)=-(P1(2)+P2(2)+P3(2)) Q(3)=-(P1(3)+P2(3)+P3(3)) KS(0)=P1(0)+P2(0) KS(1)=P1(1)+P2(1) KS(2)=P1(2)+P2(2) KS(3)=P1(3)+P2(3) KT(0)=P2(0)+P3(0) KT(1)=P2(1)+P3(1) KT(2)=P2(2)+P3(2) KT(3)=P2(3)+P3(3) Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2) KS2=KS(0)**2-(KS(1)**2+KS(2)**2+KS(3)**2) KT2=KT(0)**2-(KT(1)**2+KT(2)**2+KT(3)**2) DGWWA2=DBLE(GWWA)**2 DGWWZ2=DBLE(GWWZ)**2 DGW2 =DGWWA2+DGWWZ2 DMZ=DBLE(ZMASS) DWZ=DBLE(ZWIDTH) DMW=DBLE(WMASS) DWW=DBLE(WWIDTH) MZ2=DMZ**2 MW2=DMW**2 C DAS=-DGWWA2/KS2 DAT=-DGWWA2/KT2 DZS=-DGWWZ2/DCMPLX( KS2-MZ2 , DMAX1(DSIGN(DMZ*DWZ,KS2),0.D0) ) DZT=-DGWWZ2/DCMPLX( KT2-MZ2 , DMAX1(DSIGN(DMZ*DWZ,KT2),0.D0) ) DW =-1.0D0/DCMPLX( Q2 -MW2 , DMAX1(DSIGN(DMW*DWW,Q2 ),0.D0) ) C for the running width, use below instead of the above dw. C dw =-1.0d0/dcmplx( q2 -mw2 , dmax1(dww*q2/dmw,0.d0) ) C W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3) W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3) C P1W2= (P1(0)+KS(0))*DW2(0)-(P1(1)+KS(1))*DW2(1) & -(P1(2)+KS(2))*DW2(2)-(P1(3)+KS(3))*DW2(3) P2W1= (P2(0)+KS(0))*DW1(0)-(P2(1)+KS(1))*DW1(1) & -(P2(2)+KS(2))*DW1(2)-(P2(3)+KS(3))*DW1(3) P3W2= (P3(0)+KT(0))*DW2(0)-(P3(1)+KT(1))*DW2(1) & -(P3(2)+KT(2))*DW2(2)-(P3(3)+KT(3))*DW2(3) P2W3= (P2(0)+KT(0))*DW3(0)-(P2(1)+KT(1))*DW3(1) & -(P2(2)+KT(2))*DW3(2)-(P2(3)+KT(3))*DW3(3) C JT12(0)= (P1(0)-P2(0))*W12 + P2W1*DW2(0) - P1W2*DW1(0) JT12(1)= (P1(1)-P2(1))*W12 + P2W1*DW2(1) - P1W2*DW1(1) JT12(2)= (P1(2)-P2(2))*W12 + P2W1*DW2(2) - P1W2*DW1(2) JT12(3)= (P1(3)-P2(3))*W12 + P2W1*DW2(3) - P1W2*DW1(3) JT32(0)= (P3(0)-P2(0))*W32 + P2W3*DW2(0) - P3W2*DW3(0) JT32(1)= (P3(1)-P2(1))*W32 + P2W3*DW2(1) - P3W2*DW3(1) JT32(2)= (P3(2)-P2(2))*W32 + P2W3*DW2(2) - P3W2*DW3(2) JT32(3)= (P3(3)-P2(3))*W32 + P2W3*DW2(3) - P3W2*DW3(3) C JK12=(JT12(0)*KS(0)-JT12(1)*KS(1)-JT12(2)*KS(2)-JT12(3)*KS(3))/MZ2 JK32=(JT32(0)*KT(0)-JT32(1)*KT(1)-JT32(2)*KT(2)-JT32(3)*KT(3))/MZ2 C J12(0)=JT12(0)*(DAS+DZS)-KS(0)*JK12*DZS J12(1)=JT12(1)*(DAS+DZS)-KS(1)*JK12*DZS J12(2)=JT12(2)*(DAS+DZS)-KS(2)*JK12*DZS J12(3)=JT12(3)*(DAS+DZS)-KS(3)*JK12*DZS J32(0)=JT32(0)*(DAT+DZT)-KT(0)*JK32*DZT J32(1)=JT32(1)*(DAT+DZT)-KT(1)*JK32*DZT J32(2)=JT32(2)*(DAT+DZT)-KT(2)*JK32*DZT J32(3)=JT32(3)*(DAT+DZT)-KT(3)*JK32*DZT C JSW3=J12(0)*DW3(0)-J12(1)*DW3(1)-J12(2)*DW3(2)-J12(3)*DW3(3) JTW1=J32(0)*DW1(0)-J32(1)*DW1(1)-J32(2)*DW1(2)-J32(3)*DW1(3) C P3JS= (P3(0)-Q(0))*J12(0)-(P3(1)-Q(1))*J12(1) & -(P3(2)-Q(2))*J12(2)-(P3(3)-Q(3))*J12(3) KSW3= (KS(0)-Q(0))*DW3(0)-(KS(1)-Q(1))*DW3(1) & -(KS(2)-Q(2))*DW3(2)-(KS(3)-Q(3))*DW3(3) P1JT= (P1(0)-Q(0))*J32(0)-(P1(1)-Q(1))*J32(1) & -(P1(2)-Q(2))*J32(2)-(P1(3)-Q(3))*J32(3) KTW1= (KT(0)-Q(0))*DW1(0)-(KT(1)-Q(1))*DW1(1) & -(KT(2)-Q(2))*DW1(2)-(KT(3)-Q(3))*DW1(3) C JS(0)= (KS(0)-P3(0))*JSW3 + P3JS*DW3(0) - KSW3*J12(0) JS(1)= (KS(1)-P3(1))*JSW3 + P3JS*DW3(1) - KSW3*J12(1) JS(2)= (KS(2)-P3(2))*JSW3 + P3JS*DW3(2) - KSW3*J12(2) JS(3)= (KS(3)-P3(3))*JSW3 + P3JS*DW3(3) - KSW3*J12(3) JT(0)= (KT(0)-P1(0))*JTW1 + P1JT*DW1(0) - KTW1*J32(0) JT(1)= (KT(1)-P1(1))*JTW1 + P1JT*DW1(1) - KTW1*J32(1) JT(2)= (KT(2)-P1(2))*JTW1 + P1JT*DW1(2) - KTW1*J32(2) JT(3)= (KT(3)-P1(3))*JTW1 + P1JT*DW1(3) - KTW1*J32(3) C W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3) C J4(0)=DGW2*( DW1(0)*W32 + DW3(0)*W12 - 2.D0*DW2(0)*W13 ) J4(1)=DGW2*( DW1(1)*W32 + DW3(1)*W12 - 2.D0*DW2(1)*W13 ) J4(2)=DGW2*( DW1(2)*W32 + DW3(2)*W12 - 2.D0*DW2(2)*W13 ) J4(3)=DGW2*( DW1(3)*W32 + DW3(3)*W12 - 2.D0*DW2(3)*W13 ) C JJ(0)=J4(0) JJ(1)=J4(1) JJ(2)=J4(2) JJ(3)=J4(3) C JQ=(JJ(0)*Q(0)-JJ(1)*Q(1)-JJ(2)*Q(2)-JJ(3)*Q(3))/MW2 C JWWW(1) = DCMPLX( (JJ(0)-JQ*Q(0))*DW ) JWWW(2) = DCMPLX( (JJ(1)-JQ*Q(1))*DW ) JWWW(3) = DCMPLX( (JJ(2)-JQ*Q(2))*DW ) JWWW(4) = DCMPLX( (JJ(3)-JQ*Q(3))*DW ) C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE MOM2CX(ESUM,MASS1,MASS2,COSTH1,PHI1 , P1,P2) C C This subroutine sets up two four-momenta in the two particle rest C frame. C C INPUT: C real ESUM : energy sum of particle 1 and 2 C real MASS1 : mass of particle 1 C real MASS2 : mass of particle 2 C real COSTH1 : cos(theta) of particle 1 C real PHI1 : azimuthal angle of particle 1 C C OUTPUT: C real P1(0:3) : four-momentum of particle 1 C real P2(0:3) : four-momentum of particle 2 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 P1(0:3),P2(0:3), & ESUM,MASS1,MASS2,COSTH1,PHI1,MD2,ED,PP,SINTH1 C MD2=(MASS1-MASS2)*(MASS1+MASS2) ED=MD2/ESUM IF (MASS1*MASS2.EQ.0.) THEN PP=(ESUM-ABS(ED))*0.5D0 C ELSE PP=SQRT((MD2/ESUM)**2-2.0D0*(MASS1**2+MASS2**2)+ESUM**2)*0.5D0 ENDIF SINTH1=SQRT((1.0D0-COSTH1)*(1.0D0+COSTH1)) C P1(0) = MAX((ESUM+ED)*0.5D0,0.D0) P1(1) = PP*SINTH1*COS(PHI1) P1(2) = PP*SINTH1*SIN(PHI1) P1(3) = PP*COSTH1 C P2(0) = MAX((ESUM-ED)*0.5D0,0.D0) P2(1) = -P1(1) P2(2) = -P1(2) P2(3) = -P1(3) C RETURN END C ********************************************************************** C SUBROUTINE MOMNTX(ENERGY,MASS,COSTH,PHI , P) C C This subroutine sets up a four-momentum from the four inputs. C C INPUT: C real ENERGY : energy C real MASS : mass C real COSTH : cos(theta) C real PHI : azimuthal angle C C OUTPUT: C real P(0:3) : four-momentum C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 P(0:3),ENERGY,MASS,COSTH,PHI,PP,SINTH C P(0) = ENERGY IF (ENERGY.EQ.MASS) THEN P(1) = 0. P(2) = 0. P(3) = 0. ELSE PP=SQRT((ENERGY-MASS)*(ENERGY+MASS)) SINTH=SQRT((1.-COSTH)*(1.+COSTH)) P(3) = PP*COSTH IF (PHI.EQ.0.) THEN P(1) = PP*SINTH P(2) = 0. ELSE P(1) = PP*SINTH*COS(PHI) P(2) = PP*SINTH*SIN(PHI) ENDIF ENDIF RETURN END C C C C Subroutine returns the desired fermion or C anti-fermion anti-spinor. ie., C SUBROUTINE OXXXXX(P,FMASS,NHEL,NSF,FO) C C P IN: FOUR VECTOR MOMENTUM C FMASS IN: FERMION MASS C NHEL IN: ANTI-SPINOR HELICITY, -1 OR 1 C NSF IN: -1=ANTIFERMION, 1=FERMION C FO OUT: FERMION WAVEFUNCTION C C declare input/output variables C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 FO(6) INTEGER*4 NHEL, NSF REAL*8 P(0:3), FMASS C C declare local variables C REAL*8 RXZERO, RXONE, RXTWO PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 ) REAL*8 PLAT, PABS, OMEGAP, OMEGAM, RS2PA, SPAZ COMPLEX*16 CXZERO LOGICAL FIRST SAVE CXZERO,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXZERO=DCMPLX( RXZERO, RXZERO ) ENDIF C C define kinematic parameters C FO(5) = DCMPLX( P(0), P(3) ) * NSF FO(6) = DCMPLX( P(1), P(2) ) * NSF PLAT = SQRT( P(1)**2 + P(2)**2 ) PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 ) OMEGAP = SQRT( P(0) + PABS ) C C do massive fermion case C IF ( FMASS .NE. RXZERO ) THEN OMEGAM = FMASS / OMEGAP IF ( NSF .EQ. 1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( OMEGAP, RXZERO ) FO(2) = CXZERO FO(3) = DCMPLX( OMEGAM, RXZERO ) FO(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FO(1) = OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(2) = OMEGAP * RS2PA / SPAZ & * DCMPLX( P(1), -P(2) ) FO(3) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(4) = OMEGAM * RS2PA / SPAZ & * DCMPLX( P(1), -P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( OMEGAP, RXZERO ) FO(3) = CXZERO FO(4) = DCMPLX( OMEGAM, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FO(1) = OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(2) = OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) FO(3) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(4) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( OMEGAM, RXZERO ) FO(3) = CXZERO FO(4) = DCMPLX( OMEGAP, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FO(1) = OMEGAM * RS2PA / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(2) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(3) = OMEGAP * RS2PA / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(4) = OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( -OMEGAM, RXZERO ) FO(2) = CXZERO FO(3) = DCMPLX( -OMEGAP, RXZERO ) FO(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FO(1) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(2) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(3) = OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(4) = OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE STOP 'OXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE IF ( NSF .EQ. -1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( OMEGAM, RXZERO ) FO(3) = CXZERO FO(4) = DCMPLX( -OMEGAP, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FO(1) = OMEGAM * RS2PA / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(2) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(3) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(4) = -OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( -OMEGAM, RXZERO ) FO(2) = CXZERO FO(3) = DCMPLX( OMEGAP, RXZERO ) FO(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FO(1) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(2) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(3) = -OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(4) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( -OMEGAP, RXZERO ) FO(2) = CXZERO FO(3) = DCMPLX( OMEGAM, RXZERO ) FO(4) = CXZERO ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS + P(3) ) FO(1) = -OMEGAP * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(2) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( P(1), -P(2) ) FO(3) = OMEGAM * RS2PA & * DCMPLX( SPAZ, RXZERO ) FO(4) = OMEGAM * RS2PA / SPAZ & * DCMPLX( P(1), -P(2) ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( -OMEGAP, RXZERO ) FO(3) = CXZERO FO(4) = DCMPLX( OMEGAM, RXZERO ) ELSE RS2PA = RXONE / SQRT( RXTWO * PABS ) SPAZ = SQRT( PABS - P(3) ) FO(1) = -OMEGAP * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(2) = -OMEGAP * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) FO(3) = OMEGAM * RS2PA / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(4) = OMEGAM * RS2PA * SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) END IF END IF ELSE STOP 'OXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE STOP 'OXXXXX: FERMION TYPE MUST BE +1,-1' END IF C C do massless case C ELSE IF ( NSF .EQ. 1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( OMEGAP, RXZERO ) FO(2) = CXZERO FO(3) = CXZERO FO(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FO(1) = DCMPLX( SPAZ, RXZERO ) FO(2) = RXONE / SPAZ & * DCMPLX( P(1), -P(2) ) FO(3) = CXZERO FO(4) = CXZERO END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( OMEGAP, RXZERO ) FO(3) = CXZERO FO(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FO(1) = RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(2) = SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) FO(3) = CXZERO FO(4) = CXZERO END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = CXZERO FO(3) = CXZERO FO(4) = DCMPLX( OMEGAP, RXZERO ) ELSE SPAZ = SQRT( PABS + P(3) ) FO(1) = CXZERO FO(2) = CXZERO FO(3) = RXONE / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(4) = DCMPLX( SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = CXZERO FO(3) = DCMPLX( -OMEGAP, RXZERO ) FO(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FO(1) = CXZERO FO(2) = CXZERO FO(3) = SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(4) = RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE STOP 'OXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE IF ( NSF .EQ. -1 ) THEN IF ( NHEL .EQ. 1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = CXZERO FO(3) = CXZERO FO(4) = DCMPLX( -OMEGAP, RXZERO ) ELSE SPAZ = SQRT( PABS + P(3) ) FO(1) = CXZERO FO(2) = CXZERO FO(3) = -RXONE / SPAZ & * DCMPLX( -P(1), -P(2) ) FO(4) = DCMPLX( -SPAZ, RXZERO ) END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = CXZERO FO(3) = DCMPLX( OMEGAP, RXZERO ) FO(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FO(1) = CXZERO FO(2) = CXZERO FO(3) = -SPAZ / PLAT & * DCMPLX( -P(1), -P(2) ) FO(4) = -RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) END IF END IF ELSE IF ( NHEL .EQ. -1 ) THEN IF ( P(3) .GE. RXZERO ) THEN IF ( PLAT .EQ. RXZERO ) THEN FO(1) = DCMPLX( -OMEGAP, RXZERO ) FO(2) = CXZERO FO(3) = CXZERO FO(4) = CXZERO ELSE SPAZ = SQRT( PABS + P(3) ) FO(1) = DCMPLX( -SPAZ, RXZERO ) FO(2) = -RXONE / SPAZ & * DCMPLX( P(1), -P(2) ) FO(3) = CXZERO FO(4) = CXZERO END IF ELSE IF ( PLAT .EQ. RXZERO ) THEN FO(1) = CXZERO FO(2) = DCMPLX( -OMEGAP, RXZERO ) FO(3) = CXZERO FO(4) = CXZERO ELSE SPAZ = SQRT( PABS - P(3) ) FO(1) = -RXONE / SPAZ & * DCMPLX( PLAT, RXZERO ) FO(2) = -SPAZ / PLAT & * DCMPLX( P(1), -P(2) ) FO(3) = CXZERO FO(4) = CXZERO END IF END IF ELSE STOP 'OXXXXX: FERMION HELICITY MUST BE +1,-1' END IF ELSE STOP 'OXXXXX: FERMION TYPE MUST BE +1,-1' END IF END IF C C done C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE ROTXXX(P,Q , PROT) C C this subroutine performs the spacial rotation of a four-momentum. C the momentum p is assumed to be given in the frame where the spacial C component of q points the positive z-axis. prot is the momentum p C rotated to the frame where q is given. C C input: C real p(0:3) : four-momentum p in q(1)=q(2)=0 frame C real q(0:3) : four-momentum q in the rotated frame C C output: C real prot(0:3) : four-momentum p in the rotated frame C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL*8 P(0:3),Q(0:3),PROT(0:3),QT2,QT,PSGN,QQ,P1 C REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) C PROT(0) = P(0) C QT2=Q(1)**2+Q(2)**2 C IF ( QT2 .EQ. RXZERO ) THEN IF ( Q(3) .EQ. RXZERO ) THEN PROT(1) = P(1) PROT(2) = P(2) PROT(3) = P(3) ELSE PSGN=DSIGN(RXONE,Q(3)) PROT(1) = P(1)*PSGN PROT(2) = P(2)*PSGN PROT(3) = P(3)*PSGN ENDIF ELSE QQ=SQRT(QT2+Q(3)**2) QT=SQRT(QT2) P1=P(1) PROT(1) = Q(1)*Q(3)/QQ/QT*P1 -Q(2)/QT*P(2) +Q(1)/QQ*P(3) PROT(2) = Q(2)*Q(3)/QQ/QT*P1 +Q(1)/QT*P(2) +Q(2)/QQ*P(3) PROT(3) = -QT/QQ*P1 +Q(3)/QQ*P(3) ENDIF C RETURN END C ====================================================================== C SUBROUTINE SSSSXX(S1,S2,S3,S4,G , VERTEX) C C This subroutine computes an amplitude of the four-scalar coupling. C C INPUT: C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C complex S3(3) : third scalar S3 C complex S4(3) : fourth scalar S4 C real G : coupling constant GHHHH C C OUTPUT: C complex VERTEX : amplitude Gamma(S1,S2,S3,S4) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 S1(3),S2(3),S3(3),S4(3),VERTEX REAL*8 G C VERTEX = G*S1(1)*S2(1)*S3(1)*S4(1) C RETURN END C C ====================================================================== C SUBROUTINE SSSXXX(S1,S2,S3,G , VERTEX) C C This subroutine computes an amplitude of the three-scalar coupling. C C INPUT: C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C complex S3(3) : third scalar S3 C real G : coupling constant GHHH C C OUTPUT: C complex VERTEX : amplitude Gamma(S1,S2,S3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 S1(3),S2(3),S3(3),VERTEX REAL*8 G C VERTEX = G*S1(1)*S2(1)*S3(1) C RETURN END C C C ---------------------------------------------------------------------- C SUBROUTINE SXXXXX(P,NSS , SC) C C This subroutine computes a complex SCALAR wavefunction. C C INPUT: C real P(0:3) : four-momentum of scalar boson C integer NSS = -1 or 1 : +1 for final, -1 for initial C C OUTPUT: C complex SC(3) : scalar wavefunction S C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 SC(3) REAL*8 P(0:3) INTEGER NSS C SC(1) = DCMPLX( 1.0 ) SC(2) = DCMPLX(P(0),P(3))*NSS SC(3) = DCMPLX(P(1),P(2))*NSS C RETURN END C C ====================================================================== C SUBROUTINE VSSXXX(VC,S1,S2,G , VERTEX) C C this subroutine computes an amplitude from the vector-scalar-scalar C coupling. the coupling is absent in the minimal sm in unitary gauge. C C complex vc(6) : input vector v C complex s1(3) : first scalar s1 C complex s2(3) : second scalar s2 C complex g : coupling constant (s1 charge) C C examples of the coupling constant g for susy particles are as follows: C ----------------------------------------------------------- C | s1 | (q,i3) of s1 || v=a | v=z | v=w | C ----------------------------------------------------------- C | nu~_l | ( 0 , +1/2) || --- | gzn(1) | gwf(1) | C | e~_l | ( -1 , -1/2) || gal(1) | gzl(1) | gwf(1) | C | u~_l | (+2/3 , +1/2) || gau(1) | gzu(1) | gwf(1) | C | d~_l | (-1/3 , -1/2) || gad(1) | gzd(1) | gwf(1) | C ----------------------------------------------------------- C | e~_r-bar | ( +1 , 0 ) || -gal(2) | -gzl(2) | -gwf(2) | C | u~_r-bar | (-2/3 , 0 ) || -gau(2) | -gzu(2) | -gwf(2) | C | d~_r-bar | (+1/3 , 0 ) || -gad(2) | -gzd(2) | -gwf(2) | C ----------------------------------------------------------- C where the s1 charge is defined by the flowing-out quantum number. C C output: C complex vertex : amplitude gamma(v,s1,s2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 VC(6),S1(3),S2(3),VERTEX,G REAL*8 P(0:3) C P(0)=DBLE( S1(2)-S2(2)) P(1)=DBLE( S1(3)-S2(3)) P(2)=DIMAG(S1(3)-S2(3)) P(3)=DIMAG(S1(2)-S2(2)) C VERTEX = G*S1(1)*S2(1) & *(VC(1)*P(0)-VC(2)*P(1)-VC(3)*P(2)-VC(4)*P(3)) C RETURN END C SUBROUTINE VVSSXX(V1,V2,S1,S2,G , VERTEX) C C This subroutine computes an amplitude of the vector-vector-scalar- C scalar coupling. C C INPUT: C complex V1(6) : first vector V1 C complex V2(6) : second vector V2 C complex S1(3) : first scalar S1 C complex S2(3) : second scalar S2 C real G : coupling constant GVVHH C C OUTPUT: C complex VERTEX : amplitude Gamma(V1,V2,S1,S2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 V1(6),V2(6),S1(3),S2(3),VERTEX REAL*8 G C VERTEX = G*S1(1)*S2(1) & *(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4)) C RETURN END C C C ====================================================================== C SUBROUTINE VVSXXX(V1,V2,SC,G , VERTEX) C C this subroutine computes an amplitude of the vector-vector-scalar C coupling. C C input: C complex v1(6) : first vector v1 C complex v2(6) : second vector v2 C complex sc(3) : input scalar s C real g : coupling constant gvvh C C output: C complex vertex : amplitude gamma(v1,v2,s) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 V1(6),V2(6),SC(3),VERTEX REAL*8 G C VERTEX = G*SC(1)*(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4)) C RETURN END C C ====================================================================== C SUBROUTINE VVVXXX(WM,WP,W3,G , VERTEX) C C this subroutine computes an amplitude of the three-point coupling of C the gauge bosons. C C input: C complex wm(6) : vector flow-out w- C complex wp(6) : vector flow-out w+ C complex w3(6) : vector j3 or a or z C real g : coupling constant gw or gwwa or gwwz C C output: C complex vertex : amplitude gamma(wm,wp,w3) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 WM(6),WP(6),W3(6),VERTEX, & XV1,XV2,XV3,V12,V23,V31,P12,P13,P21,P23,P31,P32 REAL*8 PWM(0:3),PWP(0:3),PW3(0:3),G C REAL*8 RXZERO, RTENTH PARAMETER( RXZERO=0.0D0, RTENTH=0.1D0 ) C PWM(0)=DBLE( WM(5)) PWM(1)=DBLE( WM(6)) PWM(2)=DIMAG(WM(6)) PWM(3)=DIMAG(WM(5)) PWP(0)=DBLE( WP(5)) PWP(1)=DBLE( WP(6)) PWP(2)=DIMAG(WP(6)) PWP(3)=DIMAG(WP(5)) PW3(0)=DBLE( W3(5)) PW3(1)=DBLE( W3(6)) PW3(2)=DIMAG(W3(6)) PW3(3)=DIMAG(W3(5)) C V12=WM(1)*WP(1)-WM(2)*WP(2)-WM(3)*WP(3)-WM(4)*WP(4) V23=WP(1)*W3(1)-WP(2)*W3(2)-WP(3)*W3(3)-WP(4)*W3(4) V31=W3(1)*WM(1)-W3(2)*WM(2)-W3(3)*WM(3)-W3(4)*WM(4) XV1=RXZERO XV2=RXZERO XV3=RXZERO IF ( ABS(WM(1)) .NE. RXZERO ) THEN IF (ABS(WM(1)).GE.MAX(ABS(WM(2)),ABS(WM(3)),ABS(WM(4))) $ *RTENTH) & XV1=PWM(0)/WM(1) ENDIF IF ( ABS(WP(1)) .NE. RXZERO) THEN IF (ABS(WP(1)).GE.MAX(ABS(WP(2)),ABS(WP(3)),ABS(WP(4))) $ *RTENTH) & XV2=PWP(0)/WP(1) ENDIF IF ( ABS(W3(1)) .NE. RXZERO) THEN IF ( ABS(W3(1)).GE.MAX(ABS(W3(2)),ABS(W3(3)),ABS(W3(4))) $ *RTENTH) & XV3=PW3(0)/W3(1) ENDIF P12= (PWM(0)-XV1*WM(1))*WP(1)-(PWM(1)-XV1*WM(2))*WP(2) & -(PWM(2)-XV1*WM(3))*WP(3)-(PWM(3)-XV1*WM(4))*WP(4) P13= (PWM(0)-XV1*WM(1))*W3(1)-(PWM(1)-XV1*WM(2))*W3(2) & -(PWM(2)-XV1*WM(3))*W3(3)-(PWM(3)-XV1*WM(4))*W3(4) P21= (PWP(0)-XV2*WP(1))*WM(1)-(PWP(1)-XV2*WP(2))*WM(2) & -(PWP(2)-XV2*WP(3))*WM(3)-(PWP(3)-XV2*WP(4))*WM(4) P23= (PWP(0)-XV2*WP(1))*W3(1)-(PWP(1)-XV2*WP(2))*W3(2) & -(PWP(2)-XV2*WP(3))*W3(3)-(PWP(3)-XV2*WP(4))*W3(4) P31= (PW3(0)-XV3*W3(1))*WM(1)-(PW3(1)-XV3*W3(2))*WM(2) & -(PW3(2)-XV3*W3(3))*WM(3)-(PW3(3)-XV3*W3(4))*WM(4) P32= (PW3(0)-XV3*W3(1))*WP(1)-(PW3(1)-XV3*W3(2))*WP(2) & -(PW3(2)-XV3*W3(3))*WP(3)-(PW3(3)-XV3*W3(4))*WP(4) C VERTEX = -(V12*(P13-P23)+V23*(P21-P31)+V31*(P32-P12))*G C RETURN END C C C Subroutine returns the value of evaluated C helicity basis boson polarisation wavefunction. C Replaces the HELAS routine VXXXXX C C Adam Duff, 1992 September 3 C C SUBROUTINE VXXXXX(P,VMASS,NHEL,NSV,VC) C C P IN: BOSON FOUR MOMENTUM C VMASS IN: BOSON MASS C NHEL IN: BOSON HELICITY C NSV IN: INCOMING (-1) OR OUTGOING (+1) C VC OUT: BOSON WAVEFUNCTION C C declare input/output variables C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 VC(6) INTEGER*4 NHEL, NSV REAL*8 P(0:3), VMASS C C declare local variables C REAL*8 RXZERO, RXONE, RXTWO PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 ) REAL*8 PLAT, PABS, RS2, RPLAT, RPABS, RDEN COMPLEX*16 CXZERO LOGICAL FIRST SAVE CXZERO,FIRST DATA FIRST/.TRUE./ C C Fix compilation with g77 IF(FIRST) THEN FIRST=.FALSE. CXZERO=DCMPLX( RXZERO, RXZERO ) ENDIF C C define internal/external momenta C IF ( NSV**2 .NE. 1 ) THEN STOP 'VXXXXX: NSV IS NOT ONE OF -1, +1' END IF C RS2 = SQRT( RXONE / RXTWO ) VC(5) = DCMPLX( P(0), P(3) ) * NSV VC(6) = DCMPLX( P(1), P(2) ) * NSV PLAT = SQRT( P(1)**2 + P(2)**2 ) PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 ) C C calculate polarisation four vectors C IF ( NHEL**2 .EQ. 1 ) THEN IF ( (PABS .EQ. RXZERO) .OR. (PLAT .EQ. RXZERO) ) THEN VC(1) = CXZERO VC(2) = DCMPLX( -NHEL * RS2 * DSIGN( RXONE, P(3) ), RXZERO ) VC(3) = DCMPLX( RXZERO, NSV * RS2 ) VC(4) = CXZERO ELSE RPLAT = RXONE / PLAT RPABS = RXONE / PABS VC(1) = CXZERO VC(2) = DCMPLX( -NHEL * RS2 * RPABS * RPLAT * P(1) * P(3), & -NSV * RS2 * RPLAT * P(2) ) VC(3) = DCMPLX( -NHEL * RS2 * RPABS * RPLAT * P(2) * P(3), & NSV * RS2 * RPLAT * P(1) ) VC(4) = DCMPLX( NHEL * RS2 * RPABS * PLAT, & RXZERO ) END IF ELSE IF ( NHEL .EQ. 0 ) THEN IF ( VMASS .GT. RXZERO ) THEN IF ( PABS .EQ. RXZERO ) THEN VC(1) = CXZERO VC(2) = CXZERO VC(3) = CXZERO VC(4) = DCMPLX( RXONE, RXZERO ) ELSE RDEN = P(0) / ( VMASS * PABS ) VC(1) = DCMPLX( PABS / VMASS, RXZERO ) VC(2) = DCMPLX( RDEN * P(1), RXZERO ) VC(3) = DCMPLX( RDEN * P(2), RXZERO ) VC(4) = DCMPLX( RDEN * P(3), RXZERO ) END IF ELSE STOP 'VXXXXX: NHEL = 0 IS ONLY FOR MASSIVE BOSONS' END IF ELSE IF ( NHEL .EQ. 4 ) THEN IF ( VMASS .GT. RXZERO ) THEN RDEN = RXONE / VMASS VC(1) = DCMPLX( RDEN * P(0), RXZERO ) VC(2) = DCMPLX( RDEN * P(1), RXZERO ) VC(3) = DCMPLX( RDEN * P(2), RXZERO ) VC(4) = DCMPLX( RDEN * P(3), RXZERO ) ELSEIF (VMASS .EQ. RXZERO) THEN RDEN = RXONE / P(0) VC(1) = DCMPLX( RDEN * P(0), RXZERO ) VC(2) = DCMPLX( RDEN * P(1), RXZERO ) VC(3) = DCMPLX( RDEN * P(2), RXZERO ) VC(4) = DCMPLX( RDEN * P(3), RXZERO ) ELSE STOP 'VXXXXX: NHEL = 4 IS ONLY FOR M>=0' END IF ELSE STOP 'VXXXXX: NHEL IS NOT ONE OF -1, 0, 1 OR 4' END IF C C done C RETURN END C C ---------------------------------------------------------------------- C SUBROUTINE W3W3XX(WM,W31,WP,W32,G31,G32,WMASS,WWIDTH , VERTEX) C C this subroutine computes an amplitude of the four-point coupling of C the w-, w+ and two w3/z/a. the amplitude includes the contributions C of w exchange diagrams. the internal w propagator is given in unitary C gauge. if one sets wmass=0.0, then the gggg vertex is given (see sect C 2.9.1 of the manual). C C input: C complex wm(0:3) : flow-out w- wm C complex w31(0:3) : first w3/z/a w31 C complex wp(0:3) : flow-out w+ wp C complex w32(0:3) : second w3/z/a w32 C real g31 : coupling of w31 with w-/w+ C real g32 : coupling of w32 with w-/w+ C (see the table below) C real wmass : mass of w C real wwidth : width of w C C the possible sets of the inputs are as follows: C ------------------------------------------- C | wm | w31 | wp | w32 | g31 | g32 | C ------------------------------------------- C | w- | w3 | w+ | w3 | gw | gw | C | w- | w3 | w+ | z | gw | gwwz | C | w- | w3 | w+ | a | gw | gwwa | C | w- | z | w+ | z | gwwz | gwwz | C | w- | z | w+ | a | gwwz | gwwa | C | w- | a | w+ | a | gwwa | gwwa | C ------------------------------------------- C where all the bosons are defined by the flowing-out quantum number. C C output: C complex vertex : amplitude gamma(wm,w31,wp,w32) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 WM(6),W31(6),WP(6),W32(6),VERTEX COMPLEX*16 DV1(0:3),DV2(0:3),DV3(0:3),DV4(0:3),DVERTX, & V12,V13,V14,V23,V24,V34 REAL*8 G31,G32,WMASS,WWIDTH C REAL*8 RXZERO, RXONE PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 ) C DV1(0)=DCMPLX(WM(1)) DV1(1)=DCMPLX(WM(2)) DV1(2)=DCMPLX(WM(3)) DV1(3)=DCMPLX(WM(4)) DV2(0)=DCMPLX(W31(1)) DV2(1)=DCMPLX(W31(2)) DV2(2)=DCMPLX(W31(3)) DV2(3)=DCMPLX(W31(4)) DV3(0)=DCMPLX(WP(1)) DV3(1)=DCMPLX(WP(2)) DV3(2)=DCMPLX(WP(3)) DV3(3)=DCMPLX(WP(4)) DV4(0)=DCMPLX(W32(1)) DV4(1)=DCMPLX(W32(2)) DV4(2)=DCMPLX(W32(3)) DV4(3)=DCMPLX(W32(4)) C IF ( DBLE(WMASS) .NE. RXZERO ) THEN C dm2inv = r_one / dmw2 C V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3) V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3) V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3) V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3) V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3) V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3) C DVERTX = V12*V34 +V14*V23 -2.D0*V13*V24 C VERTEX = DCMPLX( DVERTX ) * (G31*G32) C ELSE V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3) V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3) V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3) V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3) V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3) V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3) C DVERTX = V14*V23 -V13*V24 C VERTEX = DCMPLX( DVERTX ) * (G31*G32) END IF C RETURN END C C ====================================================================== C SUBROUTINE WWWWXX(WM1,WP1,WM2,WP2,GWWA,GWWZ,ZMASS,ZWIDTH , VERTEX) C C this subroutine computes an amplitude of the four-point w-/w+ C coupling, including the contributions of photon and z exchanges. the C photon propagator is given in feynman gauge and the z propagator is C given in unitary gauge. C C input: C complex wm1(0:3) : first flow-out w- wm1 C complex wp1(0:3) : first flow-out w+ wp1 C complex wm2(0:3) : second flow-out w- wm2 C complex wp2(0:3) : second flow-out w+ wp2 C real gwwa : coupling constant of w and a gwwa C real gwwz : coupling constant of w and z gwwz C real zmass : mass of z C real zwidth : width of z C C output: C complex vertex : amplitude gamma(wm1,wp1,wm2,wp2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF COMPLEX*16 WM1(6),WP1(6),WM2(6),WP2(6),VERTEX COMPLEX*16 DV1(0:3),DV2(0:3),DV3(0:3),DV4(0:3), & J12(0:3),J34(0:3),J14(0:3),J32(0:3),DVERTX, & SV1,SV2,SV3,SV4,TV1,TV2,TV3,TV4,DZS,DZT, & V12,V13,V14,V23,V24,V34,JS12,JS34,JS14,JS32,JS,JT REAL*8 PWM1(0:3),PWP1(0:3),PWM2(0:3),PWP2(0:3), & GWWA,GWWZ,ZMASS,ZWIDTH REAL*8 Q(0:3),K(0:3),DP1(0:3),DP2(0:3),DP3(0:3),DP4(0:3), & DGWWA2,DGWWZ2,DGW2,DMZ,DWIDTH,S,T,DAS,DAT C REAL*8 RXZERO, RXONE, RXTWO PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 ) C PWM1(0)=DBLE( WM1(5)) PWM1(1)=DBLE( WM1(6)) PWM1(2)=DIMAG(WM1(6)) PWM1(3)=DIMAG(WM1(5)) PWP1(0)=DBLE( WP1(5)) PWP1(1)=DBLE( WP1(6)) PWP1(2)=DIMAG(WP1(6)) PWP1(3)=DIMAG(WP1(5)) PWM2(0)=DBLE( WM2(5)) PWM2(1)=DBLE( WM2(6)) PWM2(2)=DIMAG(WM2(6)) PWM2(3)=DIMAG(WM2(5)) PWP2(0)=DBLE( WP2(5)) PWP2(1)=DBLE( WP2(6)) PWP2(2)=DIMAG(WP2(6)) PWP2(3)=DIMAG(WP2(5)) C DV1(0)=DCMPLX(WM1(1)) DV1(1)=DCMPLX(WM1(2)) DV1(2)=DCMPLX(WM1(3)) DV1(3)=DCMPLX(WM1(4)) DP1(0)=DBLE(PWM1(0)) DP1(1)=DBLE(PWM1(1)) DP1(2)=DBLE(PWM1(2)) DP1(3)=DBLE(PWM1(3)) DV2(0)=DCMPLX(WP1(1)) DV2(1)=DCMPLX(WP1(2)) DV2(2)=DCMPLX(WP1(3)) DV2(3)=DCMPLX(WP1(4)) DP2(0)=DBLE(PWP1(0)) DP2(1)=DBLE(PWP1(1)) DP2(2)=DBLE(PWP1(2)) DP2(3)=DBLE(PWP1(3)) DV3(0)=DCMPLX(WM2(1)) DV3(1)=DCMPLX(WM2(2)) DV3(2)=DCMPLX(WM2(3)) DV3(3)=DCMPLX(WM2(4)) DP3(0)=DBLE(PWM2(0)) DP3(1)=DBLE(PWM2(1)) DP3(2)=DBLE(PWM2(2)) DP3(3)=DBLE(PWM2(3)) DV4(0)=DCMPLX(WP2(1)) DV4(1)=DCMPLX(WP2(2)) DV4(2)=DCMPLX(WP2(3)) DV4(3)=DCMPLX(WP2(4)) DP4(0)=DBLE(PWP2(0)) DP4(1)=DBLE(PWP2(1)) DP4(2)=DBLE(PWP2(2)) DP4(3)=DBLE(PWP2(3)) DGWWA2=DBLE(GWWA)**2 DGWWZ2=DBLE(GWWZ)**2 DGW2 =DGWWA2+DGWWZ2 DMZ =DBLE(ZMASS) DWIDTH=DBLE(ZWIDTH) C V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3) V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3) V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3) V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3) V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3) V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3) C Q(0)=DP1(0)+DP2(0) Q(1)=DP1(1)+DP2(1) Q(2)=DP1(2)+DP2(2) Q(3)=DP1(3)+DP2(3) K(0)=DP1(0)+DP4(0) K(1)=DP1(1)+DP4(1) K(2)=DP1(2)+DP4(2) K(3)=DP1(3)+DP4(3) C S=Q(0)**2-Q(1)**2-Q(2)**2-Q(3)**2 T=K(0)**2-K(1)**2-K(2)**2-K(3)**2 C DAS=-RXONE/S DAT=-RXONE/T DZS=-RXONE/DCMPLX( S-DMZ**2 , DMAX1(DSIGN(DMZ*DWIDTH,S),RXZERO) ) DZT=-RXONE/DCMPLX( T-DMZ**2 , DMAX1(DSIGN(DMZ*DWIDTH,T),RXZERO) ) C SV1= (DP2(0)+Q(0))*DV1(0) -(DP2(1)+Q(1))*DV1(1) & -(DP2(2)+Q(2))*DV1(2) -(DP2(3)+Q(3))*DV1(3) SV2=-(DP1(0)+Q(0))*DV2(0) +(DP1(1)+Q(1))*DV2(1) & +(DP1(2)+Q(2))*DV2(2) +(DP1(3)+Q(3))*DV2(3) SV3= (DP4(0)-Q(0))*DV3(0) -(DP4(1)-Q(1))*DV3(1) & -(DP4(2)-Q(2))*DV3(2) -(DP4(3)-Q(3))*DV3(3) SV4=-(DP3(0)-Q(0))*DV4(0) +(DP3(1)-Q(1))*DV4(1) & +(DP3(2)-Q(2))*DV4(2) +(DP3(3)-Q(3))*DV4(3) C TV1= (DP4(0)+K(0))*DV1(0) -(DP4(1)+K(1))*DV1(1) & -(DP4(2)+K(2))*DV1(2) -(DP4(3)+K(3))*DV1(3) TV2=-(DP3(0)-K(0))*DV2(0) +(DP3(1)-K(1))*DV2(1) & +(DP3(2)-K(2))*DV2(2) +(DP3(3)-K(3))*DV2(3) TV3= (DP2(0)-K(0))*DV3(0) -(DP2(1)-K(1))*DV3(1) & -(DP2(2)-K(2))*DV3(2) -(DP2(3)-K(3))*DV3(3) TV4=-(DP1(0)+K(0))*DV4(0) +(DP1(1)+K(1))*DV4(1) & +(DP1(2)+K(2))*DV4(2) +(DP1(3)+K(3))*DV4(3) C J12(0)=(DP1(0)-DP2(0))*V12 +SV1*DV2(0) +SV2*DV1(0) J12(1)=(DP1(1)-DP2(1))*V12 +SV1*DV2(1) +SV2*DV1(1) J12(2)=(DP1(2)-DP2(2))*V12 +SV1*DV2(2) +SV2*DV1(2) J12(3)=(DP1(3)-DP2(3))*V12 +SV1*DV2(3) +SV2*DV1(3) J34(0)=(DP3(0)-DP4(0))*V34 +SV3*DV4(0) +SV4*DV3(0) J34(1)=(DP3(1)-DP4(1))*V34 +SV3*DV4(1) +SV4*DV3(1) J34(2)=(DP3(2)-DP4(2))*V34 +SV3*DV4(2) +SV4*DV3(2) J34(3)=(DP3(3)-DP4(3))*V34 +SV3*DV4(3) +SV4*DV3(3) C J14(0)=(DP1(0)-DP4(0))*V14 +TV1*DV4(0) +TV4*DV1(0) J14(1)=(DP1(1)-DP4(1))*V14 +TV1*DV4(1) +TV4*DV1(1) J14(2)=(DP1(2)-DP4(2))*V14 +TV1*DV4(2) +TV4*DV1(2) J14(3)=(DP1(3)-DP4(3))*V14 +TV1*DV4(3) +TV4*DV1(3) J32(0)=(DP3(0)-DP2(0))*V23 +TV3*DV2(0) +TV2*DV3(0) J32(1)=(DP3(1)-DP2(1))*V23 +TV3*DV2(1) +TV2*DV3(1) J32(2)=(DP3(2)-DP2(2))*V23 +TV3*DV2(2) +TV2*DV3(2) J32(3)=(DP3(3)-DP2(3))*V23 +TV3*DV2(3) +TV2*DV3(3) C JS12=Q(0)*J12(0)-Q(1)*J12(1)-Q(2)*J12(2)-Q(3)*J12(3) JS34=Q(0)*J34(0)-Q(1)*J34(1)-Q(2)*J34(2)-Q(3)*J34(3) JS14=K(0)*J14(0)-K(1)*J14(1)-K(2)*J14(2)-K(3)*J14(3) JS32=K(0)*J32(0)-K(1)*J32(1)-K(2)*J32(2)-K(3)*J32(3) C JS=J12(0)*J34(0)-J12(1)*J34(1)-J12(2)*J34(2)-J12(3)*J34(3) JT=J14(0)*J32(0)-J14(1)*J32(1)-J14(2)*J32(2)-J14(3)*J32(3) C DVERTX = (V12*V34 +V14*V23 -RXTWO*V13*V24)*DGW2 C & +(dzs*dgwwz2+das*dgwwa2)*js -dzs*dgwwz2*js12*js34/dmz**2 C & +(dzt*dgwwz2+dat*dgwwa2)*jt -dzt*dgwwz2*js14*js32/dmz**2 C VERTEX = -DCMPLX( DVERTX ) C RETURN END +EOD +DECK,DINCGM. DOUBLE PRECISION FUNCTION DINCGM(A,X,EPS) C*********************************************************************** C* Series expansion of incomplete gamma function, from Abramowitz and * C* Stegun. A and X are the two arguments, while EPS is the relative * C* precision. More accurately, if X > 0, EPS is the ratio of the last * C* term in the series and the sum; note that for X > 0, the series is * C* alternating. For X < 0, this ratio is required to be < EPS/100. * C*********************************************************************** DOUBLE PRECISION A,X,EPS,SUM,TERM,XN C IF(DABS(A).LT.1.D-10) THEN C WRITE(*,*) ' Function diverges for A = 0!' C DINCGM = 1.D50 C RETURN C ENDIF SUM = 1.D0/A TERM = 1.D0 !Term for n = 0 H = 1.D0 XN = 1.D0 1 H = -H*X/XN TERM = H/(A+XN) XN = XN+1.D0 SUM = SUM+TERM IF((DABS(TERM/SUM).GT.EPS.AND.X.GE.0.D0).OR. & (DABS(TERM/SUM).GT.1.D-2*EPS.AND.X.LE.0.D0)) GOTO 1 DINCGM = SUM*(X**A) RETURN END +EOD +DECK,DOMSSM SUBROUTINE DOMSSM C----------------------------------------------------------------------- C Initialize MSSM masses and decay modes from ISASUSY. C Check for validity with ISAJET masses. C Decay modes are transfered to /DKYTAB/ by /SETDKY/. C C F.E. Paige, November, 1992 C C Ver. 7.01: Add test so that AMASS is not called if ID = 0 C Ver. 7.07: Add checking for LEP bounds. C Ver. 7.10: Add SUGRA interface C Ver. 7.32: Extend to large tanb solution C Ver. 7.33: Add gauge-mediated SUSY model C Ver. 7.38: NOGRAV turns off gravitino and weaker decays C C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF C ISAJET common blocks +CDE,ITAPES +CDE,QLMASS +CDE,XMSSM +CDE,NODCAY C ISASUSY common blocks +CDE,SSLUN +CDE,SSMODE +CDE,SSSM +CDE,SSPAR +CDE,SSTYPE +CDE,SUGMG +CDE,SUGPAS +CDE,SUGXIN +CDE,SUGNU C INTEGER NOUT PARAMETER (NOUT=33) INTEGER IDOUT(NOUT) REAL AMASS,AMPL REAL AMI,SUMGAM,SUMMJ,WIDMX REAL QSUSY,ASMB,MBMB,ASMT,MTMT,SUALFS,PI,GG DOUBLE PRECISION SSMQCD INTEGER I,J,K,IFL1,IFL2,IFL3,JSPIN,INDEX,IALLOW,IITEST,IMDL INTEGER IMHL,IMHC,IMSQ C DATA IDOUT/ $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR, $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL, $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2, $ISHL,ISHH,ISHA,ISHC/ DATA AMPL/2.4E18/,IAL3UN/0/ C C Generate masses and decays C C FIRST SET HIGH SCALE FOR SUSY BCs; default is M_GUT XSUGIN(7)=XSBCS IF (XMGVTO.LT.1.E19) AMGVSS=XMGVTO IF(.NOT.GOMSSM) RETURN LOUT=ITLIS IF (AL3UNI) IAL3UN=1 IF (INUHM.EQ.1) THEN MU=XNUSUG(19) AMHA=XNUSUG(20) TWOM1=-MU END IF IF(GOSUG) THEN C SUGRA input C First solve renormalization group equations IF (XMAJNR.LT.1.E19) THEN XNRIN(1)=XMN3NR XNRIN(2)=XMAJNR XNRIN(3)=XANSS XNRIN(4)=XNRSS ELSE XNRIN(2)=1.E20 END IF IF (GOAMSB.OR.GOMMAM.OR.GOHCAM) THEN XA0SU=0. XAMIN(1)=XCQAM XAMIN(2)=XCDAM XAMIN(3)=XCUAM XAMIN(4)=XCLAM XAMIN(5)=XCEAM XAMIN(6)=XCHDAM XAMIN(7)=XCHUAM XAMIN(8)=XL1AM XAMIN(9)=XL2AM XAMIN(10)=XL3AM XAMIN(11)=XM0SU IF (GOAMSB) THEN IMDL=7 CALL SUGRA(XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),IMDL) ELSE IF (GOMMAM) THEN IMDL=9 CALL SUGRA(XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),IMDL) ELSE IF (GOHCAM) THEN IMDL=10 CALL SUGRA(0.,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),IMDL) END IF ELSE IMDL=1 CALL SUGRA(XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),IMDL) END IF IF (NOGOOD.EQ.1) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: TACHYONIC PARTICLES!' ELSE IF (NOGOOD.EQ.2) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: NO EW SYMMETRY BREAKING!' ELSE IF (NOGOOD.EQ.3) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: M(H_P)^2<0!' ELSE IF (NOGOOD.EQ.4) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: YUKAWA>10!' ELSE IF (NOGOOD.EQ.5) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: Z1SS NOT LSP!' ELSE IF (NOGOOD.EQ.7) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: XT EWSB IS BAD!' ELSE IF (NOGOOD.EQ.8) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: MHL^2<0!' ELSE IF (NOGOOD.EQ.9) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: M(3RD)^2<0!' END IF IF (MHPNEG.EQ.1) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: M(H_P)^2<0!!' NOGOOD=3 END IF IF (MSQNEG.EQ.1) THEN WRITE(LOUT,*) 'SUGRA BAD POINT: M(3rd)^2<0!!' NOGOOD=9 END IF IF(NOGOOD.NE.0) STOP99 IF(ITACHY.NE.0) THEN WRITE(LOUT,*) 'WARNING: TACHYONIC SLEPTONS AT GUT SCALE' WRITE(LOUT,*) ' POINT MAY BE INVALID' ENDIF C Then calculate masses and decays CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3), $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9), $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14), $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19), $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24), $ AMASS(6),IALLOW,IMDL,IMHL,IMHC,IMSQ) ELSE IF(GOGMSB) THEN C GMSB input XGMIN(8)=XRSLGM XGMIN(9)=XDHDGM XGMIN(10)=XDHUGM XGMIN(11)=XDYGM XGMIN(12)=XN51GM XGMIN(13)=XN52GM XGMIN(14)=XN53GM C First solve renormalization group equations IMDL=2 CALL SUGRA(XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,AMASS(6),IMDL) IF (NOGOOD.EQ.1) THEN WRITE(LOUT,*) 'GMSB BAD POINT: TACHYONIC PARTICLES!' ELSE IF (NOGOOD.EQ.2) THEN WRITE(LOUT,*) 'GMSB BAD POINT: NO EW SYMMETRY BREAKING!' ELSE IF (NOGOOD.EQ.3) THEN WRITE(LOUT,*) 'GMSB BAD POINT: M(H_P)^2<0!' ELSE IF (NOGOOD.EQ.4) THEN WRITE(LOUT,*) 'GMSB BAD POINT: YUKAWA>100!' ELSE IF (NOGOOD.EQ.7) THEN WRITE(LOUT,*) 'GMSB BAD POINT: XT EWSB IS BAD!' ELSE IF (NOGOOD.EQ.8) THEN WRITE(LOUT,*) 'GMSB BAD POINT: MHL^2<0!' ELSE IF (NOGOOD.EQ.9) THEN WRITE(LOUT,*) 'GMSB BAD POINT: M(3RD)^2<0!' END IF IF (MHPNEG.EQ.1) THEN WRITE(LOUT,*) 'GMSB BAD POINT: M(H_P)^2<0!!' NOGOOD=3 END IF IF(NOGOOD.NE.0) STOP99 IF(ITACHY.NE.0) THEN WRITE(LOUT,*) 'WARNING: TACHYONIC SLEPTONS AT HIGH SCALE' WRITE(LOUT,*) ' POINT MAY BE INVALID' ENDIF C Then calculate masses and decays AMGVSS=XLAMGM*XMESGM*XCMGV/SQRT(3.)/AMPL CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3), $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9), $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14), $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19), $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24), $ AMASS(6),IALLOW,IMDL,IMHL,IMHC,IMSQ) ELSE C Weak scale input C Values of 1.E20 indicate that SSMASS should calculate C M_1 and M_2 from M_3 C First do fermion masses at QSUSY since SUGRA is not called QSUSY=SQRT(XQ3SS*XTRSS) PI=4.*ATAN(1.) C Define heavy quark pole masses and LambdaQCD: AMBT=AMASS(5) AMTP=AMASS(6) ALQCD4=0.177 ASMB=SUALFS(AMBT**2,.36,AMTP,3) MBMB=AMBT*(1.-4*ASMB/3./PI) MBQ=SSMQCD(DBLE(MBMB),DBLE(QSUSY)) ASMT=SUALFS(AMTP**2,.36,AMTP,3) MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))* $ (ASMT/PI)**2) MTQ=SSMQCD(DBLE(MTMT),DBLE(QSUSY)) MLQ=1.7463 C Define TANBQ parameters= TANB for MSSM runs, but not for SUGRA AMW=80.423 ALFAEM=1./128. SN2THW=.232 GG=SQRT(4*PI*ALFAEM/SN2THW) VUQ=SQRT(2*AMW**2/GG**2/(1.+1./XTBSS**2)) VDQ=VUQ/XTBSS CALL SSMSSM(XGLSS,XMUSS,XHASS,XTBSS,XQ1SS,XDRSS,XURSS,XL1SS, $ XERSS,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS,XQ3SS,XBRSS,XTRSS,XL3SS, $ XTARSS,XATSS,XABSS,XATASS,XM1SS,XM2SS,AMASS(6),IALLOW,0, $IMHL,IMHC,IMSQ) ENDIF C C Test parameters C IF(IALLOW.NE.0) THEN WRITE(LOUT,1000) 1000 FORMAT(//' MSSM WARNING: Z1SS IS NOT LSP') ENDIF CALL SSTEST(IALLOW) IITEST=IALLOW/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1002) 1002 FORMAT(' MSSM WARNING: Z -> Z1SS Z1SS TOO BIG') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1004) 1004 FORMAT(' MSSM WARNING: Z -> CHARGINOS ALLOWED') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1008) 1008 FORMAT(' MSSM WARNING: Z -> Z1SS Z2SS TOO BIG') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1008) 1016 FORMAT(' MSSM WARNING: Z -> SQUARKS OR SLEPTONS') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1032) 1032 FORMAT(' MSSM WARNING: Z -> Z* HL0 TOO BIG') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1064) 1064 FORMAT(' MSSM WARNING: Z -> HL0 HA0 ALLOWED') ENDIF IITEST=IITEST/2 IF(MOD(IITEST,2).NE.0) THEN WRITE(LOUT,1128) 1128 FORMAT(' MSSM WARNING: Z -> H+ H- ALLOWED') ENDIF C C Store masses in /QLMASS/ C CALL FLAVOR(ISUPL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMULSS CALL FLAVOR(ISDNL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMDLSS CALL FLAVOR(ISSTL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMSLSS CALL FLAVOR(ISCHL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMCLSS CALL FLAVOR(ISBT1,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMB1SS CALL FLAVOR(ISTP1,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMT1SS CALL FLAVOR(ISUPR,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMURSS CALL FLAVOR(ISDNR,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMDRSS CALL FLAVOR(ISSTR,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMSRSS CALL FLAVOR(ISCHR,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMCRSS CALL FLAVOR(ISBT2,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMB2SS CALL FLAVOR(ISTP2,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMT2SS C CALL FLAVOR(ISNEL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMN1SS CALL FLAVOR(ISEL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMELSS CALL FLAVOR(ISNML,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMN2SS CALL FLAVOR(ISMUL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMMLSS CALL FLAVOR(ISNTL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMN3SS CALL FLAVOR(ISTAU1,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AML1SS CALL FLAVOR(ISER,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMERSS CALL FLAVOR(ISMUR,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AMMRSS CALL FLAVOR(ISTAU2,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=AML2SS C CALL FLAVOR(ISGL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMGLSS) CALL FLAVOR(ISZ1,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMZ1SS) CALL FLAVOR(ISZ2,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMZ2SS) CALL FLAVOR(ISZ3,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMZ3SS) CALL FLAVOR(ISZ4,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMZ4SS) CALL FLAVOR(ISW1,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMW1SS) CALL FLAVOR(ISW2,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMW2SS) C CALL FLAVOR(ISHL,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMHL) CALL FLAVOR(ISHH,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMHH) CALL FLAVOR(ISHA,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMHA) CALL FLAVOR(ISHC,IFL1,IFL2,IFL3,JSPIN,INDEX) AMLEP(INDEX)=ABS(AMHC) C C Check decays with ISAJET masses C NOGRAV turns off gravitino decays and all weaker ones C WIDMX=0 IF(NOGRAV) THEN DO 90 J=1,NSSMOD DO 91 K=1,5 IF(JSSMOD(K,J).EQ.ISGRAV) WIDMX=MAX(WIDMX,GSSMOD(J)) 91 CONTINUE 90 CONTINUE ENDIF WIDMX=1.01*WIDMX C DO 100 I=1,NOUT SUMGAM=0 AMI=AMASS(IDOUT(I)) DO 110 J=1,NSSMOD IF(IDOUT(I).NE.ISSMOD(J)) GO TO 110 SUMMJ=0 DO 111 K=1,5 IF(JSSMOD(K,J).NE.0) SUMMJ=SUMMJ+AMASS(JSSMOD(K,J)) 111 CONTINUE IF(SUMMJ.GE.AMI.OR.GSSMOD(J).LT.WIDMX) GSSMOD(J)=0 SUMGAM=SUMGAM+GSSMOD(J) 110 CONTINUE DO 120 J=1,NSSMOD IF(IDOUT(I).NE.ISSMOD(J)) GO TO 120 IF(SUMGAM.NE.0) THEN BSSMOD(J)=GSSMOD(J)/SUMGAM ELSE BSSMOD(J)=0 ENDIF 120 CONTINUE 100 CONTINUE C RETURN END +EOD +DECK,DRLLYN. SUBROUTINE DRLLYN C C Generate QMW (and QTW) for DRELLYAN or HIGGS event using C integrated cross section. Then generate decay -- for HIGGS, C the mode must be chosen using the integrated cross sections C because of interference with W+W->W+W scattering. C C Note that NOGOOD calls the cross section. C C Ver. 6.40: Add technicolor resonances. Use logs for QDEN, C PTDEN, WTFAC, etc. Also scale QMW generation by QMAX. C C Ver. 7.01: Correct QDEN to correspond to correct fit form: C SIGMA = ANOMR(K)*(QMAX**2/Q**2)**QPOW C See QFUNC. C C Ver. 7.14: Add SUSY Higgs C Ver. 7.15: Fix bug with THETAW limits by adding epsilon to C allowed range. Check for possible invalid Higgs decays. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSIG +CDE,TOTALS +CDE,Q1Q2 +CDE,PARTCL +CDE,PJETS +CDE,PINITS +CDE,WCON +CDE,PRIMAR +CDE,DYLIM +CDE,CONST +CDE,JETPAR +CDE,JETLIM +CDE,WGEN +CDE,DYPAR +CDE,KEYS. +CDE,HCON. +CDE,ISLOOP +CDE,IDRUN +CDE,XMSSM +CDE,LISTSS C DIMENSION X(2) EQUIVALENCE (X(1),X1) DIMENSION PREST(5),PL(5),EL(3),EML(3),EMSQL(3) DIMENSION WTFAC(3) LOGICAL NOGOOD LOGICAL YGENJ DIMENSION BRANCH(29),LISTJ(29),LISTW(5) REAL ACOSH,XXX,ASINH,CHOOSE,RANF,SUM,WTFAC,PTDEN,QDEN,ETA,QPW, $S12,BRANCH,SUMBR,BRMODE,AMASS,BRINV,TRY,EMSQL,EL,PL12,PREST, $COSTHL,THL,PHL,PTL,SGN,PL,BP,PLPL,PLMN,AMINI,AMFIN,PINI,PFIN, $ QPL,QMN,AM1SQ,AM2SQ,ROOT,P1PL,P1MN,P2PL,P2MN,X,EML INTEGER NTRY,K,IQ1,IQ2,IFL1,IFL2,LISTJ,IQ,NTRY2,IFL,LISTW,I REAL ZZSTAR INTEGER IZSTAR,JVIR,N0J C DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, $10,80,-80,90/ DATA LISTW/10,80,-80,90,92/ ACOSH(XXX)=ALOG(XXX+SQRT(XXX**2-1.)) ASINH(XXX)=ALOG(XXX+SQRT(XXX**2+1.)) C C Entry C NPTCL=0 NTRY=0 200 CONTINUE SIGMA=0. WT=1. 1 CONTINUE NTRY=NTRY+1 IF(NTRY.GT.NTRIES) GO TO 999 SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN) NKINPT=NKINPT+1 SIGMA=0. WT=1. DO 2 K=1,3 2 SIGSL(K)=0 C Choose interval for cross section calculation CHOOSE=RANF() SUM=0. DO 3 K=NKL,NKH SUM=SUM+QSELWT(K) IF(CHOOSE.LE.SUM) GO TO 30 3 CONTINUE 30 KSEL=K C Generate QTW in selected region IF(.NOT.FIXQT) THEN ETA=(PTGN(1,K)+PTGN(2,K)*RANF())**PTGN(3,K) PTSEL(K)=SQRT(ETA-RNU2(K)) PTDEN=ALOG(ETA)*PTPOW(K) WTFAC(1)=ALOG(ABS(PTGN(2,K)))+ALOG(ABS(PTGN(3,K))) 1 +ALOG(ABS(PTSEL(K)**2+RNU2(K)))*((PTGN(3,K)-1.)/PTGN(3,K)) PT(3)=PTSEL(K) ELSE PTDEN=0. WTFAC(1)=-1000. ENDIF C Generate QMW IF(.NOT.FIXQM) THEN IF(.NOT.K.EQ.2) THEN QSEL(K)=QMAX**2*(QGEN(1,K)+QGEN(2,K)*RANF())**QGEN(3,K) QDEN=ALOG(QSEL(K)/QMAX**2)*QPOW(K) WTFAC(2)=ALOG(ABS(QGEN(2,K)))+ALOG(ABS(QGEN(3,K))) 1 +ALOG(QSEL(K)/QMAX**2)*((QGEN(3,K)-1.)/QGEN(3,K)) 2 +ALOG(QMAX**2) QSEL(K)=SQRT(QSEL(K)) QMW=QSEL(K) ELSE ETA=QGEN(3,K)*TAN(QGEN(1,K)+QGEN(2,K)*RANF()) QSEL(K)=SQRT(ETA+EMSQ) WTFAC(2)=ALOG(QGEN(2,K))+ALOG(QGEN(3,K)) 1 +ALOG((ETA/QGEN(3,K))**2+1.) QMW=QSEL(K) QDEN=ALOG((QMW**2-EMSQ)**2+EMGAM**2) ENDIF ELSE QDEN=0. WTFAC(2)=-1000. ENDIF SIGSL(K)=EXP(ANORM(K)-PTDEN-QDEN) C IF(STDDY) THEN WT=EXP(WTFAC(2)-ALOG(QSELWT(K))) ELSE WT=EXP(WTFAC(1)+WTFAC(2)-ALOG(QSELWT(K))) ENDIF QTW=PT(3) YW=YWMIN+(YWMAX-YWMIN)*RANF() WT=WT*(YWMAX-YWMIN) PHIW=PHWMIN+(PHWMAX-PHWMIN)*RANF() PHI(3)=AMOD(PHIW+PI,2.*PI) QPW=SQRT(QTW**2+QMW**2)*SINH(YW) QW=SQRT(QTW**2+QPW**2) THW=QPW/QW IF(ABS(THW).GT.1.) THW=SIGN(1.,THW) THW=ACOS(THW) IF(THW.LT.THWMIN-1.E-6.OR.THW.GT.THWMAX+1.E-6) GOTO 1 XW=QPW/HALFE IF(XW.LT.XWMIN.OR.XW.GT.XWMAX) GOTO 1 IF(.NOT.STDDY) THEN IF(.NOT.YGENJ(3)) GOTO 1 P(3)=PT(3)/STH(3) XJ(3)=P(3)*CTH(3)/HALFE IF(XJ(3).LT.XJMIN(3).OR.XJ(3).GT.XJMAX(3)) GOTO 1 ENDIF C C Check integrated cross section C IF(NOGOOD(2)) GO TO 1 SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN) NWGEN=NWGEN+1 S12=QMW**2 C C No decay for KKG: C For compatibility reasons, the jet is still the 3rd one. C Jets 1 and 2 (W decay products) are voided; no decay step. C IF(KEYS(11)) THEN DO 50 I=1,2 P(I)=0. PT(I)=0. CTH(I)=0. PHI(I)=0. EMSQL(I)=0. IDJETS(I)=0 50 CONTINUE GOTO 350 ENDIF C C Select W decay mode C QMW dependence neglected in branching ratios C BRANCH is cum. br. with heavy modes subtracted. C IF(KEYS(3)) THEN BRANCH(1)=0. SUMBR=0. DO 105 IQ1=2,25 IQ2=MATCH(IQ1,JWTYP) IF(IQ2.EQ.0) THEN BRMODE=0. ELSE BRMODE=WCBR(IQ1,JWTYP)-WCBR(IQ1-1,JWTYP) IFL1=LISTJ(IQ1) IFL2=LISTJ(IQ2) IF(S12.LE.(AMASS(IFL1)+AMASS(IFL2))**2) BRMODE=0. ENDIF BRANCH(IQ1)=BRANCH(IQ1-1)+BRMODE SUMBR=SUMBR+BRMODE 105 CONTINUE BRINV=1./SUMBR C TRY=RANF() DO 110 IQ=1,25 IF(TRY.LT.BRANCH(IQ)*BRINV.AND.MATCH(IQ,JWTYP).NE.0) THEN JETTYP(1)=IQ JETTYP(2)=MATCH(IQ,JWTYP) GO TO 120 ENDIF 110 CONTINUE ENDIF C 120 IF(GOMSSM) THEN IFL1=LISTSS(JETTYP(1)) IFL2=LISTSS(JETTYP(2)) ELSE IFL1=LISTJ(JETTYP(1)) IFL2=LISTJ(JETTYP(2)) ENDIF C C Select masses of decay products. These are just normal masses C except for Z Z* decay of Higgs, where one is virtual. C EML(1)=AMASS(IFL1) EML(2)=AMASS(IFL2) IF(KEYS(7).AND.EML(1)+EML(2).GT.QMW) THEN C WW* or ZZ* decay - generate/check W* or Z* mass IF((IABS(IFL1).EQ.80.AND.IABS(IFL2).EQ.80) $ .OR.(IFL1.EQ.90.AND.IFL2.EQ.90)) THEN IZSTAR=3-2*RANF() IF(GOMSSM) THEN JVIR=JETTYP(IZSTAR)-76 ELSE JVIR=JETTYP(IZSTAR)-25 ENDIF EML(IZSTAR)=ZZSTAR(QMW,JVIR) IF(EML(IZSTAR).LT.ZSTARS(JVIR,IZSTAR)) GO TO 200 C Other decay - invalid for this QMW ELSE GO TO 200 ENDIF ENDIF C C Generate W decay in its rest frame and compare with SIGDY2. C First set up momenta of decay products: C EMSQL(1)=EML(1)**2 EMSQL(2)=EML(2)**2 EL(1)=(S12+EMSQL(1)-EMSQL(2))/(2.*QMW) EL(2)=(S12+EMSQL(2)-EMSQL(1))/(2.*QMW) PL12=SQRT((S12-(EML(1)+EML(2))**2)*(S12-(EML(1)-EML(2))**2)) $/(2.*QMW) C W momentum PREST(1)=QTW*COS(PHIW) PREST(2)=QTW*SIN(PHIW) PREST(3)=QPW PREST(4)=SQRT(QW**2+QMW**2) PREST(5)=QMW NTRY2=0 C Generate next W decay 20 CONTINUE NTRY2=NTRY2+1 IF(NTRY2.GT.NTRIES) GO TO 999 COSTHL=2.*RANF()-1. THL=ACOS(COSTHL) PHL=2.*PI*RANF() PTL=PL12*SIN(THL) C DO 300 I=1,2 SGN=3-2*I PL(1)=SGN*PTL*COS(PHL) PL(2)=SGN*PTL*SIN(PHL) PL(3)=SGN*PL12*COSTHL PL(4)=EL(I) PL(5)=EML(I) C Boost with W momentum BP=0. DO 310 K=1,3 310 BP=BP+PL(K)*PREST(K) BP=BP/PREST(5) DO 320 K=1,3 320 PL(K)=PL(K)+PREST(K)*PL(4)/PREST(5) $ +PREST(K)*BP/(PREST(4)+PREST(5)) PL(4)=PL(4)*PREST(4)/PREST(5)+BP C Fill common blocks PT(I)=SQRT(PL(1)**2+PL(2)**2) P(I)=SQRT(PT(I)**2+PL(3)**2) IF(PT(I).GT.0.) THEN PHI(I)=ATAN2(PL(2),PL(1)) ELSE PHI(I)=(I-1)*PI ENDIF IF(PHI(I).LT.0.) PHI(I)=PHI(I)+2.*PI CTH(I)=PL(3)/P(I) STH(I)=PT(I)/P(I) TH(I)=ACOS(CTH(I)) XJ(I)=PL(3)/HALFE IF(CTH(I).GT.0.) THEN PLPL=PL(4)+PL(3) PLMN=(PT(I)**2+EMSQL(I))/PLPL ELSE PLMN=PL(4)-PL(3) PLPL=(PT(I)**2+EMSQL(I))/PLMN ENDIF YJ(I)=.5*ALOG(PLPL/PLMN) 300 CONTINUE C C Test cross section C Extra kinematics for W+W->W+W C IF(KEYS(7).OR.KEYS(9)) THEN SHAT=S12 IF(GOMSSM) THEN AMINI=AMASS(LISTSS(INITYP(1))) ELSE AMINI=AMASS(LISTJ(INITYP(1))) ENDIF AMFIN=EML(1) PINI=.5*SQRT(S12-4.*AMINI**2) PFIN=PL12 THAT=AMINI**2+AMFIN**2-.5*S12+2.*PINI*PFIN*COSTHL UHAT=AMINI**2+AMFIN**2-.5*S12-2.*PINI*PFIN*COSTHL ENDIF C C Check W decay C IF(NOGOOD(3)) GO TO 20 C C Check W decay with kinematic limits C IF(NOGOOD(4)) GO TO 200 350 NKEEP=NKEEP+1 C C Set PBEAM C PBEAM(1)=(1.-X1)*HALFE PBEAM(2)=(1.-X2)*HALFE IF(NJET.LT.3) GO TO 502 IFL=LISTJ(JETTYP(3)) EMSQL(3)=AMASS(IFL)**2 502 CONTINUE C C Set PJETS C IF(KEYS(11)) THEN N0J=3 ELSE N0J=1 ENDIF DO 501 I=N0J,NJET PJETS(3,I)=P(I)*CTH(I) PJETS(1,I)=PT(I)*COS(PHI(I)) PJETS(2,I)=PT(I)*SIN(PHI(I)) PJETS(4,I)=SQRT(P(I)**2+EMSQL(I)) PJETS(5,I)=SQRT(EMSQL(I)) IF(KEYS(7).AND.GOMSSM) THEN IDJETS(I)=LISTSS(JETTYP(I)) ELSE IDJETS(I)=LISTJ(JETTYP(I)) ENDIF 501 CONTINUE C No technicolor IDENT's defined, so... IF(KEYS(3)) THEN IDENTW=LISTW(JWTYP) ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN IDENTW=81 ELSEIF(KEYS(7).AND.GOMSSM) THEN IDENTW=IHTYPE ELSEIF(KEYS(11)) THEN IDENTW=92 ELSE IDENTW=0 ENDIF C W momentum in /PJETS/ IF(KEYS(11)) THEN QWJET(1)=QTW*COS(PHIW) QWJET(2)=QTW*SIN(PHIW) QWJET(3)=QPW QWJET(4)=SQRT(QW**2+QMW**2) QWJET(5)=QMW ELSE DO 503 K=1,4 503 QWJET(K)=PJETS(K,1)+PJETS(K,2) QWJET(5)=QMW ENDIF C C Set PINITS DO 504 I=1,2 IF(KEYS(7).AND.GOMSSM) THEN IDINIT(I)=LISTSS(INITYP(I)) ELSE IDINIT(I)=LISTJ(INITYP(I)) ENDIF PINITS(5,I)=AMASS(IDINIT(I)) PINITS(1,I)=0. PINITS(2,I)=0. 504 CONTINUE C Calculate total momentum QPL=QWJET(4)+QWJET(3) QMN=QWJET(4)-QWJET(3) IF(NJET.EQ.3) THEN QPL=QPL+PJETS(4,3)+PJETS(3,3) QMN=QMN+PJETS(4,3)-PJETS(3,3) ENDIF C and solve initial kinematics AM1SQ=PINITS(5,1)**2 AM2SQ=PINITS(5,2)**2 ROOT=SQRT((QPL*QMN-AM1SQ-AM2SQ)**2-4.*AM1SQ*AM2SQ) P1PL=(QPL*QMN+AM1SQ-AM2SQ+ROOT)/(2.*QMN) P1MN=AM1SQ/P1PL P2MN=(QPL*QMN+AM2SQ-AM1SQ+ROOT)/(2.*QPL) P2PL=AM2SQ/P2MN PINITS(3,1)=.5*(P1PL-P1MN) PINITS(4,1)=.5*(P1PL+P1MN) PINITS(3,2)=.5*(P2PL-P2MN) PINITS(4,2)=.5*(P2PL+P2MN) RETURN C 999 CALL PRTEVT(0) WRITE(ITLIS,9999) NTRIES 9999 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN', C' EVENT. CHECK LIMITS OR INCREASE NTRIES') STOP 99 END +EOD +DECK,EBEAM. REAL FUNCTION EBEAM(X,E) C*********************************************************************** C* Computes the effective single electron spectrum from beamstrahlung at * C* e+e- colliders, using Peskin expression Eq. 6 of SLAC-TN-04-032. * C* Use beamstrahlung parameter Y; is supposed to work for Y <= 10 * C* The quantities in the COMMON block are the beamstrahlungs parameter * C* Y, the bunch length XL in GeV, the number of photons NGAM, and the * C* parameters NUCL, NUGAM, W, XKAPPA defined by Chen, as well as the * C* pre-factor FAC. Y, E and XLMM are read in by BEAM when it is called * C* for the first time, with INIT=1; in this first run the other para- * C* meters are then computed, and simply used in later calls with * C* INIT = 0. This COMMON block should be present in the main program * C* in order to guarantee the survival of these parameters. Finally, X * C* is the electron energy in units of the nominal beam energy. Notice * C* that EBEAM is only the part which is NOT proportional to * C* delta(1-X); the coefficient of the delta-function is simply * C* exp(-N). * C*********************************************************************** +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,EEPAR C REAL X,E,GAMMA REAL*8 DX,DE,Z,Y,XL,GAM,RE,XKAPPA,NUCL,NUGAM,NGAM,NGAM2, $YY,HTOT,H,HTOT0,DEBEAM,DNFAC INTEGER N,NFAC,II IF (X.LT.1.E-5) X=1.E-5 IF (X.GT..99999) X=.99999 DX=X DE=E Z=1.D0-DX Y=UPSLON XL = SIGZ*1.D12/.197327D0 GAM = DE/5.11D-4 RE = 1.D0/(137.D0*5.11D-4) XKAPPA = 2.D0/(3.D0*Y) NUCL = 2.5D0*Y/(SQRT(3.D0)*137.D0**2*GAM*RE) NUGAM = NUCL/SQRT(1.D0+Y**.6666666D0) NGAM = DSQRT(3.D0)*NUGAM*XL NGAM2=NGAM/2.D0 YY=NGAM2*(XKAPPA*Z/X)**.333333D0 HTOT=0.D0 DO N=1,20 NFAC=1 DO II=1,N NFAC=NFAC*II END DO DNFAC=DBLE(FLOAT(NFAC)) H=YY**N/DNFAC/DBLE(GAMMA(FLOAT(N)/3.)) HTOT0=HTOT HTOT=HTOT+H IF (ABS(HTOT0-HTOT)/HTOT.LT..001D0.AND.N.GT.3) GO TO 101 END DO 101 CONTINUE DEBEAM=DEXP(-XKAPPA*Z/DX)/Z/DX*HTOT*DEXP(-NGAM2) EBEAM=DEBEAM IF(EBEAM.LT.0.) EBEAM = 1.E-20 RETURN END +EOD +DECK,EEBEG. SUBROUTINE EEBEG C INITIALIZE E-E+ EVENTS FOR DOLOG +CDE,ITAPES +CDE,PRIMAR +CDE,JETLIM +CDE,JETPAR DO 100 I=1,2 PMIN(I)=HALFE PMAX(I)=-1.E9 100 CONTINUE QSQ=SCM IDIN(1)=12 IDIN(2)=-12 RETURN END +EOD +DECK,EEMAX. SUBROUTINE EEMAX C FIND UPPER BOUND FOR E+E- CROSS SECTION SUMMED OVER ALLOWED C TYPES. C VER 7.17: ENSURE XJMIN < XX < XJMAX C VER 7.42: ENACT BREMSSTRAHLUNG EFFECT C Ver 7.54: Define LOUT for possible SSXINT error message. +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSIG +CDE,EEPAR +CDE,JETLIM +CDE,JETPAR +CDE,PRIMAR +CDE,XMSSM +CDE,SSSM +CDE,BREMBM +CDE,SSLUN C REAL ETEST(3),XDI(3),RSH,XD,XDUMMY,SSFEL,DX,XX INTEGER NET,NXD,NX,NX1,IET,IXD,IX,I C NET=1 NXD=1 ETEST(1)=ECM C Initialize beam/brem spectra convolution and fit IF (IBEAM) THEN LOUT=ITLIS EB=HALFE QSQBM=EB**2 WRITE(ITLIS,*) ' BEGINNING BREM/BEAM CONVOLUTION AND FIT...' XDUMMY=SSFEL(.1,1) END IF IF (IBREM) THEN NET=3 NXD=3 ETEST(1)=RSHMIN IF (RSHMAX.GT.AMZ.AND.RSHMIN.LT.AMZ) THEN ETEST(2)=AMZ ELSE ETEST(2)=RSHMIN+(RSHMAX-RSHMIN)/2. END IF ETEST(3)=MIN(RSHMAX,.999*ECM) END IF SGMXEE=0. NX=50 IF(FIXYJ(1)) NX=1 NX1=NX+1 DX=(XJMAX(1)-XJMIN(1))/NX C SCAN IN X=COS(THETA) DO IET=1,NET RSH=ETEST(IET) SHAT=RSH*RSH XDI(1)=-(1.-SHAT/SCM) XDI(2)=0. XDI(3)=-XDI(1) DO IXD=1,NXD XD=XDI(IXD) X1=(XD+SQRT(XD**2+4*SHAT/SCM))/2. X2=X1-XD DO 100 IX=1,NX1 XX=XJMIN(1)+DX*(IX-1) IF(XX.LT.XJMIN(1)) XX=XJMIN(1) IF(XX.GT.XJMAX(1)) XX=XJMAX(1) CTH(1)=XX CTH(2)=-XX DO 110 I=1,2 XJ(I)=CTH(I) TH(I)=ACOS(CTH(I)) STH(I)=SIN(TH(I)) PT(I)=HALFE*STH(I) IF(IX.EQ.1) YJ(I)=YJMIN(I) IF(IX.EQ.NX1) YJ(I)=YJMAX(I) IF(IX.GT.1.AND.IX.LT.NX1) 1 YJ(I)=.5*ALOG((1.+CTH(I))/(1.-CTH(I))) 110 CONTINUE C COMPUTE CROSS SECTION IF (GOMSSM) THEN CALL SIGSSE ELSE CALL SIGEE END IF IF(SIGMA.GT.SGMXEE) SGMXEE=SIGMA 100 CONTINUE END DO END DO C REQUIRE CROSS SECTION BE POSITIVE WRITE(ITLIS,1000) SGMXEE 1000 FORMAT(///' MAXIMUM D(SIGMA)/D(COS THETA) = ',E12.4) IF(SGMXEE.GT.0) RETURN STOP 99 END +EOD +DECK,ELCTRN. SUBROUTINE ELCTRN C GENERATE E+ E- ----> QK QB EVENT USING SIGEE CROSS SECTION. +CDE,ITAPES +CDE,JETSIG +CDE,EEPAR +CDE,PRIMAR +CDE,PJETS +CDE,PINITS +CDE,JETPAR +CDE,JETLIM +CDE,CONST +CDE,TOTALS +CDE,PARTCL +CDE,XMSSM +CDE,SSTYPE REAL AMQ(2),SSXLAM,RSH,XD,GAM,V,DUMMY INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2,IDSS(85) PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) DIMENSION LISTJ(30) DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, 111,-11,12,-12,13,-13,14,-14,15,-15,16,-16,10,80,-80,90,81/ DATA IDSS/0, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2,ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4, $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL, $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR, $ISTAU2,MSTAU2, $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13, $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/ C ENTRY NPTCL=0 NREJ=-1 SIGMA=0. NSIGS=0 DO 10 I=1,MXSIGS 10 SIGS(I)=0. WT=1. C GENERATE NEXT KINEMATIC POINT 100 CONTINUE NREJ=NREJ+1 IF(NREJ.GT.NTRIES) GO TO 9999 NKINPT=NKINPT+1 SUMWT=SUMWT+SIGMA*WT IF (IBREM) THEN RSH=RSHMIN+(RSHMAX-RSHMIN)*RANF() SHAT=RSH**2 QSQ=SHAT XD=(1.-SHAT/SCM)*(-1.+2*RANF()) X1=(XD+SQRT(XD**2+4*SHAT/SCM))/2. X2=X1-XD ELSE SHAT=SCM RSH=SQRT(SHAT) X1=1. X2=1. END IF PHI(1)=PHIMIN(1)+(PHIMAX(1)-PHIMIN(1))*RANF() PHI(2)=AMOD(PHI(1)+PI,2.*PI) CTH(1)=XJMIN(1)+(XJMAX(1)-XJMIN(1))*RANF() CTH(2)=-CTH(1) DO 110 I=1,2 TH(I)=ACOS(CTH(I)) STH(I)=SIN(TH(I)) PT(I)=HALFE*STH(I) YJ(I)=.5*ALOG((1+CTH(I))/(1-CTH(I))) XJ(I)=CTH(I) IDINIT(I)=IDIN(I) PINITS(1,I)=0. PINITS(2,I)=0. PINITS(5,I)=AME 110 CONTINUE C Set some PINITS parameters PINITS(3,1)=X1*HALFE PINITS(3,2)=-X2*HALFE PINITS(4,1)=SQRT(PINITS(3,1)**2+AME**2) PINITS(4,2)=SQRT(PINITS(3,2)**2+AME**2) C CALCULATE CROSS SECTION IF (GOMSSM) THEN CALL SIGSSE ELSE CALL SIGEE END IF WT=XJMAX(1)-XJMIN(1) C TEST CROSS SECTION IF(SIGMA.GT.SGMXEE) SGMXEE=SIGMA IF(SIGMA.LT.SGMXEE*RANF()) GO TO 100 SUMWT=SUMWT+SIGMA*WT NKEEP=NKEEP+1 C SELECT JET TYPES SIGINV=1./SIGMA TRY=RANF() SUM=0. DO 200 I=1,NSIGS SUM=SUM+SIGS(I)*SIGINV IF(SUM.LT.TRY) GO TO 200 C FIND REACTION ISIGS=I SIGEVT=SIGS(ISIGS) II=INOUT(I)/IOPAK**2 JETTYP(1)=MOD(II,IOPAK) II=II/IOPAK JETTYP(2)=MOD(II,IOPAK) GO TO 210 200 CONTINUE GO TO 9998 C SET PJETS. RESET P AND PT INCLUDING MASSES. 210 CONTINUE IF (GOMSSM) THEN AMQ(1)=AMASS(IDSS(JETTYP(1))) AMQ(2)=AMASS(IDSS(JETTYP(2))) ELSE AMQ(1)=AMASS(LISTJ(JETTYP(1))) AMQ(2)=AMASS(LISTJ(JETTYP(2))) END IF PCM=SQRT(SSXLAM(SHAT,AMQ(1)**2,AMQ(2)**2))/2./RSH DO 220 I=1,2 PJETS(1,I)=PCM*STH(I)*COS(PHI(I)) PJETS(2,I)=PCM*STH(I)*SIN(PHI(I)) PJETS(3,I)=PCM*CTH(I) PJETS(4,I)=SQRT(PCM**2+AMQ(I)**2) PJETS(5,I)=AMQ(I) IF (GOMSSM) THEN IDJETS(I)=IDSS(JETTYP(I)) ELSE IDJETS(I)=LISTJ(JETTYP(I)) END IF P(I)=PCM PT(I)=P(I)*STH(I) 220 CONTINUE C IF BREMSSTRAHLUNG, THEN BOOST TO LAB FRAME IF (IBREM) THEN GAM=(X1+X2)*ECM/2./RSH V=-SIGN(1.,(X1-X2))*SQRT(ABS(1.-1./GAM)*(1.+1./GAM)) DO I=1,2 DUMMY=PJETS(4,I) PJETS(4,I)=GAM*(PJETS(4,I)-V*PJETS(3,I)) PJETS(3,I)=GAM*(PJETS(3,I)-V*DUMMY) END DO END IF RETURN C ERROR MESSAGES 9998 CONTINUE CALL PRTEVT(0) WRITE(ITLIS,1010) 1010 FORMAT(//' ERROR IN ELCTRN...NO GOOD JET TYPES FOUND') STOP 99 9999 CONTINUE CALL PRTEVT(0) WRITE(ITLIS,1020) NTRIES 1020 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN', $' EVENT. CHECK LIMITS OR INCREASE NTRIES.') STOP 99 END +EOD +DECK,EPF. FUNCTION EPF(A,B,C,D) C CALCULATE TOTALLY ANTISYMMETRIC TENSOR EPSILON CONTRACTED C WITH FOUR 4-VECTORS. +CDE,ITAPES DIMENSION A(4),B(4),C(4),D(4) +SELF,IF=DOUBLE. DOUBLE PRECISION EPF DOUBLE PRECISION A,B,C,D,CD,BCD +SELF. CD(I,J)=C(I)*D(J)-C(J)*D(I) BCD(I,J,K)=B(I)*CD(J,K)-B(J)*CD(I,K)+B(K)*CD(I,J) EPF=A(1)*BCD(2,3,4)-A(2)*BCD(1,3,4)+A(3)*BCD(1,2,4) 1-A(4)*BCD(1,2,3) RETURN END +EOD +DECK,ESTRUC. FUNCTION ESTRUC(X,QS) C C THIS IS ELECTRON PARTON DISTRIBUTION FUNCTION; C SAME AS USED IN PYTHIA; NOTE! ESTRUC=0 FOR X>.999999 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL ESTRUC,AL,PI,AME,QS,X,BT,XM,T,A,B C AL=1./128. PI=4*ATAN(1.) AME=.511E-3 BT=2*AL/PI*(LOG(QS/AME/AME)-1.) C KLEISS/SJOSTRAND PRESCRIPTION C IF (X.LE..9999) THEN C ESTRUC=BT/2.*(1.-X)**(BT/2.-1.) C ELSE IF (X.LE..999999.AND.X.GT..9999) THEN C ESTRUC=100.**(BT/2.)/(100.**(BT/2.)-1.)*BT/2.* C $ (1.-X)**(BT/2.-1.) C ELSE C ESTRUC=0. C END IF C FADIN-KURAEV/DREES PRESCRIPTION XM=.998 IF(X.GT.XM) THEN T = (1.+.375*BT)*(1.-XM)**(BT/2.) A = ((1.0-BT/2.)*T & -.25*BT*(1.5-XM*(1.+XM/2.)))/(1.-XM) & +.25*BT*(1.0+XM) A = 2*A/(1.-XM) B = .5*BT*T/(1.-XM) - .25*BT*(1.+XM) - A*XM ESTRUC = A*X+B ELSE ESTRUC = .5*BT*((1.-X)**(.5*BT-1.)) * (1.+.375*BT) & -.25*BT*(1.+X) ENDIF RETURN END +EOD +DECK,EVOL01 SUBROUTINE EVOL01 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 1 (TWOJET) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,FRAME REAL EVOLMS INTEGER I,K,J,NJSAVE,NJFINL C---------------------------------------------------------------------- C C Copy momenta from /PJETS/ to /JETSET/ N0JETS=NJSET+1 CALL IPJSET NJSAVE=NJSET C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C CALL ISTRAD(1.0) C IF(NJSET.LT.0) RETURN C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.) C C Set maximum off-shell masses and JDCAY flags. C NJFINL=N0JETS DO 310 J=N0JETS,NJSAVE IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=EVOLMS(J,1.0) JDCAY(J)=-1 ENDIF 310 CONTINUE C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOL02 SUBROUTINE EVOL02 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 2 (E+E-) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,KEYS +CDE,FRAME REAL EVOLMS INTEGER I,K,J,NJSAVE,NJFINL C---------------------------------------------------------------------- C C Copy momenta from /PJETS/ to /JETSET/ N0JETS=NJSET+1 CALL IPJSET NJSAVE=NJSET C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.) C C Set maximum off-shell masses and JDCAY flags. C NJFINL=N0JETS DO 310 J=N0JETS,NJSAVE IF((IABS(JTYPE(J)).LT.10).OR. $ (IABS(JTYPE(J)).GE.21.AND.IABS(JTYPE(J)).LE.29).OR. $ (IABS(JTYPE(J)).GE.41.AND.IABS(JTYPE(J)).LE.46))THEN PJSET(5,J)=EVOLMS(J,1.0) JDCAY(J)=-1 ENDIF 310 CONTINUE C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOL03 SUBROUTINE EVOL03 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 3 (DRELLYAN) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,Q1Q2 +CDE,FRAME +CDE,WCON REAL EVOLMS,BP INTEGER I,K,J,NJFINL C---------------------------------------------------------------------- C C Add W momentum and recoil jets N0JETS=NJSET+1 IF(.NOT.STDDY) THEN DO 101 I=3,NJET NJSET=NJSET+1 JORIG(NJSET)=JPACK*I JTYPE(NJSET)=IDJETS(I) JDCAY(NJSET)=0 DO 105 K=1,5 105 PJSET(K,NJSET)=PJETS(K,I) IFRAME(I)=1 101 CONTINUE NJSET=NJSET+1 N0W=NJSET JORIG(NJSET)=0 JTYPE(NJSET)=IDENTW JDCAY(NJSET)=(N0W+1)*JPACK+N0W+2 DO 120 K=1,5 120 PJSET(K,NJSET)=QWJET(K) ENDIF C C Add W decays DO 110 I=1,2 NJSET=NJSET+1 JORIG(NJSET)=JPACK*I JTYPE(NJSET)=IDJETS(I) JDCAY(NJSET)=0 DO 115 K=1,5 115 PJSET(K,NJSET)=PJETS(K,I) IFRAME(I)=2 IF(STDDY) IFRAME(I)=1 110 CONTINUE C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C CALL ISTRAD(WFUDGE) C IF(NJSET.LT.0) RETURN C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C IF(STDDY) THEN CALL IFRAMS(3,4,1,.FALSE.) ELSE CALL IFRAMS(N0W+1,N0W+2,2,.FALSE.) CALL IFRAMS(N0JETS,N0W,1,.FALSE.) ENDIF C C Set maximum off-shell masses and JDCAY flags. C IF(STDDY) THEN NJFINL=3 DO 310 J=3,4 IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=QMW JDCAY(J)=-1 ENDIF 310 CONTINUE ELSE NJFINL=N0JETS DO 320 J=N0W+1,N0W+2 IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=QMW JDCAY(J)=-1 ENDIF 320 CONTINUE C Need fudge factor for DRELLYAN DO 321 J=N0JETS,N0W IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=EVOLMS(J,WFUDGE) JDCAY(J)=-1 ENDIF 321 CONTINUE ENDIF C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C C Reset FRAME using W momentum modified by evolution IF(.NOT.STDDY) THEN BP=0. DO 400 K=1,3 400 BP=BP+FRAME(K,1)*PJSET(K,N0W) BP=BP/FRAME(5,1) DO 410 K=1,3 FRAME(K,2)=PJSET(K,N0W)+FRAME(K,1)*PJSET(4,N0W)/FRAME(5,1) $ +FRAME(K,1)*BP/(FRAME(4,1)+FRAME(5,1)) 410 CONTINUE FRAME(4,2)=FRAME(4,1)*PJSET(4,N0W)/FRAME(5,1)+BP ENDIF C RETURN END +EOD +DECK,EVOL05 SUBROUTINE EVOL05 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 5 (SUPERSYM) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,FRAME REAL EVOLMS INTEGER I,K,J,NJSAVE,NJFINL,JTABS C---------------------------------------------------------------------- C C Copy momenta from /PJETS/ to /JETSET/ N0JETS=NJSET+1 CALL IPJSET NJSAVE=NJSET C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C CALL ISTRAD(1.0) C IF(NJSET.LT.0) RETURN C C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.) C C Set maximum off-shell masses and JDCAY flags. C NJFINL=N0JETS DO 325 J=N0JETS,NJSAVE JTABS=IABS(JTYPE(J)) IF(JTABS.GT.20.AND.JTABS.LT.30) THEN PJSET(5,J)=EVOLMS(J,1.0) JDCAY(J)=-1 ENDIF 325 CONTINUE C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOL06 SUBROUTINE EVOL06 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 6 (WPAIR) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,KEYS +CDE,FRAME REAL OFF,BP INTEGER I,K,J,NJSAVE,NJFINL,JTRUE C---------------------------------------------------------------------- C C Copy momenta from /PJETS/ to /JETSET/ N0JETS=NJSET+1 CALL IPJSET C C Add extra momenta for WPAIR N0PAIR=NJSET+1 DO 130 J=1,NPAIR NJSET=NJSET+1 JORIG(NJSET)=JPACK*JPAIR(J) JTYPE(NJSET)=IDPAIR(J) JDCAY(NJSET)=0 DO 135 K=1,5 135 PJSET(K,NJSET)=PPAIR(K,J) 130 CONTINUE DO 140 J=1,NPAIR,2 JET=JPAIR(J) JTRUE=N0PAIR+J-1 JDCAY(N0JETS+JET-1)=JTRUE*JPACK+JTRUE+1 140 CONTINUE NJSAVE=NJSET C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C CALL ISTRAD(1.0) C IF(NJSET.LT.0) RETURN C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C DO 200 I=3,NJSAVE,2 JMATCH(I)=I+1 200 JMATCH(I+1)=I DO 230 I=1,2 DO 231 K=1,5 231 FRAME(K,I)=PJSET(K,N0JETS+I-1) IFRAME(I)=I 230 CONTINUE C C Set up and generate final state QCD parton shower. C Boost PJSET with -FRAME. C DO 240 J=1,NJSAVE JET=JORIG(J)/JPACK IF(JET.EQ.0) JET=3 IF(JET.GT.10) GO TO 240 IF(IDJETS(JET).EQ.10) GO TO 240 C Do this boost in double precision for 32-bit machines CALL DBOOST(-1,FRAME(1,JET),PJSET(1,J)) 240 CONTINUE C C Set maximum off-shell masses and JDCAY flags. C NJFINL=N0PAIR DO 330 J=1,NPAIR IF(IABS(JTYPE(N0PAIR+J-1)).LT.10) THEN PJSET(5,N0PAIR+J-1)=PJETS(5,JPAIR(J)) JDCAY(N0PAIR+J-1)=-1 ENDIF 330 CONTINUE C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOL07 SUBROUTINE EVOL07 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 7 (HIGGS) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,PINITS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,FRAME REAL EVOLMS,BP INTEGER I,K,J,NJSAVE,NJFINL,JTRUE DOUBLE PRECISION DPASS(5),DSUM(5) INTEGER IDABS1,IDABS2 C---------------------------------------------------------------------- C C Copy momenta from /PJETS/ to /JETSET/ N0JETS=NJSET+1 CALL IPJSET C C Add extra momenta for WPAIR IDABS1=IABS(IDJETS(1)) IDABS2=IABS(IDJETS(2)) IF(IDABS1.EQ.80.OR.IDABS1.EQ.90.OR.IDABS2.EQ.80.OR. $IDABS2.EQ.90) THEN N0PAIR=NJSET+1 DO 130 J=1,NPAIR NJSET=NJSET+1 JORIG(NJSET)=JPACK*JPAIR(J) JTYPE(NJSET)=IDPAIR(J) JDCAY(NJSET)=0 DO 135 K=1,5 135 PJSET(K,NJSET)=PPAIR(K,J) 130 CONTINUE DO 140 J=1,NPAIR,2 JET=JPAIR(J) JTRUE=N0PAIR+J-1 JDCAY(N0JETS+JET-1)=JTRUE*JPACK+JTRUE+1 140 CONTINUE ENDIF NJSAVE=NJSET C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C IF(IABS(IDINIT(1)).LT.80) THEN CALL ISTRAD(1.0) IF(NJSET.LT.0) RETURN C C C Special initial state evolution for W-W fusion. ELSE CALL HEVOLV IF(NJSET.LT.0) RETURN DO 141 J=1,NJSET 141 JMATCH(J)=0 DO 142 JET=1,2 J=NJSET+1-2*JET PJSET(5,J)=-PJSET(5,JET) 142 JDCAY(J)=-2 CALL QCDINI(NJSET-3,NJSET-1) IF(NJSET.LT.0) RETURN ENDIF C C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C DO 200 I=3,NJSAVE,2 JMATCH(I)=I+1 JMATCH(I+1)=I 200 CONTINUE IF(NPAIR.EQ.0) THEN CALL DBLVEC(PJSET(1,N0JETS),DSUM) CALL DBLVEC(PJSET(1,N0JETS+1),DPASS) DO 231 K=1,4 231 DSUM(K)=DSUM(K)+DPASS(K) DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2) DO 232 K=1,5 FRAME(K,1)=DSUM(K) FRAME(K,2)=FRAME(K,1) 232 CONTINUE ELSE DO 233 I=1,2 DO 234 K=1,5 FRAME(K,I)=PJSET(K,N0JETS+I-1) 234 CONTINUE IFRAME(I)=I 233 CONTINUE ENDIF C C Set up and generate final state QCD parton shower. C Boost PJSET with -FRAME. C DO 240 J=1,NJSAVE JET=JORIG(J)/JPACK IF(JET.EQ.0) JET=3 IF(JET.GT.10) GO TO 240 C Do this boost in double precision for 32-bit machines CALL DBOOST(-1,FRAME(1,JET),PJSET(1,J)) 240 CONTINUE C C Set maximum off-shell masses and JDCAY flags. C IF(NPAIR.EQ.0) THEN NJFINL=N0JETS DO 340 J=N0JETS,NJSAVE IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=EVOLMS(J,1.0) JDCAY(J)=-1 ENDIF 340 CONTINUE ELSE NJFINL=N0PAIR DO 341 J=1,NPAIR IF(IABS(JTYPE(N0PAIR+J-1)).LT.10) THEN PJSET(5,N0PAIR+J-1)=PJETS(5,JPAIR(J)) JDCAY(N0PAIR+J-1)=-1 ENDIF 341 CONTINUE ENDIF C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOL11. SUBROUTINE EVOL11 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Setup for process 11 (EXTRADIM) C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,Q1Q2 +CDE,FRAME +CDE,WCON C INTEGER K,NJFINL,J REAL EVOLMS C---------------------------------------------------------------------- C C Add recoil jet (jet 3) NJSET=NJSET+1 N0JETS=NJSET JORIG(NJSET)=JPACK*3 JTYPE(NJSET)=IDJETS(3) JDCAY(NJSET)=0 DO 105 K=1,5 105 PJSET(K,NJSET)=PJETS(K,3) IFRAME(3)=1 C Add W (=KKG) NJSET=NJSET+1 N0W=NJSET JORIG(NJSET)=0 JTYPE(NJSET)=IDENTW JDCAY(NJSET)=0 DO 120 K=1,5 120 PJSET(K,NJSET)=QWJET(K) C C Set flags and maximum off-shell masses and generate C initial QCD parton shower. C CALL ISTRAD(1.0) IF(NJSET.LT.0) RETURN C C Final state evolution. C Define Lorentz frames and JMATCH pointers for jet evolution C and fragmentation. C CALL IFRAMS(N0JETS,N0W,1,.FALSE.) C C Set maximum off-shell masses and JDCAY flags. C NJFINL=N0JETS DO 321 J=N0JETS,N0W IF(IABS(JTYPE(J)).LT.10) THEN PJSET(5,J)=EVOLMS(J,WFUDGE) JDCAY(J)=-1 ENDIF 321 CONTINUE C C Produce final-state QCD parton cascade C CALL QCDJET(NJFINL) C RETURN END +EOD +DECK,EVOLMS FUNCTION EVOLMS(J,FUDGE) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Set evolution mass scale for parton J C- C- Returned value : maximum mass C- C- Inputs : C- J = index to PJSET array C- FUDGE= fudge factor C- C- Created 16-AUG-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL EVOLMS,FUDGE INTEGER J +CDE,LIMEVL +CDE,JETSET +CDE,JETPAR C---------------------------------------------------------------------- C IF ( USELIM ) THEN EVOLMS=SQRT(PJSET(1,J)**2+PJSET(2,J)**2)*CONCUT ELSE EVOLMS=FUDGE*SQRT(QSQ) ENDIF 999 RETURN END +EOD +DECK,EVOLVE SUBROUTINE EVOLVE C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Call for each process a subroutine to set up C- Lorentz frames and perform initial and final QCD jet C- evolution in leading-log approximation. C- C- Created 13-AUG-1991 Frank E. Paige,Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,PINITS +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,KEYS +CDE,FRAME REAL BP,PINCOM INTEGER I,K,J,JJET,IFR C---------------------------------------------------------------------- C Initialize NJSET=0 N0JETS=0 N0W=0 N0PAIR=0 C C Copy momenta from /PINITS/ to /JETSET/ IF(.NOT.KEYS(2)) THEN DO 100 I=1,2 NJSET=NJSET+1 JORIG(NJSET)=JPACK*(10+I) JTYPE(NJSET)=IDINIT(I) JDCAY(NJSET)=JPACK*I+I DO 105 K=1,5 105 PJSET(K,NJSET)=PINITS(K,I) 100 CONTINUE ENDIF C C Handle each process separately C IF(KEYS(1).OR.KEYS(8)) THEN CALL EVOL01 ELSEIF(KEYS(2)) THEN CALL EVOL02 ELSEIF(KEYS(3)) THEN CALL EVOL03 ELSEIF(KEYS(5)) THEN CALL EVOL05 ELSEIF(KEYS(6).OR.KEYS(10)) THEN CALL EVOL06 ELSEIF(KEYS(7).OR.KEYS(9)) THEN CALL EVOL07 ELSEIF(KEYS(11)) THEN CALL EVOL11 ELSEIF(KEYS(12)) THEN CALL EVOL01 ENDIF C IF(NJSET.LT.0) RETURN C C Boost /JETSET/ partons back to PP COM C DO 500 J=1,NJSET JJET=JORIG(J)/JPACK IF ( JJET.EQ.0 ) THEN IFR=1 ELSE IF(JJET.GT.10) GO TO 500 IF(IDJETS(JJET).EQ.10.AND.KEYS(6)) GO TO 500 IFR=IFRAME(JJET) ENDIF BP=0. DO 505 K=1,3 505 BP=BP+FRAME(K,IFR)*PJSET(K,J) BP=BP/FRAME(5,IFR) DO 510 K=1,3 510 PJSET(K,J)=PJSET(K,J)+FRAME(K,IFR)*PJSET(4,J)/FRAME(5,IFR) 1 +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR)) PJSET(4,J)=FRAME(4,IFR)*PJSET(4,J)/FRAME(5,IFR)+BP 500 CONTINUE C C Reset PBEAM DO 530 J=1,NJSET IF(JDCAY(J).EQ.JPACK*J+J) THEN JJET=JORIG(J)/JPACK-10 PINCOM=.5*(PJSET(4,J)+ABS(PJSET(3,J))) PBEAM(JJET)=HALFE-PINCOM ENDIF 530 CONTINUE C C Check for zero energy partons CALL IRMOV0 C RETURN END +EOD +DECK,FBRBM. REAL FUNCTION FBRBM(X) C C Integrand for convolution of C bremsstrahlung with beamstrahlung spectra C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,BREMBM C REAL EBEAM,ESTRUC,X C FBRBM=EBEAM(X,EB)*ESTRUC(XMIN/X,QSQBM)/X RETURN END +EOD +DECK,FLAVOR. SUBROUTINE FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX) C C This subroutine unpacks the IDENT code ID=+/-IJKL C C Mesons-- C I=0, J<=K, +/- is sign for J C ID=110 for PI0, ID=220 for ETA, etc. C C Baryons-- C I<=J<=K in general C J 1000 but K = 0 IF(K.EQ.0.AND.JSPIN.EQ.0) GO TO 300 C C Baryons C Only X,Y baryons are QQX, QQY, Q=U,D,S. C IF(I.GT.K.OR.J.GT.K.OR.J.EQ.0) GO TO 400 IF(K.GT.6.AND.(I.GT.3.OR.J.GT.3)) GO TO 400 IFL1=ISIGN(I,ID) IFL2=ISIGN(J,ID) IFL3=ISIGN(K,ID) IF(K.LE.6) THEN INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0)+(K-1)*K*(2*K-1)/6 1 +109*JSPIN+36*NMES+NQLEP+13 ELSE INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0)+9*(K-7)+91 1 +109*JSPIN+36*NMES+NQLEP+13 ENDIF RETURN C C Mesons C 100 CONTINUE IF(J.GT.K) GO TO 400 IF(J.EQ.K.AND.ID.LT.0) GO TO 400 IFL1=0 IFL2=ISIGN(J,ID) IFL3=ISIGN(K,-ID) INDEX=J+K*(K-1)/2+36*JSPIN+NQLEP INDEX=INDEX+13 RETURN C C Quarks, leptons, etc C 200 CONTINUE IFL1=0 IFL2=0 IFL3=0 JSPIN=0 INDEX=IDABS IF(IDABS.LT.20) RETURN C Define INDEX=20 for KS, INDEX=21 for KL INDEX=IDABS+1 IF(ID.EQ.20) INDEX=20 C INDEX=NQLEP+1,...,NQLEP+13 for W+, Higgs, Z0, GVSS, GRAV IF(IDABS.LT.80) RETURN INDEX=NQLEP+IDABS-79 RETURN C C Diquarks C 300 IF(JSPIN.GT.0.OR.I.GT.J) GO TO 400 IF(I.GT.6.OR.J.GT.6) GO TO 400 IFL1=ISIGN(I,ID) IFL2=ISIGN(J,ID) IFL3=0 JSPIN=0 INDEX=109*NBARY+36*NMES+NQLEP+13+I+J*(J-1)/2 RETURN C C Error C 400 CONTINUE IFL1=0 IFL2=0 IFL3=0 JSPIN=0 INDEX=0 RETURN C C Special mesons - used only for B decays C 500 INDXSP=400 IF(IDABS.EQ.10121) THEN INDEX=INDXSP+1 ELSEIF(IDABS.EQ.10111) THEN INDEX=INDXSP+2 ELSEIF(IDABS.EQ.10131) THEN INDEX=INDXSP+3 ELSEIF(IDABS.EQ.10231) THEN INDEX=INDXSP+4 ELSEIF(IDABS.EQ.30131) THEN INDEX=INDXSP+5 ELSEIF(IDABS.EQ.30231) THEN INDEX=INDXSP+6 ELSEIF(IDABS.EQ.132) THEN INDEX=INDXSP+7 ELSEIF(IDABS.EQ.232) THEN INDEX=INDXSP+8 ELSEIF(IDABS.EQ.10110) THEN INDEX=INDXSP+9 ELSEIF(IDABS.EQ.112) THEN INDEX=INDXSP+10 ELSEIF(IDABS.EQ.10441) THEN INDEX=INDXSP+11 ELSEIF(IDABS.EQ.20440) THEN INDEX=INDXSP+12 ELSEIF(IDABS.EQ.20441) THEN INDEX=INDXSP+13 ELSEIF(IDABS.EQ.20442) THEN INDEX=INDXSP+14 ELSEIF(IDABS.EQ.IDTAUL) THEN INDEX=INDXSP+15 ELSEIF(IDABS.EQ.IDTAUR) THEN INDEX=INDXSP+16 ELSE INDEX=0 ENDIF IF(INDEX.GT.0) THEN IFL1=0 IFL2=ISIGN(J,ID) IFL3=ISIGN(K,-ID) ELSE IFL1=0 IFL2=0 IFL3=0 ENDIF C RETURN END +EOD +DECK,FORTOP. SUBROUTINE FORTOP C---------------------------------------------------------------------- C- C- Purpose and Methods : C- add to force list forced decays for all heavy q particles C- if there was a request to force a heavy q decay C- Zero IFORCE after use C- C- Created 15-DEC-1989 Serban D. Protopopescu C- C Ver 7.30: Decay top quark rather than hadron, so no longer needed. C---------------------------------------------------------------------- +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,FORCE C---------------------------------------------------------------------- RETURN END +EOD +DECK,FRGJET SUBROUTINE FRGJET(JET) C C Hadronize all partons in /JETSET/ corresponding to jet JET. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,PINITS +CDE,PARTCL +CDE,CONST +CDE,JETSET +CDE,JWORK +CDE,KEYS +CDE,Q1Q2 +CDE,FRAME C REAL ROT(3,3),POLD(5),PNEW(5),PSUM(5) REAL CPHI,SPHI,AMSUM,ESUM,PJ,CTHJ,STHJ,PTJ INTEGER K,K1,K2,IP,NPLV1,IFAIL,NBEGIN,JET,NFRAG,NFRGMX,JETJ, $JTABS,NFIRST,J C DATA PSUM/5*0./ C C NFRAG counter protects against possible infinite loop. C NFRAG=0 NFRGMX=10*MXJSET 201 NBEGIN=NPTCL+1 NFRAG=NFRAG+1 C C Loop over partons C ESUM=0. DO 220 J=1,NJSET IF(JDCAY(J).NE.0) GO TO 220 JETJ=JORIG(J)/JPACK IF(JETJ.NE.JET) GO TO 220 ESUM=ESUM+PJSET(4,J) C C Generate Field-Feynman jet for each quark or gluon, or... C JTABS = IABS(JTYPE(J)) IF(JTABS.LT.10) THEN NFIRST=NPTCL+1 CALL JETGEN(J) IF(NPTCL.LT.NFIRST) GO TO 220 C C Rotate hadrons to parton direction C PTJ=PJSET(1,J)**2+PJSET(2,J)**2 PJ=SQRT(PTJ+PJSET(3,J)**2) PTJ=SQRT(PTJ) C Following is to fix occasional bug on 32-bit machines IF(PJ.GT.0.) THEN CTHJ=PJSET(3,J)/PJ STHJ=PTJ/PJ ELSE CTHJ=1. STHJ=0. ENDIF IF(PTJ.GT.0.) THEN CPHI=PJSET(1,J)/PTJ SPHI=PJSET(2,J)/PTJ ELSE CPHI=SIGN(1.,PJSET(3,J)) SPHI=0. ENDIF ROT(1,1)=CPHI*CTHJ ROT(2,1)=SPHI*CTHJ ROT(3,1)=-STHJ ROT(1,2)=-SPHI ROT(2,2)=CPHI ROT(3,2)=0. ROT(1,3)=CPHI*STHJ ROT(2,3)=SPHI*STHJ ROT(3,3)=CTHJ DO 230 IP=NFIRST,NPTCL DO 235 K=1,3 POLD(K)=PPTCL(K,IP) PPTCL(K,IP)=0 235 CONTINUE DO 240 K1=1,3 DO 240 K2=1,3 240 PPTCL(K1,IP)=PPTCL(K1,IP)+ROT(K1,K2)*POLD(K2) 230 CONTINUE C C ... hadronize all other partons with delta function. C ELSE IF((IABS(JTYPE(J)).EQ.80.OR.IABS(JTYPE(J)).EQ.90).AND. $ .NOT.KEYS(2).AND..NOT.KEYS(12)) GO TO 210 IF(NPTCL.GE.MXPTCL) GO TO 9999 NPTCL=NPTCL+1 DO 255 K=1,5 PPTCL(K,NPTCL)=PJSET(K,J) 255 CONTINUE IORIG(NPTCL)=-J IDENT(NPTCL)=JTYPE(J) IDCAY(NPTCL)=0 ENDIF 220 CONTINUE C C Sum masses and insert jet label C AMSUM=0. DO 260 IP=NBEGIN,NPTCL AMSUM=AMSUM+PPTCL(5,IP) IORIG(IP)=ISIGN(IABS(IORIG(IP))+IPACK*JET,IORIG(IP)) 260 CONTINUE C C Require sum of masses less than jet energy. C IF(AMSUM.GT.ESUM.AND.NBEGIN.NE.NPTCL.AND.NFRAG.LT.NFRGMX) THEN NPTCL=NBEGIN-1 GO TO 201 ENDIF C C For WPAIR events rescale jet to W mass. C IF((KEYS(6).OR.KEYS(7).OR.KEYS(9).OR.KEYS(10)).AND.JET.LT.10) $ THEN IF(IABS(JTYPE(JET+N0JETS-1)).LT.80) RETURN IF(AMSUM.GE.PJSET(5,JET+N0JETS-1)) THEN IF(NFRAG.GT.NFRGMX) RETURN NPTCL=NBEGIN-1 GO TO 201 ENDIF PSUM(4)=PJSET(5,JET+N0JETS-1) PSUM(5)=PSUM(4) NPLV1=NPTCL CALL RESCAL(NBEGIN,NPLV1,PSUM,IFAIL) ENDIF C 210 RETURN C C Error C 9999 CALL PRTEVT(0) WRITE(ITLIS,9998) NPTCL 9998 FORMAT(//' ERROR IN FRGJET ... NPTCL > ',I6) RETURN END +EOD +DECK,FRGMNT SUBROUTINE FRGMNT C C Control jet fragmentation. Boost to frames defined in C EVOLVE and call JETGEN. C C EVOLVE initializes /PJSET/ as follows-- C 1 - 2 = PINITS (except for E+E-) C N0W - N0W = QWJET (for DRELLYAN, NJET=3) C N0JETS - N0JETS+NJET = PJETS C N0PAIR - N0PAIR+NPAIR = PPAIR (for WPAIR) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,PINITS +CDE,PARTCL +CDE,CONST +CDE,JETSET +CDE,JWORK +CDE,KEYS +CDE,Q1Q2 +CDE,FRAME C REAL PSUM(5),PALLJ(5),P12(5),PIN(5,2),PWREST(5),PADD(5) REAL POLD(5),PNEW(5) REAL PINPL,PINMN,BP,PT2AVE,PTADD,RANF,PHIADD,PALLPL,PALLMN REAL PALLX,PALLY INTEGER K,J,JJET,NZERO,IB,NPTCL1,NPTCL2,IFAIL,JET,NPJET1,NPLV1 INTEGER NPJET3,IP,NP1,NP2,NFIRST,IP1,IFR,NLJ DOUBLE PRECISION DSUM(5),DPASS(5) C C Initialize DO 100 K=1,5 100 DSUM(K)=0. NLJ=NJET IF(KEYS(3)) NLJ=NJET+1 DO 101 J=1,NLJ JJET=N0JETS+J-1 IF(JJET.EQ.N0W) GOTO 101 CALL DBLVEC(PJSET(1,JJET),DPASS) DO 102 K=1,4 102 DSUM(K)=DSUM(K)+DPASS(K) 101 CONTINUE DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2) DO 103 K=1,5 103 PALLJ(K)=DSUM(K) C NZERO=NPTCL+1 C C Fragment partons from initial state shower C IF(.NOT.KEYS(2)) THEN DO 110 J=1,NJSET IF(JDCAY(J).EQ.JPACK*J+J) THEN IB=JORIG(J)/JPACK-10 DO 120 K=1,5 120 PIN(K,IB)=PJSET(K,J) ENDIF 110 CONTINUE C CALL FRGJET(11) CALL FRGJET(12) C NPTCL1=NPTCL+1 NPTCL2=NPTCL1+1 IF(NPTCL1.GT.MXPTCL) GO TO 9999 PINPL=.5*(PIN(4,1)+PIN(3,1)+PIN(4,2)+PIN(3,2)) PINMN=.5*(PIN(4,1)-PIN(3,1)+PIN(4,2)-PIN(3,2)) PPTCL(1,NPTCL1)=0. PPTCL(2,NPTCL1)=0. PPTCL(3,NPTCL1)=HALFE-PINPL PPTCL(4,NPTCL1)=HALFE-PINPL PPTCL(5,NPTCL1)=0. PPTCL(1,NPTCL2)=0. PPTCL(2,NPTCL2)=0. PPTCL(3,NPTCL2)=-(HALFE-PINMN) PPTCL(4,NPTCL2)=HALFE-PINMN PPTCL(5,NPTCL2)=0. DO 130 K=1,4 130 PSUM(K)=-PALLJ(K) PSUM(4)=PSUM(4)+ECM PSUM(5)=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2 IF(PSUM(5).GE.0.) THEN PSUM(5)=SQRT(PSUM(5)) CALL RESCAL(NZERO,NPTCL2,PSUM,IFAIL) ENDIF C DO 140 K=1,4 140 PBEAMS(K)=PPTCL(K,NPTCL1)+PPTCL(K,NPTCL2) PBEAMS(5)=SQRT(PBEAMS(4)**2-PBEAMS(1)**2-PBEAMS(2)**2 $ -PBEAMS(3)**2) ENDIF C C Boost partons from final jets with -FRAME C 200 DO 210 J=1,NJSET JET=JORIG(J)/JPACK IF ( JET.EQ.0 ) THEN IFR=1 ELSE IF(JET.GT.10) GO TO 210 IF(KEYS(6)) THEN IF(IDJETS(JET).EQ.10) GO TO 210 ENDIF IFR=IFRAME(JET) ENDIF C C Do this boost in double precision for 32-bit machines CALL DBOOST(-1,FRAME(1,IFR),PJSET(1,J)) 210 CONTINUE C C Fragment partons from final jets C NPJET1=NPTCL+1 DO 220 K=1,4 220 PSUM(K)=0 C C Conserve mass of 1+2 for DRELLYAN (automatic for WPAIR) C IF(KEYS(3)) THEN CALL FRGJET(1) CALL FRGJET(2) IF(STDDY) THEN DO 230 K=1,4 PSUM(K)=PJSET(K,3)+PJSET(K,4) 230 CONTINUE ELSE DO 240 K=1,4 PSUM(K)=PJSET(K,N0W+1)+PJSET(K,N0W+2) 240 CONTINUE ENDIF PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2) NPLV1=NPTCL CALL RESCAL(NPJET1,NPLV1,PSUM,IFAIL) C EXTRADIM has only jet3 + graviton ELSEIF(KEYS(11)) THEN CALL FRGJET(3) CALL FRGJET(0) NPLV1=NPTCL DO 241 K=1,4 PSUM(K)=PJSET(K,3)+PJSET(K,4) 241 CONTINUE PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2) CALL RESCAL (NPJET1,NPLV1,PSUM,IFAIL) ELSE C All other processes DO 242 J=1,NJET JJET=N0JETS+J-1 CALL FRGJET(J) DO 243 K=1,4 243 PSUM(K)=PSUM(K)+PJSET(K,JJET) 242 CONTINUE PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2) NPLV1=NPTCL CALL RESCAL(NPJET1,NPLV1,PSUM,IFAIL) ENDIF C C Add extra jets for DRELLYAN IF(KEYS(3).AND..NOT.STDDY) THEN NPJET3=NPTCL+1 DO 245 J=3,NJET 245 CALL FRGJET(J) NPTCL1=NPTCL+1 IF(NPTCL1.GT.MXPTCL) GO TO 9999 DO 250 K=1,4 PPTCL(K,NPTCL1)=PJSET(K,N0W) 250 PSUM(K)=PJSET(K,N0W) PPTCL(5,NPTCL1)=PJSET(5,N0W) DO 246 J=3,NJET JJET=N0JETS+J-3 DO 246 K=1,4 PSUM(K)=PSUM(K)+PJSET(K,JJET) 246 CONTINUE PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2) CALL RESCAL(NPJET3,NPTCL1,PSUM,IFAIL) DO 260 K=1,5 260 PWREST(K)=PPTCL(K,NPTCL1) ENDIF C C Boost partons back to PP COM C DO 300 J=1,NJSET JET=JORIG(J)/JPACK IF ( JET.EQ.0 ) THEN IFR=1 ELSE IF(JET.GT.10) GO TO 300 IF(KEYS(6)) THEN IF(IDJETS(JET).EQ.10) GO TO 300 ENDIF IFR=IFRAME(JET) ENDIF BP=0. DO 305 K=1,3 305 BP=BP+FRAME(K,IFR)*PJSET(K,J) BP=BP/FRAME(5,IFR) DO 310 K=1,3 310 PJSET(K,J)=PJSET(K,J)+FRAME(K,IFR)*PJSET(4,J)/FRAME(5,IFR) $ +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR)) PJSET(4,J)=FRAME(4,IFR)*PJSET(4,J)/FRAME(5,IFR)+BP 300 CONTINUE C C Reset FRAME to boost hadrons to PP COM C IF(KEYS(1).OR.KEYS(2).OR.(KEYS(3).AND.NJET.EQ.2).OR.KEYS(5) $.OR.(KEYS(7).AND.NPAIR.EQ.0).OR.KEYS(8)) THEN DO 410 K=1,5 FRAME(K,1)=PALLJ(K) 410 CONTINUE ELSEIF(KEYS(3).AND.NJET.GT.2) THEN DO 420 K=1,5 420 FRAME(K,1)=PALLJ(K) BP=0. DO 430 K=1,3 430 BP=BP+FRAME(K,1)*PWREST(K) BP=BP/FRAME(5,1) DO 440 K=1,3 FRAME(K,2)=PWREST(K)+FRAME(K,1)*PWREST(4)/FRAME(5,1) $ +FRAME(K,1)*BP/(FRAME(4,1)+FRAME(5,1)) 440 CONTINUE FRAME(4,2)=FRAME(4,1)*PWREST(4)/FRAME(5,1)+BP ENDIF C C Boost hadrons back to PP COM C DO 500 IP=NZERO,NPTCL JET=IABS(IORIG(IP))/IPACK IF(JET.GT.10) GO TO 500 IF(KEYS(6)) THEN IF(IDJETS(JET).EQ.10) GO TO 500 ENDIF IF(JET.EQ.0) THEN IFR=1 ELSE IFR=IFRAME(JET) ENDIF BP=0. DO 510 K=1,3 510 BP=BP+FRAME(K,IFR)*PPTCL(K,IP) BP=BP/FRAME(5,IFR) DO 520 K=1,3 520 PPTCL(K,IP)=PPTCL(K,IP)+FRAME(K,IFR)*PPTCL(4,IP)/FRAME(5,IFR) $ +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR)) PPTCL(4,IP)=FRAME(4,IFR)*PPTCL(4,IP)/FRAME(5,IFR)+BP 500 CONTINUE C C Add intrinsic PT C IF(.NOT.KEYS(2)) THEN PT2AVE=.1*SQRT(QSQ) PTADD=SQRT(-PT2AVE*ALOG(RANF())) PHIADD=2.*PI*RANF() PADD(1)=2.*PTADD*COS(PHIADD) PADD(2)=2.*PTADD*SIN(PHIADD) C Must use large and small components carefully to calculate C mass on 32-bit machines. PALLPL=0. PALLMN=0. PALLX=0. PALLY=0. DO 525 IP=NZERO,NPTCL PALLX=PALLX+PPTCL(1,IP) PALLY=PALLY+PPTCL(2,IP) IF(PPTCL(3,IP).GT.0.) THEN PALLPL=PALLPL+(PPTCL(4,IP)+PPTCL(3,IP)) PALLMN=PALLMN+(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(5,IP)**2) $ /(PPTCL(4,IP)+PPTCL(3,IP)) ELSE PALLMN=PALLMN+(PPTCL(4,IP)-PPTCL(3,IP)) PALLPL=PALLPL+(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(5,IP)**2) $ /(PPTCL(4,IP)-PPTCL(3,IP)) ENDIF 525 CONTINUE POLD(1)=PALLX POLD(2)=PALLY POLD(3)=.5*(PALLPL-PALLMN) POLD(4)=.5*(PALLPL+PALLMN) POLD(5)=SQRT(PALLPL*PALLMN-PALLX**2-PALLY**2) PNEW(1)=PADD(1)+POLD(1) PNEW(2)=PADD(2)+POLD(2) PNEW(3)=POLD(3) PNEW(4)=SQRT(PNEW(1)**2+PNEW(2)**2+PNEW(3)**2+POLD(5)**2) PNEW(5)=POLD(5) C DO 530 IP=NZERO,NPTCL BP=0. DO 531 K=1,3 531 BP=BP+POLD(K)*PPTCL(K,IP) BP=BP/POLD(5) DO 532 K=1,3 532 PPTCL(K,IP)=PPTCL(K,IP)-POLD(K)*PPTCL(4,IP)/POLD(5) $ +POLD(K)*BP/(POLD(4)+POLD(5)) PPTCL(4,IP)=PPTCL(4,IP)*POLD(4)/POLD(5)-BP C BP=0. DO 533 K=1,3 533 BP=BP+PNEW(K)*PPTCL(K,IP) BP=BP/PNEW(5) DO 534 K=1,3 534 PPTCL(K,IP)=PPTCL(K,IP)+PNEW(K)*PPTCL(4,IP)/PNEW(5) $ +PNEW(K)*BP/(PNEW(4)+PNEW(5)) PPTCL(4,IP)=PPTCL(4,IP)*PNEW(4)/PNEW(5)+BP 530 CONTINUE C C Add opposite PT to beam jets DO 541 K=1,4 541 PBEAMS(K)=-PNEW(K) PBEAMS(4)=PBEAMS(4)+ECM PBEAMS(5)=PBEAMS(4)**2-PBEAMS(1)**2-PBEAMS(2)**2 -PBEAMS(3)**2 IF ( PBEAMS(5).GT.0 ) THEN PBEAMS(5)=SQRT(PBEAMS(5)) ELSE PBEAMS(4)=SQRT(PBEAMS(4)**2-PBEAMS(5)+4.) PBEAMS(5)=2. ENDIF ENDIF C C Decay hadrons C NP1=NZERO 600 NP2=NPTCL DO 610 IP=NP1,NP2 NFIRST=NPTCL+1 JET=IABS(IORIG(IP))/IPACK CALL DECAY(IP) DO 620 IP1=NFIRST,NPTCL 620 IORIG(IP1)=ISIGN(IABS(IORIG(IP1))+IPACK*JET,IORIG(IP1)) 610 CONTINUE NP1=NP2+1 IF(NP1.LE.NPTCL) GO TO 600 RETURN C C Error C 9999 CALL PRTEVT(0) WRITE(ITLIS,9998) NPTCL 9998 FORMAT(//' ERROR IN FRGMNT ... NPTCL > ',I6) RETURN END +EOD +DECK,GAMMA. FUNCTION GAMMA(X) +CDE,ITAPES DIMENSION C(13) DATA C 1/ 0.00053 96989 58808, 0.00261 93072 82746, 0.02044 96308 23590, 2 0.07309 48364 14370, 0.27964 36915 78538, 0.55338 76923 85769, 3 0.99999 99999 99998,-0.00083 27247 08684, 0.00469 86580 79622, 4 0.02252 38347 47260,-0.17044 79328 74746,-0.05681 03350 86194, 5 1.13060 33572 86556/ Z=X IF(X .GT. 0.0) GO TO 1 IF(X .EQ. AINT(X)) GO TO 5 Z=1.0-Z 1 F=1.0/Z IF(Z .LE. 1.0) GO TO 4 F=1.0 2 IF(Z .LT. 2.0) GO TO 3 Z=Z-1.0 F=F*Z GO TO 2 3 Z=Z-1.0 4 GAMMA= 1 F*((((((C(1)*Z+C(2))*Z+C(3))*Z+C(4))*Z+C(5))*Z+C(6))*Z+C(7))/ 2 ((((((C(8)*Z+C(9))*Z+C(10))*Z+C(11))*Z+C(12))*Z+C(13))*Z+1.0) IF(X .GT. 0.0) RETURN GAMMA=3.141592653589793/(SIN(3.141592653589793*X)*GAMMA) RETURN 5 GAMMA=0. WRITE(ITLIS,10) X RETURN 10 FORMAT(1X,'GAMMA ... ARGUMENT IS NON-POSITIVE INTEGER = ',E20.5) END +EOD +DECK,GETPT. SUBROUTINE GETPT(PT0,PTMEAN) C GENERATE PT WITH 1/(1+B*PT**2)**4 DISTRIBUTION C (APPROXIMATELY AN EXPONENTIAL FOR PT < 2 GEV.) C CON1=16/(3*PI) C CON2=-1/3 +CDE,ITAPES DATA CON1/1.697652726/,CON2/-.3333333333/ R=RANF() ARG=AMAX1(R**CON2-1.,0.) PT0=PTMEAN*CON1*SQRT(ARG) RETURN END +EOD +DECK,GETTOT. SUBROUTINE GETTOT(PRFLAG) C C Calculate total cross section within jet limits. C If PRFLAG=.TRUE. print summary. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,FINAL +CDE,TIMES +CDE,TOTALS +CDE,KEYS +CDE,Q1Q2 +CDE,CONST +CDE,JETLIM +CDE,DYLIM +CDE,TYPES +CDE,IDRUN +CDE,SEED +CDE,PRIMAR +CDE,ISLOOP +CDE,MGSIGS C REAL DELPHI,SIGF2,FRAC,TMEAN,ALUM2,SIGF3 LOGICAL PRFLAG INTEGER I,II,KK REAL TMP LOGICAL MGFLAG INTEGER L,LINT,LK1,LK2 C C Calculate jet cross sections C SIGF=0. ALUM=0. ACCEPT=0. NKINF=NKINPT C For 2-body processes we can use the totals. C For MadGraph we must sum the partial cross sections. MGFLAG=KEYS(12) IF(NKINPT.GT.0.AND..NOT.MGFLAG) THEN SIGF=SUMWT/NKINPT DELPHI=2.*PI IF(KEYS(1).OR.KEYS(2).OR.KEYS(5).OR.KEYS(6).OR.KEYS(8) $ .OR.KEYS(9)) THEN DELPHI=PHIMAX(1)-PHIMIN(1) ELSEIF(KEYS(3).AND..NOT.STDDY) THEN DELPHI=PHWMAX-PHWMIN ENDIF SIGF=SIGF*DELPHI/(2.*PI) ELSEIF(MGFLAG) THEN DO 10 I=1,NSIG8 SIGF=SIGF+WTSUM8(I)/NWT8(I) 10 CONTINUE ENDIF C C Print summary if desired C IF(.NOT.PRFLAG) RETURN C C Print header and title WRITE(ITLIS,100) 100 FORMAT('1',30('*')/' *',28X,'*'/ 1' *',5X,'ISAJET RUN SUMMARY',5X,'*'/ 2' *',28X,'*'/1X,30('*')//) WRITE(ITLIS,101) TITLE 101 FORMAT(//11X,10A8) IF(NKINPT.EQ.0) GO TO 300 C C Print cross section WRITE(ITLIS,102) NKINPT 102 FORMAT(//' NO. KINEMATIC POINTS GENERATED =',I13) SIGF2=SIGF*NEVOLV*NFRGMN WRITE(ITLIS,103) SIGF2 103 FORMAT(//' MONTE CARLO JET CROSS SECTION =',E13.4,' MB') IF(SIGF.EQ.0.) WRITE(ITLIS,111) 111 FORMAT(' CROSS SECTION IS ZERO IF VARIABLES ARE FIXED') C C Print W decay acceptance IF(KEYS(3)) THEN ACCEPT=FLOAT(NKEEP)/FLOAT(NWGEN) WRITE(ITLIS,105) ACCEPT 105 FORMAT(//' ACCEPTANCE FOR W DECAYS =',E13.4) ELSEIF(KEYS(7)) THEN ACCEPT=FLOAT(NKEEP)/FLOAT(NWGEN) WRITE(ITLIS,106) ACCEPT 106 FORMAT(//' ACCEPTANCE FOR H DECAYS =',E13.4) ENDIF C C Print luminosity IF(SIGF.GT.0.) THEN ALUM=NEVENT/SIGF IF(KEYS(4)) ALUM=NKINPT/SIGF WRITE(ITLIS,104) ALUM 104 FORMAT(//' EQUIVALENT INTEGRAL LUMINOSITY =',E13.4, $ ' /MB') ENDIF C C Print final multijet cross sections IF(KEYS(12)) THEN WRITE(ITLIS,9001) 9001 FORMAT(//6X,'FINAL MULTIJET CROSS SECTIONS'/ $ 6X,'PROCESS',18X,'SIGMA',10X,'MAX(SIGMA)') DO 992 I=1,NSIG8 II=ISORT8(I) TMP=WTSUM8(II)/NWT8(II) WRITE(ITLIS,9002) (IDENT8(KK,II),KK=1,5),TMP,WTMAX8(II) 9002 FORMAT(2X,5I5,2E15.5) 992 CONTINUE WRITE(ITLIS,*) ENDIF C C Print statistics for multiple evolution and fragmentation IF(NEVOLV.GT.1.OR.NFRGMN.GT.1) THEN FRAC=FLOAT(IEVGEN)/FLOAT(IEVT) WRITE(ITLIS,201) IEVGEN 201 FORMAT(//' NUMBER OF ACCEPTED EVENTS =',I13) WRITE(ITLIS,202) FRAC 202 FORMAT(' FRACTION OF ACCEPTED EVENTS =',E13.4) SIGF3=SIGF2*FRAC WRITE(ITLIS,203) SIGF3 203 FORMAT(' CROSS SECTION FOR ACCEPTED EVENTS =',E13.4) ENDIF C C Print mean time per event 300 TMEAN=(TIME2-TIME1)/NEVENT WRITE(ITLIS,301) TMEAN 301 FORMAT(//' MEAN TIME PER GENERATED EVENT =',E13.4, $' SEC') C C Print final seed(s) +SELF,IF=NORANLUX CALL RANFMT WRITE(ITLIS,302) XSEED 302 FORMAT(//' FINAL RANDOM NUMBER SEED =',A24) +SELF,IF=RANLUX CALL RLUXAT(L,LINT,LK1,LK2) WRITE(ITLIS,302) LINT,LK1,LK2 302 FORMAT(//' FINAL RANLUX SEEDS =',3I12) +SELF C C Print run identifier WRITE(ITLIS,303) IDG 303 FORMAT(//' END OF ISAJET RUN =',2I9.6) RETURN END +EOD +DECK,HEAVYX. SUBROUTINE HEAVYX(X,EPS) C C GENERATE X FOR HEAVY PARTICLE FRAGMENTATION ACCORDING TO C THE PETERSON FORM C D(X)=1/(X*(1-1/X-EPS/(1-X))**2) C =D0(X)*D1(X)*D2(X) C D0(X)=(1-X)**2/((1-X)**2+EPS)**2 C D1(X)=X C D2(X)=(((1-X)**2+EPS)/((1-X)**2+EPS*X))**2 C USING X=1-Y**POW C DATA ALN4/1.3863/ C C CHOOSE POW FOR X=1-Y**POW. C GENERATE FLAT IN X IF EPS>1. IF(EPS.LT.1.) THEN POW=ALOG((3.+EPS)/EPS)/ALN4 YMX=(EPS*(3.*POW-1.)/(POW+1.))**(.5/POW) ZMX=1-YMX**POW D0MX=(1-ZMX)**2/((1.-ZMX)**2+EPS)**2*POW*YMX**(POW-1.) D2MX=2./(2.-SQRT(EPS)) ELSE POW=1. ZMX=0. D0MX=(1.-ZMX)**2/((1.-ZMX)**2+EPS)**2 D2MX=1.+EPS ENDIF C C GENERATE Z ACCORDING TO (1-Z)**2/((1-Z)**2+EPS*Z)**2 1 CONTINUE Y=RANF() Z=1.-Y**POW C D0Z=(1.-Z)**2/((1.-Z)**2+EPS)**2*POW*Y**(POW-1.) IF(D0Z.LT.RANF()*D0MX) GO TO 1 C C CHECK REMAINING FACTORS D1=Z D2=(((1.-Z)**2+EPS)/((1.-Z)**2+EPS*Z))**2 IF(D1*D2.LT.RANF()*D2MX) GO TO 1 C C GOOD X X=Z RETURN END +EOD +DECK,HEVOLV. SUBROUTINE HEVOLV C C CARRY OUT BACKWARDS EVOLUTION QK --> QK + W FOR LONGITUDINAL C W-W FUSION, GENERATING Z AND KT**2 FROM RELATION OF W AND C QUARK STRUCTURE FUNCTIONS. C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PJETS +CDE,JETSET +CDE,PRIMAR +CDE,WCON +CDE,CONST +CDE,IDRUN +CDE,HCON C DIMENSION X(2) EQUIVALENCE (X1,X(1)) DIMENSION FZIQ(13),IWPICK(2),PFINAL(5),BST1(5),BST2(5),B2B1(5) DIMENSION PSAVE(5,2) C LAMBDA FUNCTION ALAMF(A,B,C)=SQRT((A-B-C)**2-4.*B*C) C NJSAVE=NJSET NREJ2=-1 C C INITIALIZE DO 10 I=1,2 DO 10 K=1,5 10 PSAVE(K,I)=PJSET(K,I) 20 CONTINUE DO 30 I=1,2 DO 30 K=1,5 30 PJSET(K,I)=PSAVE(K,I) DO 40 K=1,5 40 PFINAL(K)=QWJET(K) NJSET=NJSAVE C C CHOOSE A W AND DO BACKWARDS EVOLUTION FOR QK -> QK + W. C IF(RANF().LT..5) THEN IWPICK(1)=1 IWPICK(2)=2 SGN=+1. ELSE IWPICK(1)=2 IWPICK(2)=1 SGN=-1. ENDIF DO 100 JJ=1,2 C C OTHER PARTICLE IS W FOR JJ=1, QUARK FOR JJ=2: IF(JJ.EQ.1) THEN J1=IWPICK(1) J2=IWPICK(2) ELSE J1=IWPICK(2) J2=NJSAVE+1 SGN=-SGN ENDIF JTLV1=JTYPE(J1) IF(JTLV1.EQ.10) THEN IW=1 ELSEIF(JTLV1.EQ.80) THEN IW=2 ELSEIF(JTLV1.EQ.-80) THEN IW=3 ELSEIF(JTLV1.EQ.90) THEN IW=4 ENDIF XV=(PJSET(4,J1)+ABS(PJSET(3,J1)))/ECM AMV=AMASS(JTLV1) C C GENERATE VARIABLES FOR BRANCHING C FIND MAXIMUM OF INTEGRAND USING 20 POINTS IN LOG(Z) FMAX=0. ZMULT=(1./XV)**.05 ZIZ=XV DO 110 IZ=1,19 ZIZ=ZIZ*ZMULT FSUM=0. DO 115 IQ=2,13 IF(MATCH(IQ,IW).NE.0) THEN IFL=IQ/2 CIQ=AQ(IFL,IW)**2+BQ(IFL,IW)**2 FSUM=FSUM+CIQ*(1.-ZIZ)/ZIZ*STRUC(XV/ZIZ,AMV**2,IQ,IDIN(J1)) ENDIF 115 CONTINUE FMAX=AMAX1(FMAX,FSUM) 110 CONTINUE C GENERATE Z UNIFORMLY IN (XV,1) AND TEST NREJ1=-1 120 ZV=XV+(1.-XV)*RANF() FZ=0. DO 130 IQ=2,13 IF(MATCH(IQ,IW).NE.0) THEN IFL=IQ/2 CIQ=AQ(IFL,IW)**2+BQ(IFL,IW)**2 FZIQ(IQ)=CIQ*(1.-ZV)/ZV*STRUC(XV/ZV,AMV**2,IQ,IDIN(J1)) ELSE FZIQ(IQ)=0. ENDIF 130 FZ=FZ+FZIQ(IQ) IF(FZ.LT.FMAX*RANF()) THEN NREJ1=NREJ1+1 IF(NREJ1.GT.NTRIES) GO TO 9999 GO TO 120 ENDIF C DETERMINE QUARK TYPE TRY=RANF() SUM=0. DO 140 IQ=2,13 IQ1=IQ SUM=SUM+FZIQ(IQ)/FZ 140 IF(SUM.GT.TRY) GO TO 150 150 IQ3=MATCH(IQ1,IW) IQ3=MATCH(IQ3,4) C GENERATE T=-K**2 AND UNIFORM PHI T=AMV**2*(1./RANF()-1.) PHIK=2.*PI*RANF() C C SOLVE KINEMATICS FOR THIS SIDE S=(PJSET(4,J1)+PJSET(4,J2))**2-(PJSET(1,J1)+PJSET(1,J2))**2 $-(PJSET(2,J1)+PJSET(2,J2))**2-(PJSET(3,J1)+PJSET(3,J2))**2 SP=S/ZV IFL1=IQ1/2 IFL2=JTYPE(J2) IFL3=IQ3/2 AM1=AMASS(IFL1) AM2=PJSET(5,J2) AM3=AMASS(IFL3) AM1SQ=AM1**2 AM2SQ=AM2**2 AM3SQ=AM3**2 IF(SGN.LT.0.) THEN P2PL=PJSET(4,J2)+PJSET(3,J2) P2MN=AM2SQ/P2PL ELSE P2MN=PJSET(4,J2)-PJSET(3,J2) P2PL=AM2SQ/P2MN ENDIF C STEP 1: SOLVE FOR PP1=PJSET(K,NEWV) IF(SGN.GT.0.) THEN PP1PL=(SP-AM1SQ-AM2SQ+ALAMF(SP,AM1SQ,AM2SQ))/(2.*P2MN) PP1MN=AM1SQ/PP1PL ELSE PP1MN=(SP-AM1SQ-AM2SQ+ALAMF(SP,AM1SQ,AM2SQ))/(2.*P2PL) PP1PL=AM1SQ/PP1MN ENDIF C STEP 2: SOLVE FOR K = VIRTUAL W MOMENTUM DEN=PP1PL*P2MN-PP1MN*P2PL AKPL=(+PP1PL*(S+T-AM2SQ)+P2PL*(T+AM3SQ-AM1SQ))/DEN AKMN=(-PP1MN*(S+T-AM2SQ)-P2MN*(T+AM3SQ-AM1SQ))/DEN WPL=PP1PL-AKPL WMN=PP1MN-AKMN AKT2=T+AKPL*AKMN C STEP 3: START OVER IF AKT2 UNPHYSICAL IF(AKT2.LE.0..OR.PP1PL.GE.ECM.OR.PP1MN.GE.ECM.OR. $P2PL.GE.ECM.OR.P2MN.GE.ECM) THEN NREJ2=NREJ2+1 IF(NREJ2.GT.NTRIES) GO TO 9999 GO TO 20 ENDIF C C SAVE NEW VECTORS NJ1=NJSET+1 NJ2=NJSET+2 AKT=SQRT(AKT2) AKX=AKT*COS(PHIK) AKY=AKT*SIN(PHIK) PJSET(1,J1)=AKX PJSET(2,J1)=AKY PJSET(3,J1)=.5*(AKPL-AKMN) PJSET(4,J1)=.5*(AKPL+AKMN) PJSET(5,J1)=-SQRT(T) JDCAY(J1)=JPACK*NJ1+NJ2 JET=IABS(JORIG(J1))/JPACK C PJSET(1,NJ1)=0. PJSET(2,NJ1)=0. PJSET(3,NJ1)=.5*(PP1PL-PP1MN) PJSET(4,NJ1)=.5*(PP1PL+PP1MN) PJSET(5,NJ1)=AM1 JORIG(NJ1)=JPACK*JET+J1 JTYPE(NJ1)=IFL1 JDCAY(NJ1)=0 C PJSET(1,NJ2)=-AKX PJSET(2,NJ2)=-AKY PJSET(3,NJ2)=.5*(WPL-WMN) PJSET(4,NJ2)=.5*(WPL+WMN) PJSET(5,NJ2)=AM3 JORIG(NJ2)=JPACK*JET+J1 JTYPE(NJ2)=IFL3 JDCAY(NJ2)=0 C C BOOST OTHER VECTORS TO NEW FRAME GIVEN BY DIFFERENCE OF C OLD AND NEW FINAL MOMENTA. DO 200 K=1,4 BST1(K)=PFINAL(K) 200 BST2(K)=PJSET(K,J1)+PJSET(K,J2) BMASS=PFINAL(5) BST1(5)=BMASS BST2(5)=BMASS C C PARAMETERS FOR COMBINED BOOSTS. BDOTB=BST1(4)*BST2(4)-BST1(1)*BST2(1)-BST1(2)*BST2(2) $-BST1(3)*BST2(3) DO 210 K=1,4 210 B2B1(K)=BST2(K)-BST1(K) C B44=BDOTB/BMASS**2 BI41=1./BMASS BI42=(BDOTB-BMASS**2-B2B1(4)*BMASS)/(BMASS**2*(BST2(4)+BMASS)) B4K1=BI41 B4K2=(BMASS**2-BDOTB-B2B1(4)*BMASS)/(BMASS**2*(BST1(4)+BMASS)) BIK1=-1./(BMASS*(BST1(4)+BMASS)) BIK2=1./(BMASS*(BST2(4)+BMASS)) BIK3=(BMASS**2-BDOTB)/(BMASS**2*(BST1(4)+BMASS) $*(BST2(4)+BMASS)) C C BOOST FINAL JETS DO 220 J=1,NJSET IF(J.EQ.J1.OR.J.EQ.J2) GO TO 220 IF(PJSET(5,J).LT.0.) GO TO 220 BP1=0. BP21=0. DO 221 K=1,3 BP1=BP1+BST1(K)*PJSET(K,J) 221 BP21=BP21+B2B1(K)*PJSET(K,J) DO 222 K=1,3 222 PJSET(K,J)=PJSET(K,J) $+(B2B1(K)*BI41+BST2(K)*BI42)*PJSET(4,J) $+B2B1(K)*BP1*BIK1+BST2(K)*BP21*BIK2+BST2(K)*BP1*BIK3 PJSET(4,J)=B44*PJSET(4,J)+BP21*B4K1+BP1*B4K2 220 CONTINUE C C RESET VIRTUAL MOMENTA DO 230 J=1,NJSET IF(J.EQ.J1.OR.J.EQ.J2) GO TO 230 IF(PJSET(5,J).GE.0.) GO TO 230 JX1=JDCAY(J)/JPACK JX2=JDCAY(J)-JPACK*JX1 DO 231 K=1,4 231 PJSET(K,J)=PJSET(K,JX1)-PJSET(K,JX2) AMJ=PJSET(4,J)**2-PJSET(1,J)**2-PJSET(2,J)**2-PJSET(3,J)**2 PJSET(5,J)=-SQRT(ABS(AMJ)) 230 CONTINUE C C RESET PFINAL AND NJSET DO 240 K=1,4 240 PFINAL(K)=PJSET(K,J2)+PJSET(K,NJ1) PFINAL(5)=SQRT(SP) NJSET=NJSET+2 100 CONTINUE RETURN C 9999 CONTINUE WRITE(ITLIS,9998) IEVT 9998 FORMAT(/' ***** ERROR IN HEVOLV ... EVENT',I8,' DISCARDED *****') NJSET=-1 RETURN END +EOD +DECK,HIGGS. SUBROUTINE HIGGS C C FINISH HIGGS GENERATION STARTED BY DRLLYN FOR DECAY C HIGGS --> W W. C C VER 7.14: TEST BOTH JET1 AND JET2 FOR W,Z FOR SAFETY C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PJETS +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,HCON C DIMENSION X(2) EQUIVALENCE (X(1),X1) C IDABS1=IABS(IDJETS(1)) IDABS2=IABS(IDJETS(2)) IF(IDABS1.NE.80.AND.IDABS1.NE.90.AND. $IDABS2.NE.80.AND.IDABS2.NE.90) THEN NPAIR=0 DO 100 I=1,4 IDPAIR(I)=0 JPAIR(I)=0 DO 110 K=1,5 110 PPAIR(K,I)=0. 100 CONTINUE ELSE CALL WPAIR ENDIF RETURN END +EOD +DECK,IDANTI INTEGER FUNCTION IDANTI(ID) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Return value of antiparticle id C- C- Inputs : C- ID = particle id C- C- Created 1-JUN-1988 Serban D. Protopopescu C- 3-Jan-1993: Expand self-conjugate list for MSSM and simplify C structure. FEP C 17-Mar-1997: Correctly handle mesons with IDENT>10000 C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. INTEGER ID,IFL1,IFL2,IFL3,IDABS INTEGER NSELF,I PARAMETER (NSELF=14) INTEGER IDSELF(NSELF) SAVE IDSELF DATA IDSELF/9,10,20,29,30,40,50,60,81,82,83,84,90,91/ C---------------------------------------------------------------------- IDABS=IABS(ID) IFL1=MOD(IDABS/1000,10) C C Baryons and diquarks C IF(IFL1.NE.0) THEN IDANTI=-ID RETURN ENDIF C C Mesons C IF(IDABS.GT.100.AND.IFL1.EQ.0) THEN IFL2=MOD(IDABS/100,10) IFL3=MOD(IDABS/10,10) IF(IFL2.EQ.IFL3) THEN IDANTI=+ID ELSE IDANTI=-ID ENDIF RETURN ENDIF C C Other particles C DO 100 I=1,NSELF IF(IDABS.EQ.IDSELF(I)) THEN IDANTI=+ID RETURN ENDIF 100 CONTINUE IDANTI=-ID RETURN END +EOD +DECK,IDGEN. SUBROUTINE IDGEN C C Call system date and time routines (non-standard) to set up C run identification: C IDVER=100*VERSN (integer ISAJET version number) C IDG(1)=YYMMDD (integer year-month-day) C IDG(2)=HHMMSS (integer hour-minute-second) C +CDE,ITAPES +CDE,IDRUN +SELF,IF=CDC,ETA. CHARACTER*10 CHAR,DATE,TIME +SELF,IF=SUN,SGI. DIMENSION ISUN(3) +SELF. C Default run id is zero. IYMD=0. IHMS=0. +SELF,IF=CDC,IF=NOCERN. C Call CDC date and time and convert to integer. CHAR=DATE() READ(CHAR,'(1X,I2,1X,I2,1X,I2,1X)') IA,IB,IC IYMD=10000*IC+100*IA+IB CHAR=TIME() READ(CHAR,'(1X,I2,1X,I2,1X,I2,1X)') IA,IB,IC IHMS=10000*IA+100*IB+IC +SELF,IF=ETA,IF=NOCERN. C Call ETA date and time and convert to integer. CHAR=DATE() READ(CHAR,'(I2,1X,I2,1X,I2)') IA,IB,IC IYMD=10000*IC+100*IA+IB CHAR=TIME() READ(CHAR,'(I2,1X,I2,1X,I2)') IA,IB,IC IHMS=10000*IA+100*IB+IC +SELF,IF=SGI,IF=NOCERN. C Call Silicon Graphics date and time CALL IDATE(ISUN(1),ISUN(2),ISUN(3)) IYMD=10000*ISUN(3)+100*ISUN(2)+ISUN(1) CALL ITIME(ISUN) IHMS=10000*ISUN(1)+100*ISUN(2)+ISUN(3) +SELF,IF=SUN,IF=NOCERN. C Call SUN date and time CALL IDATE(ISUN) IYMD=10000*(MOD(ISUN(3),100))+100*ISUN(2)+ISUN(1) CALL ITIME(ISUN) IHMS=10000*ISUN(1)+100*ISUN(2)+ISUN(3) +SELF,IF=IBM,VAX,CERN. C Call DATIME for date and time. (In Cern library) CALL DATIME(IYMD,IHMS) +SELF. IDG(1)=IYMD IDG(2)=IHMS RETURN END +EOD +DECK,IFRAMS SUBROUTINE IFRAMS(N1,N2,IFR,PAIR) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Initialize a center of mass frame for partons N1 to N2 C- partons must be consecutive unless PAIR is true C- C- Inputs : C- N1 = first parton C- N2 = last parton C- IFR = index of frame C- PAIR= if false N1, N2 denote a range C- if true N1 and N2 form a pair C- C- Created 14-AUG-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PJETS +CDE,JETSET +CDE,JWORK +CDE,FRAME INTEGER I,J,K,JADD,N1,N2,IFR DOUBLE PRECISION DPASS(5),DSUM(5) LOGICAL PAIR C---------------------------------------------------------------------- C IF ( N2-N1.EQ.1.OR.PAIR ) THEN JMATCH(N1)=N2 JMATCH(N2)=N1 JADD=N2-N1 ELSE JADD=1 DO 201 I=N1,N2 JMATCH(I)=JPACK*N1+N2 201 CONTINUE ENDIF C Need double precision boosts CALL DBLVEC(PJSET(1,N1),DSUM) DO 211 I=N1+JADD,N2 CALL DBLVEC(PJSET(1,I),DPASS) DO 210 K=1,4 210 DSUM(K)=DSUM(K)+DPASS(K) DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2) 211 CONTINUE DO 212 K=1,5 FRAME(K,IFR)=DSUM(K) 212 CONTINUE C C Set up and generate final state QCD parton shower. C Boost PJSET with -FRAME. C DO 240 J=N1,N2,JADD CALL DBOOST(-1,FRAME(1,IFR),PJSET(1,J)) 240 CONTINUE C 999 RETURN END +EOD +DECK,INISAP SUBROUTINE INISAP(CMSE,XREAC,BEAMS,WZ,NDCAYS,DCAYS, $ ETMIN,RCONE,OK) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- initialize ISAJET for externally supplied partons C- Inputs : C- CMSE = center of mass energy C- XREAC = reaction C- BEAMS(2) = chose 'P ' or 'AP' C- ETMIN = minimum ET of supplied partons C- RCONE = minimum cone (R) between supplied partons C- WZ = option 'W' or 'Z', ' ' no W's or Z's C- NDCAYS= number of decay options C- DCAYS= list of particles W or Z are allowed to decay into C- C- Controls: C- OK = true if initialization is possible C- Created 8-OCT-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,KEYS +CDE,IDRUN +CDE,LIMEVL +CDE,PRIMAR +CDE,Q1Q2 +CDE,TYPES C REAL CMSE CHARACTER*8 XREAC CHARACTER*2 BEAMS(2) REAL ETMIN,RCONE CHARACTER*1 WZ INTEGER NDCAYS CHARACTER*4 DCAYS(*) LOGICAL OK LOGICAL DUMY,SETTYP INTEGER I C---------------------------------------------------------------------- OK=.TRUE. CALL RESET IEVT=0 ECM=CMSE SCM=ECM**2 HALFE=ECM/2. ETTHRS=ETMIN C fudge factor 1.5 to approximate ET distributions and widths CONCUT=SIN(RCONE)/1.5 IF(RCONE.GT.1.5) CONCUT=1.0 USELIM=.TRUE. IKEYS=0 DO 18 I=1,8 18 KEYS(I)=.FALSE. KEYON=.FALSE. REAC=XREAC C IF(XREAC.EQ.'TWOJET ') THEN KEYS(1)=.TRUE. IKEYS=1 C ELSEIF(XREAC.EQ.'DRELLYAN') THEN KEYS(3)=.TRUE. IKEYS=3 IF(WZ.EQ.'Z') GODY(4)=.TRUE. IF(WZ.EQ.'W') THEN GODY(2)=.TRUE. GODY(3)=.TRUE. ENDIF NJTTYP(1)=NDCAYS NJTTYP(2)=0 NJTTYP(3)=0 DO 21 I=1,NDCAYS JETYP(I,1)=DCAYS(I) 21 CONTINUE C ELSEIF(XREAC.EQ.'MINBIAS ') THEN KEYS(4)=.TRUE. IKEYS=4 C ELSEIF(XREAC.EQ.'SUPERSYM'.OR.XREAC.EQ.'SUSY ') THEN KEYS(5)=.TRUE. IKEYS=5 C ELSEIF(XREAC.EQ.'WPAIR ') THEN KEYS(6)=.TRUE. IKEYS=6 C ELSEIF(XREAC.EQ.'HIGGS ') THEN KEYS(7)=.TRUE. IKEYS=7 C ELSEIF(XREAC.EQ.'PHOTON ') THEN KEYS(8)=.TRUE. IKEYS=8 ENDIF C IF(IKEYS.EQ.0) THEN OK=.FALSE. GOTO 999 ENDIF C CALL SETCON IDIN(1)=1120 IDIN(2)=-1120 IF (BEAMS(1).EQ.'P ') IDIN(1)=1120 IF (BEAMS(2).EQ.'P ') IDIN(2)=1120 IF (BEAMS(1).EQ.'AP') IDIN(1)=-1120 IF (BEAMS(2).EQ.'AP') IDIN(2)=-1120 DUMY=SETTYP(0) CALL SETW CALL IDGEN CALL SETDKY(.FALSE.) CALL MBSET CALL PRTLIM CALL TIMER(1) 999 RETURN END +EOD +DECK,IPARTNS SUBROUTINE IPARTNS(NPRTNS,IDS,PRTNS,IDQ,WEIGHT,WZDK) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- fill PJETS array from a list of input partons C- Inputs : C- NPRTNS = number of partons C- IDS(NPRTNS) = parton ids C- PRTNS(4,NPRTNS) = parton 4 vectors C- IDQ(2) = initial partons C- WEIGHT = weight C- WZDK = if true last 2 partons are from W,Z decay C- C- C- Created 8-OCT-1991 Serban D. Protopopescu C- Updated 17-APR-1996 Serban D. Protopopescu C- added entry evcuts to supply evolution limits C- modified DrellYan (keys(3)) to stay within VECBOS jet ranking C- Updated 16-JUN-1998 F. Paige C- Removed ISAZEB dependence: use ISPJET and do not call ISPETA C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF INTEGER NPRTNS,IDS(NPRTNS),IDQ(2) REAL PRTNS(4,NPRTNS),WEIGHT LOGICAL WZDK +CDE,FINAL +CDE,IDRUN +CDE,JETPAR +CDE,KEYS +CDE,NODCAY +CDE,PARTCL +CDE,PJETS +CDE,PRIMAR +CDE,Q1Q2 +CDE,TOTALS REAL SUM(4),AMASS INTEGER K,J,IWZ,ID,NQS INTEGER MAXQ PARAMETER (MAXQ=15) INTEGER I,NP,JDORD(MAXQ),JIORD(MAXQ),NPJ REAL ETAQ(MAXQ),PHIQ(MAXQ),THQ(MAXQ),PTQ(MAXQ) REAL ETCUT,ETIN,RCUT,RIN,R REAL PPI REAL PXPT(MAXQ),PXETA(MAXQ),PXPHI(MAXQ) LOGICAL DOEVOL,DOEVIN DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN PARAMETER (PI= 3.1415 92653 58979 32384 6 D0) PARAMETER (TWOPI= 6.2831 85307 17958 64769 3 D0) PARAMETER (HALFPI= 1.5707 96326 79489 66192 3 D0) PARAMETER (RADIAN= 0.0174532 92519 94329 5769237 D0) C---------------------------------------------------------------------- C NJET=0 C C handle W's and Z's C IEVT=IEVT+1 IWZ=0 NQS=NPRTNS IF(WZDK) NQS=NPRTNS-2 DO 1 J=1,NPRTNS ID=IABS(IDS(J)) IF(ID.GT.79) THEN IF(ID.EQ.90) JWTYP=4 IF(IDS(J).EQ.80) JWTYP=2 IF(IDS(J).EQ.-80) JWTYP=3 IDENTW=IDS(J) DO 2 K=1,4 QWJET(K)=PRTNS(K,J) 2 CONTINUE QWJET(5)=SQRT(QWJET(4)**2-QWJET(1)**2-QWJET(2)**2-QWJET(3)**2) IWZ=J ENDIF 1 CONTINUE DO 4 J=NQS+1,NPRTNS ID=IABS(IDS(J)) NJET=NJET+1 DO 3 K=1,4 PJETS(K,NJET)=PRTNS(K,J) 3 CONTINUE IDJETS(NJET)=IDS(J) PJETS(5,NJET)=AMASS(ID) 4 CONTINUE C W,Z decays were not in input IF(IWZ.NE.0.AND.NJET.EQ.0) THEN NJET=2 CALL ISWDKY ENDIF C C fill with the other partons C DO 5 K=1,4 SUM(K)=0 5 CONTINUE DO 11 J=1,NQS ID=IABS(IDS(J)) IF(IWZ.NE.J.AND.ID.LT.11) THEN NJET=NJET+1 IDJETS(NJET)=IDS(J) DO 12 K=1,4 PJETS(K,NJET)=PRTNS(K,J) 12 CONTINUE PJETS(5,NJET)=PRTNS(4,J)**2-PRTNS(1,J)**2-PRTNS(2,J)**2- $ PRTNS(3,J)**2 IF ( PJETS(5,NJET).GT.0. ) THEN PJETS(5,NJET)=SQRT(PJETS(5,NJET)) ELSE PJETS(4,NJET)=SQRT(PRTNS(4,J)**2-PJETS(5,NJET)) PJETS(5,NJET)=0. ENDIF ENDIF DO 13 K=1,4 SUM(K)=SUM(K)+PRTNS(K,J) 13 CONTINUE 11 CONTINUE C C eta and phi of incoming partons IF(DOEVOL) THEN NP=NQS-1 DO 114 I=1,NP PPI=SQRT(PRTNS(1,I)**2+PRTNS(2,I)**2+PRTNS(3,I)**2) IF(PPI.GT.0.AND.PPI.GT.ABS(PRTNS(3,I))) THEN THQ(I)=ACOS(PRTNS(3,I)/PPI) ETAQ(I)=-LOG(TAN(THQ(I)/2)) ELSE THQ(I)=0 ETAQ(I)=SIGN(999.,PRTNS(3,I)) ENDIF PTQ(I)=SQRT(PRTNS(1,I)**2+PRTNS(2,I)**2) IF(PTQ(I).GT.0) THEN PHIQ(I)=ATAN2(PRTNS(2,I),PRTNS(1,I)) IF(PHIQ(I).LT.0) PHIQ(I)=PHIQ(I)+TWOPI ELSE PHIQ(I)=0 ENDIF 114 CONTINUE C C ... Order partons in pt C DO 115 I = 1 , NP JIORD(I) = I PXPT(I)=PTQ(I) 115 CONTINUE CALL ISASRT(PXPT(1),NP,JIORD) DO 116 I = 1 , NP PXPT(I)=PTQ(I) PXETA(I)=ETAQ(I) PXPHI(I)=PHIQ(I) JDORD(I) = JIORD(NP-I+1) 116 CONTINUE DO 117 I = 1 , NP PTQ(I)=PXPT(JDORD(I)) ETAQ(I)=PXETA(JDORD(I)) PHIQ(I)=PXPHI(JDORD(I)) 117 CONTINUE ENDIF C C 15 CONTINUE PBEAM(1)=(ECM-SUM(4)-SUM(3))/2. PBEAM(2)=(ECM-SUM(4)+SUM(3))/2. QSQ=SQRT(SUM(4)**2-SUM(3)**2-SUM(2)**2-SUM(1)**2) CALL RANFMT NPTCL=0 IF(KEYS(3)) THEN STDDY=.FALSE. IF(NQS.EQ.1.OR.NJET.LT.3) STDDY=.TRUE. ENDIF CALL IPRTNS(NQS,PRTNS,IDQ) IF(.NOT.NOEVOL) THEN CALL EVOLVE C C special check for VECBOS IF(DOEVOL) THEN C Find parton jets CALL ISPJET(RCUT,ETCUT,NPJ,PXPT,PXPHI,PXETA) IF(NPJ.GE.NP.AND.PXPT(NP).GT.PTQ(NP)) THEN R=SQRT((PXETA(NP)-ETAQ(NP))**2+(PXPHI(NP)-PHIQ(NP))**2) IF(R.GT.RCUT) GOTO 15 ENDIF ENDIF C IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF WT=WEIGHT SUMWT=SUMWT+WT SIGF=SUMWT NKINF=IEVT NEVENT=IEVT 999 RETURN C C Entry point to set parameters C ENTRY EVCUTS(RIN,ETIN,DOEVIN) RCUT=RIN ETCUT=ETIN DOEVOL=DOEVIN RETURN END +EOD +DECK,IPJSET SUBROUTINE IPJSET C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Initialize PJSET starting from PJETS C- C- Created 14-AUG-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PRIMAR +CDE,PJETS +CDE,JETSET INTEGER I,K C---------------------------------------------------------------------- DO 110 I=1,NJET NJSET=NJSET+1 JORIG(NJSET)=JPACK*I JTYPE(NJSET)=IDJETS(I) JDCAY(NJSET)=0 DO 115 K=1,5 115 PJSET(K,NJSET)=PJETS(K,I) IFRAME(I)=1 110 CONTINUE 999 RETURN END +EOD +DECK,IPRTNS SUBROUTINE IPRTNS(NPRTNS,PRTNS,IDQ) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Fill PINITS common block C- Inputs : C- IDQ(2)= id's of partons starting reaction C- C- Created 10-OCT-1991 Serban D. Protopopescu C- Renamed from IPINIT to avoid name clash with Cern Library C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF INTEGER NPRTNS,IDQ(2) REAL PRTNS(4,NPRTNS) +CDE,JETPAR +CDE,PINITS REAL AMASS, AM1SQ,AM2SQ,ROOT,QPL,QMN,P1PL,P1MN,P2PL,P2MN INTEGER I C---------------------------------------------------------------------- C sum P+ and P-, shat C assumes sum of transverse momenta is zero QPL=0 QMN=0 DO 1 I=1,NPRTNS QPL=QPL+PRTNS(4,I)+PRTNS(3,I) QMN=QMN+PRTNS(4,I)-PRTNS(3,I) 1 CONTINUE SHAT=QPL*QMN C C fill PINITS DO 2 I=1,2 IDINIT(I)=IDQ(I) PINITS(5,I)=AMASS(IDQ(I)) PINITS(1,I)=0. PINITS(2,I)=0. 2 CONTINUE C and solve initial kinematics AM1SQ=PINITS(5,1)**2 AM2SQ=PINITS(5,2)**2 ROOT=SQRT((QPL*QMN-AM1SQ-AM2SQ)**2-4.*AM1SQ*AM2SQ) P1PL=(QPL*QMN+AM1SQ-AM2SQ+ROOT)/(2.*QMN) P1MN=AM1SQ/P1PL P2MN=(QPL*QMN+AM2SQ-AM1SQ+ROOT)/(2.*QPL) P2PL=AM2SQ/P2MN PINITS(3,1)=.5*(P1PL-P1MN) PINITS(4,1)=.5*(P1PL+P1MN) PINITS(3,2)=.5*(P2PL-P2MN) PINITS(4,2)=.5*(P2PL+P2MN) 999 RETURN END +EOD +DECK,IRMOV0. SUBROUTINE IRMOV0 C---------------------------------------------------------------------- C- C- Purpose and Methods : C- remove 0's from PJSET C- C- Created 15-OCT-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,JETSET +CDE,JWORK INTEGER NCOUNT,I,J,K C---------------------------------------------------------------------- C C remove zeroes NCOUNT=NJSET DO 160 I=3,NJSET 151 IF (PJSET(4,I).EQ.0.AND.I.LT.NCOUNT) THEN DO 155 K=I+1,NCOUNT DO 154 J=1,5 PJSET(J,K-1)=PJSET(J,K) 154 CONTINUE JORIG(K-1)=JORIG(K) JTYPE(K-1)=JTYPE(K) JDCAY(K-1)=JDCAY(K) ZZC(K-1)=ZZC(K) JMATCH(K-1)=JMATCH(K) IF(JMATCH(K-1).GT.I) JMATCH(K-1)=JMATCH(K-1)-1 155 CONTINUE NCOUNT=NCOUNT-1 GOTO 151 ENDIF 160 CONTINUE NJSET=NCOUNT C remove last one if 0 IF(PJSET(4,NJSET).EQ.0) NJSET=NJSET-1 999 RETURN END +EOD +DECK,ISABEG. SUBROUTINE ISABEG(IFL) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Initialize a process before event generation C- C- Created 5-FEB-1988 Serban D. Protopopescu C- C Ver 7.14: Do logic after setting physics parameters C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,NODCAY +CDE,IDRUN +CDE,KEYS +CDE,PRIMAR +CDE,JETPAR +CDE,ISLOOP +CDE,XMSSM +CDE,ISAPW C INTEGER IFL,I LOGICAL FIRST SAVE FIRST CHARACTER*30 ISAPW2 SAVE ISAPW2 DATA FIRST/.TRUE./ C ISAPW2 is used to check whether ALDATA is loaded DATA ISAPW2/'ALDATA REQUIRED BY FORTRAN G,H'/ C C Initialize C IF(ISAPW1.NE.ISAPW2) THEN PRINT*, ' ISABEG ERROR: BLOCK DATA ALDATA HAS NOT BEEN LOADED.' PRINT*, ' ISAJET CANNOT RUN WITHOUT IT.' PRINT*, ' PLEASE READ THE FINE MANUAL FOR ISAJET.' STOP99 ENDIF C IF (FIRST) THEN FIRST=.FALSE. ELSE CALL SETNXT ENDIF IEVT=0 IEVGEN=0 NEVENT=0 IEVOL=1 IFRG=1 C C Read in user data and decay table C CALL READIN(IFL) IF(IFL.NE.0) GOTO 999 CALL IDGEN IF(GOMSSM) THEN CALL DOMSSM ENDIF IF ((KEYS(2).OR.KEYS(10)).AND..NOT.GOMSSM) THEN CALL SETH END IF CALL SETDKY(.FALSE.) C C Generate NSIGMA unevolved events for SIGF calculation C C TWOJET events IF(KEYS(1)) THEN CALL MBSET CALL SETW CALL LOGIC CALL PRTLIM CALL PTFUN DO 105 I=1,NSIGMA 105 CALL TWOJET CALL TIMER(1) C C E+E- events ELSE IF(KEYS(2)) THEN CALL SETW CALL LOGIC CALL PRTLIM CALL EEBEG CALL EEMAX DO 205 I=1,NSIGMA 205 CALL ELCTRN CALL TIMER(1) C C DRELLYAN events ELSE IF(KEYS(3)) THEN CALL SETW CALL MBSET CALL LOGIC CALL PRTLIM CALL QFUNC DO 305 I=1,NSIGMA 305 CALL DRLLYN CALL TIMER(1) C C MINBIAS events ELSE IF(KEYS(4)) THEN PBEAM(1)=HALFE PBEAM(2)=HALFE CALL PRTLIM CALL MBSET CALL TIMER(1) C C SUPERSYM events ELSE IF(KEYS(5)) THEN CALL SETW CALL MBSET CALL LOGIC CALL PRTLIM CALL PTFUN DO 505 I=1,NSIGMA 505 CALL TWOJET CALL TIMER(1) C C WPAIR events ELSE IF(KEYS(6)) THEN CALL SETW CALL MBSET CALL LOGIC CALL PRTLIM CALL PTFUN DO 605 I=1,NSIGMA CALL TWOJET 605 CALL WPAIR CALL TIMER(1) C C HIGGS events ELSE IF(KEYS(7)) THEN CALL SETW IF(GOMSSM) THEN CALL SETHSS ELSE CALL SETH ENDIF CALL MBSET CALL LOGIC CALL PRTLIM CALL QFUNC DO 705 I=1,NSIGMA 705 CALL DRLLYN CALL TIMER(1) C C PHOTON events ELSEIF(KEYS(8)) THEN CALL MBSET CALL SETW CALL LOGIC CALL PRTLIM CALL PTFUN DO 805 I=1,NSIGMA 805 CALL TWOJET CALL TIMER(1) C C TCOLOR events ELSE IF(KEYS(9)) THEN CALL SETW CALL MBSET CALL LOGIC CALL PRTLIM CALL QFUNC DO 905 I=1,NSIGMA 905 CALL DRLLYN CALL TIMER(1) C C WHIGGS events ELSE IF(KEYS(10)) THEN CALL SETW CALL MBSET CALL LOGIC CALL PRTLIM CALL PTFUN DO 906 I=1,NSIGMA CALL TWOJET 906 CALL WHIGGS CALL TIMER(1) C C EXTRADIM events ELSE IF(KEYS(11)) THEN CALL SETW CALL SETKKG CALL MBSET CALL LOGIC CALL PRTLIM CALL QFUNC DO 1105 I=1,NSIGMA CALL DRLLYN 1105 CONTINUE CALL TIMER(1) C C ZJJ events C ZJJ0 initializes cross sections, so no event loop ELSEIF(KEYS(12)) THEN CALL SETW CALL MGINIT CALL MBSET CALL LOGIC CALL PRTLIM CALL ZJJ0 CALL TIMER(1) ELSE STOP 99 ENDIF 999 RETURN END +EOD +DECK,ISAEND. SUBROUTINE ISAEND C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Terminate an ISAJET run C- C- Created 4-FEB-1988 Serban D. Protopopescu C- C---------------------------------------------------------------------- CALL TIMER(2) CALL GETTOT(.TRUE.) 999 RETURN END +EOD +DECK,ISAEVT. SUBROUTINE ISAEVT(I,OK,DONE) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- C- Normal operation: C- Generate one ISAJET event and return. C- C- "ISALEP" generation: C- Generate a TWOJET or DRELLYAN hard scattering. Then make NEVOLVE C- evolutions and NHADRON fragmentations, rejecting events which C- fail the desired cuts using logical functions C- REJJET() tests the QCD evolution stage, e.g. by requiring C- a heavy quark. C- REJFRG() tests the fragmentation stage, e.g. by requiring C- a high-pt lepton. C- These functions default to .FALSE.; i.e. they do not reject any C- events. Note that one hard scattering can give more than one C- event. You must choose NEVOLVE and NHADRON carefully. C- IEVT = event number. This is incremented NEVOLVE * NHADRON C- times for each hard scattering; i.e. it counts the C- number of potential events. C- IEVGEN = counter for generated events. C- NEVENT = maximum value of hard scatterings. Hence the limit C- for IEVT is NEVENT * NEVOLVE * NHADRON. C- The cross section SIGF contains an extra factor of C- 1 / (NEVOLVE * NHADRON) C- to produce the correct final cross section using the weight C- SIGF / NEVENT C- C- Input: C- I = number used to control printout C- Output: C- OK = logical flag for good event. C- DONE = logical flag for job completion. C- C- Created 3-FEB-1988 Serban D. Protopopescu C- Updated 17-APR-1990 Serban D. Protopopescu (add ISALEP option) C- 22-JUL-1992: Move PRTEVT and GETTOT statements to end so they C- work for TWOJET and DRELLYAN with NOVOLVE. (FEP) C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,IDRUN +CDE,KEYS +CDE,NODCAY +CDE,PRIMAR +CDE,JETPAR +CDE,PARTCL +CDE,JETSET +CDE,ISLOOP C LOGICAL REJJET,REJFRG,OK,DONE INTEGER NPASS,I,NLIMIT C IF (WRTLHE) THEN NOEVOL=.TRUE. NOHADR=.TRUE. END IF NPASS=0 OK=.TRUE. DONE=.FALSE. NLIMIT=NEVENT*NEVOLV*NFRGMN C C Twojet or Drell-Yan events. The evolution and fragmentation C loops are done with GO TO statements so that we can exit C the loops with a good event and reenter them. C IF(KEYS(1).OR.KEYS(3)) THEN 100 CONTINUE IF(IEVOL.EQ.1.AND.IFRG.EQ.1) THEN NPASS=NPASS+1 IF(NPASS.GT.NTRIES) THEN WRITE(ITLIS,1001) NTRIES 1001 FORMAT(//' IT IS TAKING MORE THAN',I6,' TRIES TO MAKE', $ ' AN EVENT IN ISAEVT.'/ $ ' CHECK YOUR LIMITS OR OR INCREASE NTRIES.'/ $ ' CHECK NEVOLVE, NHADRON, AND YOUR REJJET AND REJFRG', $ ' FUNCTIONS IF ANY.'/ $ ' JOB TERMINATED.') STOP 99 ENDIF CALL RANFMT C Generate appropriate hard scattering IF(KEYS(1)) THEN CALL TWOJET ELSE CALL DRLLYN ENDIF ENDIF C QCD evolution IF(NOEVOL) THEN IEVT=IEVT+NEVOLV*NFRGMN GOTO 9999 ENDIF C Continue if in fragmentation loop IF(IFRG.NE.1) GO TO 120 C Begin multiple evolution loop 110 CONTINUE NJSET=0 IEVT=IEVT+1 CALL EVOLVE IEVT=IEVT-1 IF(NJSET.LT.0) THEN IEVT=IEVT+NFRGMN GO TO 111 ENDIF IF(REJJET()) THEN IEVT=IEVT+NFRGMN GO TO 111 ENDIF IF(NOHADR) THEN IEVT=IEVT+NFRGMN GO TO 9999 ENDIF C Begin multiple fragmentation loop 120 CONTINUE NPTCL=0 CALL FRGMNT IEVT=IEVT+1 IF(REJFRG()) GO TO 121 C Finish good event CALL MBIAS IFRG=IFRG+1 IF(IFRG.GT.NFRGMN) IFRG=1 IF(IFRG.EQ.1) THEN IEVOL=IEVOL+1 IF(IEVOL.GT.NEVOLV) IEVOL=1 ENDIF GOTO 9999 C Fragmentation failed - increment counter and loop 121 IFRG=IFRG+1 IF(IFRG.GT.NFRGMN) THEN IFRG=1 ELSE GO TO 120 ENDIF C End of multiple fragmentation loop C Evolution failed - increment counter and loop 111 IEVOL=IEVOL+1 IF(IEVOL.GT.NEVOLV) THEN IEVOL=1 IFRG=1 GO TO 100 ELSE GO TO 110 ENDIF C C E+E- events C ELSE IF(KEYS(2)) THEN IEVT=IEVT+1 CALL RANFMT CALL ELCTRN IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(.NOT.NOHADR) CALL FRGMNT ENDIF C C MINBIAS events C ELSE IF(KEYS(4)) THEN IEVT=IEVT+1 CALL RANFMT NPTCL=0 IF(.NOT.(NOEVOL.OR.NOHADR)) CALL MBIAS C C SUPERSYM events C ELSE IF(KEYS(5)) THEN IEVT=IEVT+1 CALL RANFMT CALL TWOJET IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GO TO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C WPAIR events C ELSE IF(KEYS(6)) THEN IEVT=IEVT+1 CALL RANFMT CALL TWOJET CALL WPAIR C IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GO TO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C HIGGS events C ELSE IF(KEYS(7)) THEN IEVT=IEVT+1 CALL RANFMT CALL DRLLYN CALL HIGGS IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GOTO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C PHOTON events C ELSEIF(KEYS(8)) THEN IEVT=IEVT+1 CALL RANFMT CALL TWOJET IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GOTO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C TCOLOR events, e.g. techni-rho C ELSEIF(KEYS(9)) THEN IEVT=IEVT+1 CALL RANFMT CALL DRLLYN CALL HIGGS IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GOTO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C WHIGGS events C ELSE IF(KEYS(10)) THEN IEVT=IEVT+1 CALL RANFMT CALL TWOJET CALL WHIGGS C IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GO TO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C EXTRADIM events C ELSE IF(KEYS(11)) THEN IEVT=IEVT+1 CALL RANFMT CALL DRLLYN C IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GO TO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF C C ZJJ events C ELSEIF(KEYS(12)) THEN IEVT=IEVT+1 CALL RANFMT CALL ZJJ C IF(.NOT.NOEVOL) THEN CALL EVOLVE IF(NJSET.LT.0) GO TO 9999 IF(.NOT.NOHADR) THEN CALL FRGMNT CALL MBIAS ENDIF ENDIF ENDIF C C Event complete C 9999 IEVGEN=IEVGEN+1 IF(NJSET.LT.0) OK=.FALSE. IF(IEVT.GT.NLIMIT) THEN OK=.FALSE. DONE=.TRUE. ELSEIF(IEVT.EQ.NLIMIT) THEN DONE=.TRUE. ENDIF IF (WRTLHE) THEN CALL ISALHE END IF IF(OK) THEN CALL PRTEVT(I) CALL GETTOT(.FALSE.) ENDIF RETURN END +EOD +DECK,ISAINI. SUBROUTINE ISAINI(JTDKY,JTEVT,JTCOM,JTLIS) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- INITIALIZE PROCESSES C- C- Inputs : C JTDKY = +/- UNIT NUMBER FOR DECAY TABLE FILE. C IF IT IS NEGATIVE, DECAY TABLE IS NOT PRINTED. C JTEVT = +/- UNIT NUMBER FOR OUTPUT EVENT FILE. C IF IT IS NEGATIVE, ONLY STABLE PARTICLES ARE C WRITTEN ON IT. C JTCOM = UNIT NUMBER FOR COMMAND FILE. C JTLIS = UNIT NUMBER FOR LISTING. C- C- Created 3-FEB-1988 Serban D. Protopopescu C- C---------------------------------------------------------------------- C +CDE,IDRUN +CDE,ITAPES C C ENTRY. ITDKY=IABS(JTDKY) ITEVT=JTEVT ITCOM=IABS(JTCOM) ITLIS=IABS(JTLIS) C IEVT=0 CALL SETCON CALL RESET IF(JTDKY.GT.0) THEN CALL SETDKY(.TRUE.) ELSE CALL SETDKY(.FALSE.) ENDIF C 999 RETURN END +EOD +DECK,ISAJET. SUBROUTINE ISAJET(JTDKY,JTEVT,JTCOM,JTLIS) C C Main subroutine for ISAJET, a Monte Carlo event generator C for P P , AP P , and E+ E- interactions at high energy. C C Frank E. Paige and Serban D. Protopopescu C Brookhaven National Laboratory C Upton, New York, USA C C JTDKY = +/- unit number for decay table file. C If it is negative, decay table is not printed. C JTEVT = +/- unit number for output event file. C If it is negative, only stable particles are C written on it. C JTCOM = unit number for command file. C JTLIS = unit number for listing. C C Instead of calling this subroutine the user may wish to C control the program himself using: C ISAINI overall initialization C ISABEG run initialization C ISAEVT generation of one event C ISAEND run termination C ISAWBG initial record writing C ISAWEV event record writing C ISAWND end record writing C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,IDRUN +CDE,PRIMAR +CDE,ISLOOP C INTEGER JTDKY,JTEVT,JTCOM,JTLIS,IFL,ILOOP LOGICAL OK,DONE SAVE ILOOP C C Initialize ISAJET C CALL ISAINI(JTDKY,JTEVT,JTCOM,JTLIS) C C Read instructions; terminate for STOP command or error. C 1 IFL=0 CALL ISABEG(IFL) IF(IFL.NE.0) RETURN C Write begin-run record CALL ISAWBG C C Event loop C ILOOP=0 101 CONTINUE ILOOP=ILOOP+1 C Generate one event - discard if .NOT.OK CALL ISAEVT(ILOOP,OK,DONE) C Write event record IF(OK) CALL ISAWEV IF(.NOT.DONE) GO TO 101 C C Calculate cross section and luminosity C CALL ISAEND C Write end-of-run record CALL ISAWND GO TO 1 C C Entry point for error recovery. C CALL RSTART will continue generation on next event. C ENTRY RSTART IF(IEVT.EQ.0) RETURN IF(IEVT.GE.NEVENT*NEVOLV*NFRGMN) GO TO 1 GO TO 101 END +EOD +DECK,ISALHE SUBROUTINE ISALHE C C USING NOEVOL AND NOHADR, DECAY SUBPROCESS PARTICLES TO FILL C PARTCL COMMON BLOCK. THEN WRITE TO A .lhe FILE, C SO EVENT CAN BE PASSED TO OTHER GENERATORS FOR C SHOWERING, HADRONIZATION AND UNDERLYING EVENT C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,KEYS +CDE,PARTCL +CDE,PRIMAR +CDE,JETPAR +CDE,PJETS +CDE,PINITS +CDE,IDRUN +CDE,SSTYPE +CDE,LISTSS +CDE,XMSSM +CDE,SSLUN +CDE,CONST C INTEGER I,IFL1,IFL2,IP1,JET,NFIRST,IP INTEGER LISTJ(17),LISTW(4),LISTSM(30),IPAK,ID INTEGER ICOLOR(2,100),ISTAT,ITRANS,I1 INTEGER IF1,IF2,IF3,JSPIN,INDEX,indx1,indx2,indx3,indx4 INTEGER ND,N1,N2,N3,L1,IMO1,IMO2 REAL AMASS C INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) DATA LISTSM/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13, $14,-14,15,-15,16,-16,10,80,-80,90,81/ DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,7,-7,8,-8/ DATA LISTW/10,80,-80,90/ DATA IPAK/100/ C FILL PARTCL FROM JETPAR: FINAL PARTONS NPTCL=NJET DO 100 I=1,NJET PPTCL(1,I)=PT(I)*COS(PHI(I)) PPTCL(2,I)=PT(I)*SIN(PHI(I)) PPTCL(3,I)=P(I)*CTH(I) IF(KEYS(1)) THEN IDENT(I)=LISTJ(JETTYP(I)) ELSEIF(KEYS(2)) THEN IDENT(I)=IDJETS(I) ELSEIF(KEYS(5).OR.(KEYS(10).AND.GOMSSM)) THEN IDENT(I)=LISTSS(JETTYP(I)) ELSEIF(KEYS(6)) THEN IDENT(I)=LISTW(JETTYP(I)) ELSEIF(KEYS(8)) THEN IF(JETTYP(1).LE.13) THEN IFL1=LISTJ(JETTYP(1)) ELSE IFL1=10 ENDIF IF(JETTYP(2).LE.13) THEN IFL2=LISTJ(JETTYP(2)) ELSE IFL2=10 ENDIF IDENT(1)=IFL1 IDENT(2)=IFL2 ELSEIF(KEYS(10)) THEN IDENT(I)=LISTSM(JETTYP(I)) ENDIF PPTCL(5,I)=AMASS(IDENT(I)) PPTCL(4,I)=SQRT(P(I)**2+PPTCL(5,I)**2) IORIG(I)=-(IPACK*I) IDCAY(I)=0 100 CONTINUE C Implement color connection for 2-> 2 subprocess IF (NPTCL.EQ.2) THEN CALL COLR22(IDINIT(1),IDINIT(2),IDENT(1),IDENT(2),ICOLOR) END IF C NOW DECAY FINAL STATE PARTONS DO 610 IP=1,NJET NFIRST=NPTCL+1 JET=IP CALL DECAY(IP) c ND=NPTCL-(NFIRST-1) N1=NFIRST N2=NFIRST+1 L1=IP IF (ND.EQ.2) THEN CALL COLR12(IDENT(IP),L1,IDENT(N1),N1,IDENT(N2),N2,ICOLOR) END IF IF (ND.EQ.3) THEN N3=NFIRST+2 CALL COLR13(IDENT(IP),L1,IDENT(N1),N1,IDENT(N2),N2, $ IDENT(N3),N3,ICOLOR) END IF C DO 620 IP1=NFIRST,NPTCL 620 IORIG(IP1)=ISIGN(IABS(IORIG(IP1))+IPACK*JET,IORIG(IP1)) 610 CONTINUE C NOW DECAY THE DECAY PRODUCTS IP=NJET+1 700 NFIRST=NPTCL+1 JET=IABS(IORIG(IP))/IPACK CALL DECAY(IP) c ND=NPTCL-(NFIRST-1) N1=NFIRST N2=NFIRST+1 L1=IP IF (ND.EQ.2) THEN CALL COLR12(IDENT(IP),L1,IDENT(N1),N1,IDENT(N2),N2,ICOLOR) END IF IF (ND.EQ.3) THEN N3=NFIRST+2 CALL COLR13(IDENT(IP),L1,IDENT(N1),N1,IDENT(N2),N2, $ IDENT(N3),N3,ICOLOR) END IF C DO 720 IP1=NFIRST,NPTCL 720 IORIG(IP1)=ISIGN(IABS(IORIG(IP1))+IPACK*JET,IORIG(IP1)) IP=IP+1 IF (IP.LE.NPTCL) GO TO 700 C C Now output to isajet.lhe WRITE(LHEOUT,1001) C Here one needs to invert particle IDs using LISTJ C for idinit or LISTSS for IDENT if running SUSY C in order to match up with INOUT reaction code. C ID=IPAK**3*JETTYP(2)+IPAK**2*JETTYP(1)+IPAK*INITYP(2)+INITYP(1) c If we have SUSY production, just dump out one type of subprocess, C since Pythia can only handle 500 or less IF (GOMSSM) THEN ID=2160 END IF WRITE(LHEOUT,1002) NPTCL+2,ID,1.,QSQ,ALFA,ALFQSQ C Write out initial state particles DO I=1,2 WRITE(LHEOUT,1003) ITRANS(IDINIT(I),1),-1,0,0, $ICOLOR(1,I),ICOLOR(2,I),PINITS(1,I),PINITS(2,I),PINITS(3,I), $PINITS(4,I),PINITS(5,I),0.,9. END DO DO I=1,NPTCL IF (IDCAY(I).EQ.0.) THEN ISTAT=1 ELSE ISTAT=2 END IF IF (IORIG(I).EQ.0) ISTAT=-1 I1=IABS(IORIG(I)) JET=I1/IPACK I1=I1-IPACK*JET I1=ISIGN(I1,IORIG(I)) IF (I.LE.2) THEN IMO1=1 IMO2=2 ELSE IMO1=I1+2 IMO2=0 END IF WRITE(LHEOUT,1003) ITRANS(IDENT(I),1),ISTAT,IMO1,IMO2, $ICOLOR(1,I+2),ICOLOR(2,I+2),PPTCL(1,I),PPTCL(2,I),PPTCL(3,I), $PPTCL(4,I),PPTCL(5,I),0.,9. END DO WRITE(LHEOUT,1004) 1001 FORMAT('') 1002 FORMAT(4X,I3,4X,I8,3X,F12.5,3X,E12.6,3X,F12.6,3X,F12.6) 1003 FORMAT(6X,I8,3(2X,I4),2(2X,I3),5(2X,E12.6),2(1X,F2.0)) 1004 FORMAT('') RETURN END +EOD +DECK,ISASRT SUBROUTINE ISASRT(X,NCH,IMAP) C---------------------------------------------------------------------- C- C- Purpose and Methods : Sorts a floating point array X into ascending order. C- The array IMAP contains ordered list of pointers C- C- Inputs : X - Floating point array C- NCH - Number of elements in X C- Outputs : IMAP - pointer to ordered list in X C- Controls: None C- C- Created 3-OCT-1988 Rajendran Raja C- Based on the Algorithm of D.L.Shell, High speed sorting C- procedure , Communications of the ACM, Vol 2, July 1959, PP 30-32 C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL X(*) REAL TEMP INTEGER IMAP(*),NCH,M,I,J,K,IM,IT C---------------------------------------------------------------------- M=NCH 10 M=M/2 !binary chop IF(M.EQ.0)GO TO 999 K=NCH-M J=1 20 I=J 30 IM=I+M IF(X(I).LE.X(IM))GO TO 40 TEMP = X(I) X(I) = X(IM) X(IM) = TEMP IT = IMAP(I) IMAP(I)=IMAP(IM) IMAP(IM)=IT I = I-M IF(I.GE.1)GO TO 30 40 J=J+1 IF(J.GT.K)GO TO 10 GO TO 20 999 RETURN END +DECK,ISPJET SUBROUTINE ISPJET(DRCUT,ETCUT,NPJ,PJPT,PJPHI,PJETA) C---------------------------------------------------------------------- C- C- Purpose and Methods : COMBINES PARTONS INTO PARTON JETS C- based on PJCONE C- Inputs C- DRCUT - dR=sqrt(dETA**2+dPHI**2) cut around Leading Partons. C- ETCUT - Transverse Energy cut (minimum for defining a JET ). C- C- Outputs : C- NPJ = No. of Parton Jets found. C- PJPT(NPJ) = pt of partons C- PJPHI(NPJ)= phi " C- PJETA(NPJ)= eta " C- C- created 16-APR-1996 Serban D. Protopopescu C- Updated 16-JUN-1998 F. Paige C- Copy of ISAZEB routine ISA_PJETS to be used by IPARTNS C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PJETS +CDE,JETSET C INTEGER NPJ REAL DRCUT REAL PJPHI(*), PJETA(*), PJPT(*) INTEGER NP, JP, J, JO, JOP1, JOP2, JP1, JP2, ISKP, IP REAL X1, Y1, PHI1, PHI2,TH REAL DETA, DPHI, DR, ETCUT INTEGER NPMAX PARAMETER (NPMAX=50) INTEGER JIORD(NPMAX), JDORD(NPMAX), JCNN(NPMAX,NPMAX) INTEGER JSKP(NPMAX) INTEGER I, JJ, K REAL PJIN(4,NPMAX), PINPHI(NPMAX), PINETA(NPMAX) REAL PINPT(NPMAX),PDMPT(NPMAX) REAL PJ(4,NPMAX) REAL EPS DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN C C last significant (correctly rounded) decimal place on VAX: C | C V PARAMETER (PI= 3.1415 92653 58979 32384 6 D0) PARAMETER (TWOPI= 6.2831 85307 17958 64769 3 D0) PARAMETER (HALFPI= 1.5707 96326 79489 66192 3 D0) PARAMETER (RADIAN= 0.0174532 92519 94329 5769237 D0) C PARAMETER( EPS = 1.0E-5 ) C---------------------------------------------------------------------- C NP=0 DO 10 I=1,NJSET IF(JDCAY(I).EQ.0.AND.IABS(JTYPE(I)).LT.10) THEN NP = NP + 1 DO 11 K=1,4 PJIN(K,NP)=PJSET(K,I) 11 CONTINUE PINPT(NP) = SQRT( PJIN(1,NP)**2+PJIN(2,NP)**2 ) PINPHI(NP) = ATAN2 (PJIN(2,NP),PJIN(1,NP)+EPS) IF(PINPHI(NP).LT.0.)PINPHI(NP)=PINPHI(NP)+TWOPI TH = ATAN2 (PINPT(NP),PJIN(3,NP)+EPS) PINETA(NP) = -ALOG ( ABS(TAN(TH/2.)) + EPS ) IF(NP.GE.NPMAX) GOTO 35 ENDIF 10 CONTINUE 35 CONTINUE ! jump here if more than NPMAX partons C C ... Order partons in pt C DO 100 JP = 1 , NP JIORD(JP) = JP 100 PDMPT(JP)=PINPT(JP) CALL ISASRT(PDMPT(1),NP,JIORD) DO 105 JP = 1 , NP 105 JDORD(JP) = JIORD(NP-JP+1) C C ... Combine partons close in r space C DO 110 J = 1 , NP JO=JDORD(J) 110 JCNN(JO,1)=0 ISKP=0 DO 120 JP1 = 1 , NP-1 JOP1=JDORD(JP1) C ... Check if parton already connected to other one IF ( JCNN(JOP1,1).EQ.-1 ) GOTO 120 DO 130 JP2 = JP1+1 , NP JOP2=JDORD(JP2) C ... Check if parton already connected to other one IF ( JCNN(JOP2,1).EQ.-1 ) GOTO 130 DETA = PINETA(JOP1) - PINETA(JOP2) PHI1 = PINPHI(JOP1) PHI2 = PINPHI(JOP2) X1 = COS(PHI2-PHI1) Y1 = SIN(PHI2-PHI1) IF(X1.EQ.0.0) THEN DPHI = HALFPI ELSE DPHI = ATAN2(Y1,X1) END IF DR = SQRT(DETA**2+DPHI**2) C --- Criterion for combining partons IF ( DR.LT.DRCUT ) THEN JCNN(JOP1,1)=JCNN(JOP1,1)+1 JCNN(JOP2,1)=-1 JCNN(JOP1,JCNN(JOP1,1)+1)=JOP2 ISKP=ISKP+JCNN(JOP1,1) JSKP(ISKP)=JOP2 ELSE GOTO 130 ENDIF 130 CONTINUE 120 CONTINUE C C ... Bookkeeping for parton jets C DO 150 IP = 1 , NPJ PJPHI(IP)=0. PJETA(IP)=0. PJPT(IP) =0. 150 CONTINUE NPJ=0 DO 200 JP1 = 1 , NP JOP1=JDORD(JP1) C ... Already connected, single parton, or has others to connect to IF ( JCNN(JOP1,1).GE.0 ) THEN NPJ=NPJ+1 DO 151 K=1,4 PJ(K,NPJ)=PJIN(K,JOP1) 151 CONTINUE PJPHI(NPJ) = PINPHI(JOP1) PJETA(NPJ) = PINETA(JOP1) PJPT(NPJ) = PINPT(JOP1) IF ( JCNN(JOP1,1).EQ.0 ) GOTO 205 DO 210 JJ = 1 , JCNN(JOP1,1) PJ(1,NPJ) = PJ(1,NPJ) + PJIN(1,JCNN(JOP1,JJ+1)) PJ(2,NPJ) = PJ(2,NPJ) + PJIN(2,JCNN(JOP1,JJ+1)) PJ(3,NPJ) = PJ(3,NPJ) + PJIN(3,JCNN(JOP1,JJ+1)) PJ(4,NPJ) = PJ(4,NPJ) + PJIN(4,JCNN(JOP1,JJ+1)) 210 CONTINUE PJPT(NPJ) = SQRT( PJ(1,NPJ)**2 + PJ(2,NPJ)**2 ) PJPHI(NPJ) = ATAN2 (PJ(2,NPJ),PJ(1,NPJ)+EPS) IF(PJPHI(NPJ).LT.0.)PJPHI(NPJ)=PJPHI(NPJ)+TWOPI TH = ATAN2 (PJPT(NPJ),PJ(3,NPJ)+EPS) PJETA(NPJ) = -ALOG ( ABS(TAN(TH/2.)) + EPS ) C ... Criterion for dropping a parton jet ( et < etcut ) 205 IF ( PJPT(NPJ).GT.ETCUT ) GOTO 200 NPJ=NPJ-1 ENDIF 200 CONTINUE C C ... Order pjets in pt C DO 300 JP = 1 , NPJ JIORD(JP) = JP 300 PDMPT(JP)=PJPT(JP) CALL ISASRT(PDMPT(1),NPJ,JIORD) DO 305 JP = 1 , NPJ PINPT(JP)=PJPT(JP) PINETA(JP)=PJETA(JP) PINPHI(JP)=PJPHI(JP) 305 JDORD(JP) = JIORD(NPJ-JP+1) DO 306 JP = 1 , NPJ PJPT(JP)=PINPT(JDORD(JP)) PJETA(JP)=PINETA(JDORD(JP)) PJPHI(JP)=PINPHI(JDORD(JP)) 306 CONTINUE C- 999 RETURN END +DECK,ISTRAD SUBROUTINE ISTRAD(FUDGE) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- Set parameters and call QCDINI to generate initial C- state radiation C- Inputs : C- FUDGE= fudge factor C- C- Created 16-AUG-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF REAL FUDGE +CDE,LIMEVL +CDE,JETSET +CDE,JWORK +CDE,JETPAR REAL OFF INTEGER I C---------------------------------------------------------------------- C IF ( USELIM.AND.CONCUT.LT.1.0 ) THEN OFF=ETTHRS ELSEIF( .NOT.USELIM) THEN OFF=SQRT(QSQ)*FUDGE ELSE OFF=SQRT(QSQ) ENDIF DO 150 I=1,2 PJSET(5,I)=-OFF 150 JDCAY(I)=-2 JMATCH(1)=0 JMATCH(2)=0 C CALL QCDINI(1,2) 999 RETURN END +EOD +DECK,ISWDKY SUBROUTINE ISWDKY C---------------------------------------------------------------------- C- C- Purpose and Methods : C- decay W's and Z's as done in ISAJET C- C- Created 6-MAY-1991 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,CONST +CDE,FRAME +CDE,JETPAR +CDE,JETSET +CDE,JWORK +CDE,PJETS +CDE,PARTCL +CDE,PRIMAR +CDE,WCON REAL X(2) EQUIVALENCE (X(1),X1) REAL PREST(5),PL(5),EL(3),EML(3),EMSQL(3) REAL WTFAC(3) REAL BRANCH(29) INTEGER LISTJ(29),LISTW(4) REAL RANF,SUM,PTDEN,QDEN,ETA, $S12,SUMBR,BRMODE,AMASS,BRINV,TRY,PL12, $COSTHL,THL,PHL,PTL,SGN,BP,PLPL,PLMN,AMINI,AMFIN,PINI,PFIN, $ QPL,QMN,AM1SQ,AM2SQ,ROOT,P1PL,P1MN,P2PL,P2MN INTEGER NADD,K,IQ1,IQ2,IFL1,IFL2,IQ,IFL,I REAL EY REAL QWPL,QWMN C DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, $10,80,-80,90/ DATA LISTW/10,80,-80,90/ C---------------------------------------------------------------------- C C Entry C NPTCL=0 C C Kinematics. Note that YW is the true rapidity and QW is C the true 3-momentum. See DRLLYN. C QMW=QWJET(5) QTW=SQRT(QWJET(1)**2+QWJET(2)**2) QW=SQRT(QWJET(1)**2+QWJET(2)**2+QWJET(3)**2) IF(QTW.NE.0) THEN PHIW=ATAN2(QWJET(2),QWJET(1)) IF(PHIW.LT.0) PHIW=PHIW+2*PI ELSE PHIW=0 ENDIF QWPL=QWJET(4)+QWJET(3) QWMN=QWJET(4)-QWJET(3) IF(QWPL.GT.0..AND.QWMN.GT.0.) THEN YW=0.5*ALOG(QWPL/QWMN) ELSE YW=999.*SIGN(1.,QWJET(3)) ENDIF IF(QW.NE.0.) THEN THW=ACOS(QWJET(3)/QW) ELSE THW=0. ENDIF C C Select W decay mode C QMW dependence neglected in branching ratios C BRANCH is cum. br. with heavy modes subtracted. C S12=QMW**2 BRANCH(1)=0. SUMBR=0. DO 105 IQ1=2,25 IQ2=MATCH(IQ1,JWTYP) IF(IQ2.EQ.0) THEN BRMODE=0. ELSE BRMODE=WCBR(IQ1,JWTYP)-WCBR(IQ1-1,JWTYP) IFL1=LISTJ(IQ1) IFL2=LISTJ(IQ2) IF(S12.LE.(AMASS(IFL1)+AMASS(IFL2))**2) BRMODE=0. ENDIF BRANCH(IQ1)=BRANCH(IQ1-1)+BRMODE SUMBR=SUMBR+BRMODE 105 CONTINUE BRINV=1./SUMBR C TRY=RANF() DO 110 IQ=1,25 IF(TRY.LT.BRANCH(IQ)*BRINV.AND.MATCH(IQ,JWTYP).NE.0) THEN JETTYP(1)=IQ JETTYP(2)=MATCH(IQ,JWTYP) GO TO 120 ENDIF 110 CONTINUE C 120 IFL1=LISTJ(JETTYP(1)) IFL2=LISTJ(JETTYP(2)) C C Select masses of decay products. C EML(1)=AMASS(IFL1) EML(2)=AMASS(IFL2) C C Generate W decay in its rest frame C First set up momenta of decay products: C EMSQL(1)=EML(1)**2 EMSQL(2)=EML(2)**2 EL(1)=(S12+EMSQL(1)-EMSQL(2))/(2.*QMW) EL(2)=(S12+EMSQL(2)-EMSQL(1))/(2.*QMW) PL12=SQRT((S12-(EML(1)+EML(2))**2)*(S12-(EML(1)-EML(2))**2)) $/(2.*QMW) C W momentum DO 140 K=1,5 140 PREST(K)=QWJET(K) C Generate next W decay 20 CONTINUE COSTHL=2.*RANF()-1. THL=ACOS(COSTHL) PHL=2.*PI*RANF() PTL=PL12*SIN(THL) C DO 300 I=1,2 SGN=3-2*I PL(1)=SGN*PTL*COS(PHL) PL(2)=SGN*PTL*SIN(PHL) PL(3)=SGN*PL12*COSTHL PL(4)=EL(I) PL(5)=EML(I) C Boost with W momentum BP=0. DO 310 K=1,3 310 BP=BP+PL(K)*PREST(K) BP=BP/PREST(5) DO 320 K=1,3 320 PL(K)=PL(K)+PREST(K)*PL(4)/PREST(5) $ +PREST(K)*BP/(PREST(4)+PREST(5)) PL(4)=PL(4)*PREST(4)/PREST(5)+BP C Fill common blocks PT(I)=SQRT(PL(1)**2+PL(2)**2) P(I)=SQRT(PT(I)**2+PL(3)**2) IF(PT(I).GT.0.) THEN PHI(I)=ATAN2(PL(2),PL(1)) ELSE PHI(I)=(I-1)*PI ENDIF IF(PHI(I).LT.0.) PHI(I)=PHI(I)+2.*PI CTH(I)=PL(3)/P(I) STH(I)=PT(I)/P(I) TH(I)=ACOS(CTH(I)) XJ(I)=PL(3)/HALFE IF(CTH(I).GT.0.) THEN PLPL=PL(4)+PL(3) PLMN=(PT(I)**2+EMSQL(I))/PLPL ELSE PLMN=PL(4)-PL(3) PLPL=(PT(I)**2+EMSQL(I))/PLMN ENDIF YJ(I)=.5*ALOG(PLPL/PLMN) 300 CONTINUE C C Set PJETS C DO 501 I=1,2 PJETS(3,I)=P(I)*CTH(I) PJETS(1,I)=PT(I)*COS(PHI(I)) PJETS(2,I)=PT(I)*SIN(PHI(I)) PJETS(4,I)=SQRT(P(I)**2+EMSQL(I)) PJETS(5,I)=SQRT(EMSQL(I)) IDJETS(I)=LISTJ(JETTYP(I)) 501 CONTINUE 999 RETURN END +EOD +DECK,JETGEN. SUBROUTINE JETGEN(J) C C FRAGMENT JET J IN /JETSET/ INTO PRIMARY HADRONS USING THE C ALGORITHM OF FIELD AND FEYNMAN WITH C F(X)=1-XGEN(1)+XGEN(1)*(XGEN(2)+1)*(1-X)**XGEN(2) C FOR LIGHT QUARKS AND THE PETERSON F(X) WITH C EPSILON=XGEN(I)*AMASS(I)**2 C FOR HEAVY QUARKS. C INCLUDE BARYONS USING DIQUARKS WITH PROBABILITY PBARY. C PROBABILITY PSPIN1 FOR SPIN 1 DEPENDS ON HEAVIEST FLAVOR. C FRAGMENT A GLUON LIKE A RANDOM QUARK. C C Ver 7.30: Use delta function fragmentation for top quark. C C +CDE,ITAPES +CDE,JETSET +CDE,PARTCL +CDE,FRGPAR +CDE,CONST +CDE,MBPAR C LOGICAL HEAVY NBEGIN=NPTCL+1 PSUM=0. IFLBEG=JTYPE(J) HEAVY=.FALSE. IF(IABS(IFLBEG).GT.3.AND.IFLBEG.NE.9) HEAVY=.TRUE. PBEG=SQRT(PJSET(1,J)**2+PJSET(2,J)**2+PJSET(3,J)**2) C TOP QUARK... IF(IABS(IFLBEG).GE.6.AND.IABS(IFLBEG).LE.8) THEN NPTCL=NPTCL+1 PPTCL(1,NPTCL)=0 PPTCL(2,NPTCL)=0 PPTCL(3,NPTCL)=PBEG PPTCL(4,NPTCL)=PJSET(4,J) PPTCL(5,NPTCL)=PJSET(5,J) IORIG(NPTCL)=-J IDCAY(NPTCL)=0 IDENT(NPTCL)=JTYPE(J) RETURN ENDIF C EQUIVALENT QUARK FOR GLUON IF(IFLBEG.NE.9) GO TO 200 IFLBEG=INT(RANF()/PUD)+1 IF(RANF().GT..5) IFLBEG=-IFLBEG C CONSTRUCT FIRST QUARK 200 LOOP=0 IFL1=IFLBEG CALL GETPT(PT1,SIGQT) PHI1=2.*PI*RANF() PX1=PT1*COS(PHI1) PY1=PT1*SIN(PHI1) PPLUS=PBEG+PJSET(4,J) PTRUE=PPLUS 935 CONTINUE C CONSTRUCT NEXT QUARK 300 LOOP=LOOP+1 IF(PPLUS.LT.PEND.OR.LOOP.GT.10000) RETURN C IFL2 CAN BE DIQUARK ONLY IF IFL1 IS NOT IF(MOD(IFL1,100).EQ.0) GO TO 305 IF(RANF().LT.PBARY) GO TO 310 IFL2=ISIGN(INT(RANF()/PUD)+1,-IFL1) GO TO 320 305 IFL2=ISIGN(INT(RANF()/PUD)+1,+IFL1) GO TO 320 310 IQ1=INT(RANF()/PUD)+1 IQ2=INT(RANF()/PUD)+1 IF(IQ1.LE.IQ2) GO TO 315 ISWAP=IQ1 IQ1=IQ2 IQ2=ISWAP 315 IFL2=ISIGN(1000*IQ1+100*IQ2,IFL1) 320 CONTINUE CALL GETPT(PT2,SIGQT) PHI2=2.*PI*RANF() PX2=PT2*COS(PHI2) PY2=PT2*SIN(PHI2) C CONSTRUCT MESON WITH FLAVOR MIXING C SPECIAL CASE - SUPERSYM IFLABS=IABS(IFL1) IF(IFLABS.GT.20.AND.IFLABS.LT.30) THEN IDHAD=IFL1 GOTO 470 ENDIF IF(MOD(IFL1,100).EQ.0) GO TO 420 IF(MOD(IFL2,100).EQ.0) GO TO 425 IHIGH=MAX0(IABS(IFL1),IABS(IFL2)) JSPIN=INT(RANF()+PSPIN1(IHIGH)) ID1=IFL1 ID2=IFL2 IF(ID1+ID2.NE.0) GO TO 400 RND=RANF() ID1=IABS(ID1) ID1=INT(PMIX1(ID1,JSPIN+1)+RND)+INT(PMIX2(ID1,JSPIN+1)+RND)+1 ID2=-ID1 400 IF(IABS(ID1).LE.IABS(ID2)) GO TO 410 ISAVE=ID1 ID1=ID2 ID2=ISAVE 410 IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1) GO TO 470 C CONSTRUCT BARYON IDENT. 420 ID3=MOD(IFL1/100,10) ID2=IFL1/1000 ID1=IFL2 GO TO 430 425 ID3=MOD(IFL2/100,10) ID2=IFL2/1000 ID1=IFL1 430 IF(IABS(ID1).LE.IABS(ID2)) GO TO 431 ISWAP=ID1 ID1=ID2 ID2=ISWAP 431 IF(IABS(ID2).LE.IABS(ID3)) GO TO 432 ISWAP=ID2 ID2=ID3 ID3=ISWAP 432 IF(IABS(ID1).LE.IABS(ID2)) GO TO 440 ISWAP=ID1 ID1=ID2 ID2=ISWAP 440 JSPIN=1 IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) GO TO 450 IHIGH=IABS(ID3) JSPIN=INT(RANF()+PSPIN1(IHIGH)) 450 IF(JSPIN.EQ.1.OR.ID1.EQ.ID2.OR.ID2.EQ.ID3) GO TO 460 IF(RANF().GT.PISPN) GO TO 460 ISWAP=ID1 ID1=ID2 ID2=ISWAP 460 IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN IDHAD=ISIGN(IDHAD,IFL1) 470 CONTINUE AM=AMASS(IDHAD) PX=PX1+PX2 PY=PY1+PY2 AMT2=PX**2+PY**2+AM**2 C IF LEADING PARTICLE, FIND MINIMUM X XMIN=0. IF(LOOP.EQ.1) XMIN=AMIN1(SQRT(AMT2)/PPLUS,1.) C SELECT X C USE FIELD-FEYNMAN FUNCTION FOR LIGHT QUARKS. C USE PETERSON FRAGMENTATION FOR HEAVY QUARKS. C USE DISTRIBUTION FOR HEAVIER QUARK FOR DIQUARKS. II1=IABS(IFL1) IF(MOD(II1,100).EQ.0) II1=MOD(II1/100,10) IF(II1.LE.3) THEN X=RANF() IF(RANF().LT.XGEN(1)) X=1.-X**(1./(XGEN(2)+1.)) ELSEIF(II1.LE.9) THEN CALL HEAVYX(X,XGEN(II1)/AM**2) ELSEIF(II1.GT.20.AND.II1.LT.30) THEN CALL HEAVYX(X,XGENSS(II1-20)/AM**2) ENDIF X=XMIN+(1.-XMIN)*X QPLUS=X*PPLUS QPLUS=AMAX1(QPLUS,1.E-6) QMINUS=AMT2/QPLUS P0=.5*(QPLUS+QMINUS) PZ=.5*(QPLUS-QMINUS) C DISCARD PARTICLE IF PZ<0 IF(PZ.LT.0..AND..NOT.(HEAVY.AND.LOOP.EQ.1)) GO TO 500 C ADD PARTICLE TO /PARTCL/ IF(NPTCL.GE.MXPTCL) GO TO 9999 NPTCL=NPTCL+1 PPTCL(1,NPTCL)=PX PPTCL(2,NPTCL)=PY PPTCL(3,NPTCL)=PZ PPTCL(4,NPTCL)=P0 PPTCL(5,NPTCL)=AM IORIG(NPTCL)=-J IDCAY(NPTCL)=0 IDENT(NPTCL)=IDHAD PSUM=PSUM+QPLUS C SWAP QUARKS AND CONTINUE IF SUFFICIENT PPLUS 500 CONTINUE PX1=-PX2 PY1=-PY2 IFL1=-IFL2 PPLUS=(1.-X)*PPLUS GO TO 300 C 9999 CALL PRTEVT(0) WRITE(ITLIS,10) NPTCL 10 FORMAT(//5X,'ERROR IN JETGEN...NPTCL >',I5) RETURN END +EOD +DECK,KKGF1 REAL FUNCTION KKGF1(S,T,M2) REAL S,T,M2 REAL XG,YG XG = T/S YG = M2/S KKGF1 = & ( -4.*XG*(1.+XG)*(1.+2.*XG+2.*XG**2) & + YG*(1.+6.*XG+18.*XG**2+16.*XG**3) & - 6.*YG**2*XG*(1.+2.*XG) + YG**3*(1.+4.*XG) ) / & ( XG*(YG-1.-XG) ) RETURN END +EOD +DECK,KKGF2 REAL FUNCTION KKGF2(S,T,M2) REAL S,T,M2 REAL XG,YG XG = T/S YG = M2/S KKGF2 = & ( -4.*XG*(1.+XG**2) + YG*(1.+XG)*(1.+8.*XG+XG**2) - & 3.*YG**2*(1.+4.*XG+XG**2) + 4.*YG**3*(1.+XG) - 2.*YG**4 ) / & ( XG*(YG-1.-XG) ) RETURN END +EOD +DECK,KKGF3 REAL FUNCTION KKGF3(S,T,M2) REAL S,T,M2 REAL XG,YG XG = T/S YG = M2/S KKGF3 = & ( 1. + 2.*XG + 3.*XG**2 + 2.*XG**3 + XG**4 - 2.*YG*(1.+XG**3) & + 3.*YG**2*(1.+XG**2) - 2.*YG**3*(1.+XG) + YG**4 ) / & ( XG*(YG-1.-XG) ) RETURN END +EOD +DECK,LABEL. FUNCTION LABEL(ID) C C Return the CHARACTER*8 label for the particle ID. C Quark-based IDENT code. C MSSM names for squarks, sleptons, Higgs bosons. C C Ver. 7.49: Offset of INDEX must match that in FLAVOR. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QLMASS +CDE,SSTYPE C +SELF,IF=LEVEL2. C DUMMY COMMON BLOCK TO ALLOW LEVEL2 STORAGE. COMMON/XLABEL/LLEP,LMES0,LMES1,LBAR0,LABAR0,LBAR1,LABAR1,LQQ,LAQQ LEVEL2,/XLABEL/ +SELF. INTEGER ID CHARACTER*8 LABEL CHARACTER*8 LLEP,LMES0,LMES1,LBAR0,LABAR0,LBAR1,LABAR1 CHARACTER*8 LQQ,LAQQ DIMENSION LLEP(149) DIMENSION LMES0(64),LMES1(64) DIMENSION LBAR0(109),LABAR0(109),LBAR1(109),LABAR1(109) DIMENSION LQQ(21),LAQQ(21) INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,I,J,IDABS C C Diquark labels C DATA LQQ/ 1'UU0. ','UD0. ','DD0. ','US0. ','DS0. ','SS0. ','UC0. ','DC0. ', 2'SC0. ','CC0. ','UB0. ','DB0. ','SB0. ','CB0. ','BB0. ','UT0. ', 3'DT0. ','ST0. ','CT0. ','BT0. ','TT0. '/ DATA LAQQ/ 1'AUU0.','AUD0.','ADD0.','AUS0.','ADS0.','ASS0.','AUC0.','ADC0.', 2'ASC0.','ACC0.','AUB0.','ADB0.','ASB0.','ACB0.','ABB0.','AUT0.', 3'ADT0.','AST0.','ACT0.','ABT0.','ATT0.'/ C C Quark and lepton labels C DATA LLEP/ $' ','UP ','UB ','DN ','DB ','ST ','SB ','CH ', $'CB ','BT ','BB ','TP ','TB ','Y ','YB ','X ', $'XB ','GL ','ERR ','GM ','ERR ','NUE ','ANUE ','E- ', $'E+ ','NUM ','ANUM ','MU- ','MU+ ','NUT ','ANUT ','TAU- ', $'TAU+ ','ERR ','ERR ','ERR ','ERR ','ERR ','ERR ','KS ', $'ERR ','ERR ','KL ', $'UPL ','UBL ','DNL ','DBL ','STL ','SBL ','CHL ','CBL ', $'BT1 ','BB1 ','TP1 ','TB1 ','ERR ','ERR ','ERR ','ERR ', $'GLSS ','ERR ','Z1SS ','ERR ','NUEL ','ANUEL','EL- ','EL+ ', $'NUML ','ANUML','MUL- ','MUL+ ','NUTL ','ANUTL','TAU1-','TAU1+', $'ERR ','ERR ','ERR ','ERR ','W1SS+','W1SS-','Z2SS ','ERR ', $'UPR ','UBR ','DNR ','DBR ','STR ','SBR ','CHR ','CBR ', $'BT2 ','BB2 ','TP2 ','TB2 ','ERR ','ERR ','ERR ','ERR ', $'W2SS+','W2SS-','Z3SS ','ERR ','NUER ','ANUER','ER- ','ER+ ', $'NUMR ','ANUMR','MUR- ','MUR+ ','NUTR ','ANUTR','TAU2-','TAU2+', $'ERR ','ERR ','ERR ','ERR ','ERR ','ERR ','Z4SS ','ERR ', $'W+ ','W- ','HIGGS','ERR ','HL0 ','ERR ','HH0 ','ERR ', $'HA0 ','ERR ','H40 ','AH40 ','H+ ','H- ','H2+ ','H2- ', $'H1++ ','H1-- ','H2++ ','H2-- ','Z0 ','ERR ','GVSS ','ERR ', $'GRAV ','ERR '/ C C 0- meson labels C DATA LMES0/ 1'PI0 ','PI+ ','ETA ','PI- ','K+ ','K0 ','ETAP ','AK0 ', 2'K- ','AD0 ','D- ','DS- ','ETAC ','DS+ ','D+ ','D0 ', 2'B+ ','B0 ','BS ','BC ','ETAB ','ABC ','ABS ','AB0 ', 3'B- ','UT. ','DT. ','ST. ','CT. ','BT. ','TT. ','TB. ', 4'TC. ','TS. ','TD. ','TU. ','UY. ','DY. ','SY. ','CY. ', 5'BY. ','TY. ','YY. ','YT. ','YB. ','YC. ','YS. ','YD. ', 6'YU. ','UX. ','DX. ','SX. ','CX. ','BX. ','TX. ','YX. ', 7'XX. ','XY. ','XT. ','XB. ','XC. ','XS. ','XD. ','XU. '/ C C 1- meson labels C DATA LMES1/ 1'RHO0 ','RHO+ ','OMEG ','RHO- ','K*+ ','K*0 ','PHI ','AK*0 ', 2'K*- ','AD*0 ','D*- ','DS*- ','JPSI ','DS*+ ','D*+ ','D*0 ', 3'B*+ ','B*0 ','BS* ','BC* ','UPSL ','ABC* ','ABS* ','AB0* ', 4'B*- ','UT* ','DT* ','ST* ','CT* ','BT* ','TT* ','TB* ', 5'TC* ','TS* ','TD* ','TU* ','UY* ','DY* ','SY* ','CY* ', 6'BY* ','TY* ','YY* ','YT* ','YB* ','YC* ','YS* ','YD* ', 7'YU* ','UX* ','DX* ','SX* ','CX* ','BX* ','TX* ','YX* ', 8'XX* ','XY* ','XT* ','XB* ','XC* ','XS* ','XD* ','XU* '/ C C 1/2+ baryon labels C DATA LBAR0/ 1'ERR ','P ','N ','ERR ','ERR ','S+ ','S0 ','S- ', 2'L ','XI0 ','XI- ','ERR ','ERR ','ERR ','SC++ ','SC+ ', 3'SC0 ','LC+ ','USC. ','DSC. ','SSC. ','SDC. ','SUC. ','UCC. ', 4'DCC. ','SCC. ','ERR ','ERR ','ERR ','ERR ','UUB. ','UDB. ', 5'DDB. ','DUB. ','USB. ','DSB. ','SSB. ','SDB. ','SUB. ','UCB. ', 6'DCB. ','SCB. ','CCB. ','CSB. ','CDB. ','CUB. ','UBB. ','DBB. ', 7'SBB. ','CBB. ','ERR ','ERR ','ERR ','ERR ','ERR ','UUT. ', 8'UDT. ','DDT. ','DUT. ','UST. ','DST. ','SST. ','SDT. ','SUT. ', 9'UCT. ','DCT. ','SCT. ','CCT. ','CST. ','CDT. ','CUT. ','UBT. ', 1'DBT. ','SBT. ','CBT. ','BBT. ','BCT. ','BST. ','BDT. ','BUT. ', 2'UTT. ','DTT. ','STT. ','CTT. ','BTT. ','ERR ','ERR ','ERR ', 3'ERR ','ERR ','ERR ','UUY. ','UDY. ','DDY. ','DUY. ','USY. ', 4'DSY. ','SSY. ','SDY. ','SUY. ','UUX. ','UDX. ','DDX. ','DUX. ', 5'USX. ','DSX. ','SSX. ','SDX. ','SUX. '/ DATA LABAR0/ 1'ERR ','AP ','AN ','ERR ','ERR ','AS- ','AS0 ','AS+ ', 2'AL ','AXI0 ','AXI+ ','ERR ','ERR ','ERR ','ASC--','ASC- ', 3'ASC0 ','ALC- ','AUSC.','ADSC.','ASSC.','ASDC.','ASUC.','AUCC.', 4'ADCC.','ASCC.','ERR ','ERR ','ERR ','ERR ','AUUB.','AUDB.', 5'ADDB.','ADUB.','AUSB.','ADSB.','ASSB.','ASDB.','ASUB.','AUCB.', 6'ADCB.','ASCB.','ACCB.','ACSB.','ACDB.','ACUB.','AUBB.','ADBB.', 7'ASBB.','ACBB.','ERR ','ERR ','ERR ','ERR ','ERR ','AUUT.', 8'AUDT.','ADDT.','ADUT.','AUST.','ADST.','ASST.','ASDT.','ASUT.', 9'AUCT.','ADCT.','ASCT.','ACCT.','ACST.','ACDT.','ACUT.','AUBT.', 1'ADBT.','ASBT.','ACBT.','ABBT.','ABCT.','ABST.','ABDT.','ABUT.', 2'AUTT.','ADTT.','ASTT.','ACTT.','ABTT.','ERR ','ERR ','ERR ', 3'ERR ','ERR ','ERR ','AUUY.','AUDY.','ADDY.','ADUY.','AUSY.', 4'ADSY.','ASSY.','ASDY.','ASUY.','AUUX.','AUDX.','ADDX.','ADUX.', 5'AUSX.','ADSX.','ASSX.','ASDX.','ASUX.'/ C C 3/2+ baryon labels C DATA LBAR1/ 1'DL++ ','DL+ ','DL0 ','DL- ','ERR ','S*+ ','S*0 ','S*- ', 2'ERR ','XI*0 ','XI*- ','OM- ','ERR ','ERR ','UUC* ','UDC* ', 3'DDC* ','ERR ','USC* ','DSC* ','SSC* ','ERR ','ERR ','UCC* ', 4'DCC* ','SCC* ','CCC* ','ERR ','ERR ','ERR ','UUB* ','UDB* ', 5'DDB* ','ERR ','USB* ','DSB* ','SSB* ','ERR ','ERR ','UCB* ', 6'DCB* ','SCB* ','CCB* ','ERR ','ERR ','ERR ','UBB* ','DBB* ', 7'SBB* ','CBB* ','BBB* ','ERR ','ERR ','ERR ','ERR ','UUT* ', 8'UDT* ','DDT* ','ERR ','UST* ','DST* ','SST* ','ERR ','ERR ', 9'UCT* ','DCT* ','SCT* ','CCT* ','ERR ','ERR ','ERR ','UBT* ', 1'DBT* ','SBT* ','CBT* ','BBT* ','ERR ','ERR ','ERR ','ERR ', 2'UTT* ','DTT* ','STT* ','CTT* ','BTT* ','TTT* ','ERR ','ERR ', 3'ERR ','ERR ','ERR ','UUY* ','UDY* ','DDY* ','ERR ','USY* ', 4'DSY* ','SSY* ','ERR ','ERR ','UUX* ','UDX* ','DDX* ','ERR ', 5'USX* ','DSX* ','SSX* ','ERR ','ERR '/ DATA LABAR1/ 1'ADL--','ADL- ','ADL0 ','ADL+ ','ERR ','AS*- ','AS*0 ','AS*+ ', 2'ERR ','AXI*0','AXI*+','AOM+ ','ERR ','ERR ','AUUC*','AUDC*', 3'ADDC*','ERR ','AUSC*','ADSC*','ASSC*','ERR ','ERR ','AUCC*', 4'ADCC*','ASCC*','ACCC*','ERR ','ERR ','ERR ','AUUB*','AUDB*', 5'ADDB*','ERR ','AUSB*','ADSB*','ASSB*','ERR ','ERR ','AUCB*', 6'ADCB*','ASCB*','ACCB*','ERR ','ERR ','ERR ','AUBB*','ADBB*', 7'ASBB*','ACBB*','ABBB*','ERR ','ERR ','ERR ','ERR ','AUUT*', 8'AUDT*','ADDT*','ERR ','AUST*','ADST*','ASST*','ERR ','ERR ', 9'AUCT*','ADCT*','ASCT*','ACCT*','ERR ','ERR ','ERR ','AUBT*', 1'ADBT*','ASBT*','ACBT*','ABBT*','ERR ','ERR ','ERR ','ERR ', 2'AUTT*','ADTT*','ASTT*','ACTT*','ABTT*','ATTT*','ERR ','ERR ', 3'ERR ','ERR ','ERR ','AUUY*','AUDY*','ADDY*','ERR ','AUSY*', 4'ADSY*','ASSY*','ERR ','ERR ','AUUX*','AUDX*','ADDX*','ERR ', 5'AUSX*','ADSX*','ASSX*','ERR ','ERR '/ C C Entry C LABEL='ERR' IDABS=IABS(ID) IF(IDABS.EQ.0) THEN LABEL=' ' RETURN ENDIF CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX) IF(INDEX.LE.0) RETURN IF(IDABS.GT.10000.OR.JSPIN.GT.1) GO TO 500 IF(IDABS.LT.100) GO TO 200 IF(IDABS.LT.1000) GO TO 100 IF(ID.NE.0.AND.MOD(ID,100).EQ.0) GO TO 300 C C Baryons C INDEX=INDEX-109*JSPIN-36*NMES-NQLEP INDEX=INDEX-13 IF(JSPIN.EQ.0.AND.ID.GT.0) LABEL=LBAR0(INDEX) IF(JSPIN.EQ.0.AND.ID.LT.0) LABEL=LABAR0(INDEX) IF(JSPIN.EQ.1.AND.ID.GT.0) LABEL=LBAR1(INDEX) IF(JSPIN.EQ.1.AND.ID.LT.0) LABEL=LABAR1(INDEX) GO TO 999 C C Mesons C 100 CONTINUE I=MAX0(IFL2,IFL3) J=-MIN0(IFL2,IFL3) INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0) IF(JSPIN.EQ.0) LABEL=LMES0(INDEX) IF(JSPIN.EQ.1) LABEL=LMES1(INDEX) GO TO 999 C C Quarks, leptons, etc. C 200 CONTINUE INDEX=2*INDEX IF(ID.LE.0) INDEX=INDEX+1 LABEL=LLEP(INDEX) GO TO 999 300 I=IABS(IFL1) J=IABS(IFL2) INDEX=I+J*(J-1)/2 IF(ID.GT.0) LABEL=LQQ(INDEX) IF(ID.LT.0) LABEL=LAQQ(INDEX) RETURN C C Special hadrons - used only in B decays C 500 CONTINUE IF(ID.EQ.10121) THEN LABEL='A1+' ELSEIF(ID.EQ.-10121) THEN LABEL='A1-' ELSEIF(ID.EQ.10111) THEN LABEL='A10' ELSEIF(ID.EQ.10131) THEN LABEL='K1+' ELSEIF(ID.EQ.-10131) THEN LABEL='K1-' ELSEIF(ID.EQ.10231) THEN LABEL='K10' ELSEIF(ID.EQ.-10231) THEN LABEL='AK10' ELSEIF(ID.EQ.30131) THEN LABEL='K1*+' ELSEIF(ID.EQ.-30131) THEN LABEL='K1*-' ELSEIF(ID.EQ.30231) THEN LABEL='K1*0' ELSEIF(ID.EQ.-30231) THEN LABEL='AK1*0' ELSEIF(ID.EQ.132) THEN LABEL='K2*+' ELSEIF(ID.EQ.-132) THEN LABEL='K2*-' ELSEIF(ID.EQ.232) THEN LABEL='K2*0' ELSEIF(ID.EQ.-232) THEN LABEL='AK2*0' ELSEIF(ID.EQ.10110) THEN LABEL='F0' ELSEIF(ID.EQ.112) THEN LABEL='F2' ELSEIF(ID.EQ.10441) THEN LABEL='PSI2' ELSEIF(ID.EQ.20440) THEN LABEL='CHI0' ELSEIF(ID.EQ.20441) THEN LABEL='CHI1' ELSEIF(ID.EQ.20442) THEN LABEL='CHI2' ELSEIF(ID.EQ.IDTAUL) THEN LABEL='TAUL-' ELSEIF(ID.EQ.-IDTAUL) THEN LABEL='TAUL+' ELSEIF(ID.EQ.IDTAUR) THEN LABEL='TAUR-' ELSEIF(ID.EQ.-IDTAUR) THEN LABEL='TAUR+' ELSE LABEL='ERR' ENDIF 999 RETURN END +EOD +DECK,LBOOST. SUBROUTINE LBOOST(PREST,N,P1,P2) C C BOOST 4-VECTORS P1 TO PREST REST FRAME C PUT RESULTING 4-VECTORS IN P2 C +CDE,ITAPES DIMENSION PREST(4),P1(4,N),P2(4,N) DO 1 I=1,N WCN=SQRT(PREST(4)**2-PREST(1)**2-PREST(2)**2-PREST(3)**2) II=(I-1)*4 P2(4,I)=(P1(4,I)*PREST(4)-P1(1,I)*PREST(1)-P1(2,I)*PREST(2) 1 -P1(3,I)*PREST(3))/WCN FACT=(P2(4,I)+P1(4,I))/(WCN+PREST(4)) DO 2 K=1,3 2 P2(K,I)=P1(K,I)-FACT*PREST(K) 1 CONTINUE RETURN END +EOD +DECK,LOGERR. SUBROUTINE LOGERR(IMSG,I,IERR) C C ERROR MESSAGES C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 C C ERRORS IN JET PARAMETERS C IERR=IERR+1 IF(IMSG.EQ.0) WRITE(ITLIS,81) 81 FORMAT(//5X,'DEFAULT LIMITS HAVE BEEN SET') IF(IMSG.EQ.1) WRITE(ITLIS,1001) I,PMIN(I),PMAX(I) 1001 FORMAT(//10X,'BAD LIMITS FOR P(',I2,')=',2E12.4) IF(IMSG.EQ.2) WRITE(ITLIS,1002) I,PTMIN(I),PTMAX(I) 1002 FORMAT(//10X,'BAD LIMITS FOR PT(',I2,')=',2E12.4) IF(IMSG.EQ.3) WRITE(ITLIS,1003) I,THMIN(I),THMAX(I) 1003 FORMAT(//10X,'BAD LIMITS FOR THETA(',I2,')=',2E12.4) IF(IMSG.EQ.4) WRITE(ITLIS,1004) I,XJMIN(I),XJMAX(I) 1004 FORMAT(//10X,'BAD LIMITS FOR X(',I2,')=',2E12.4) IF(IMSG.EQ.5) WRITE(ITLIS,1005) I,XJ(I),P(I) 1005 FORMAT(//5X,'X AND P FOR JET',I2,' ARE INCOMPATIBLE',2E12.4) IF(IMSG.EQ.6) WRITE(ITLIS,1006) I,THMIN(I),THMAX(I) 1006 FORMAT(//10X,'LIMITS FOR THETA MUST BE .GT.0 AND .LT.PI. PRESENT' C ,' LIMITS FOR JET NO.',I3,' ARE',2E12.4) IF(IMSG.EQ.7) WRITE(ITLIS,1007) I,XJ(I),X1,X2 1007 FORMAT(//5X,'FIXED X VALUE FOR JET NO.',I3,' IS',E12.4,2X, C 'THIS IS INCOMPATIBLE WITH ALLOWED X LIMITS',2E12.4) C C ERRORS IN W(Z0) PARAMETERS C IF(IMSG.EQ.101) WRITE(ITLIS,901) XW,XWMIN,XWMAX 901 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED XW',E12.4, C ' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS',2E12.4) IF(IMSG.EQ.102) WRITE(ITLIS,902) YW,YWMIN,YWMAX 902 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED YW', C E12.4,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS ') IF(IMSG.EQ.103) WRITE(ITLIS,903) QMW,QMIN,QMAX 903 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED QMW', C E12.4,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS', C E12.4) IF(IMSG.EQ.104) WRITE(ITLIS,904) XW,YW,QTW 904 FORMAT(//5X,'FIXED VALUES FOR XW,YW,AND QTW',3E12.4, C ' ARE UNPHYSICAL') IF(IMSG.EQ.105) WRITE(ITLIS,905) QTW,QTMIN,QTMAX 905 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED QTW',E12.4 C ,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS',2E12.4) IF(IMSG.EQ.106) WRITE(ITLIS,906) XW,YW,QMW 906 FORMAT(//5X,'FIXED VALUS FOR XW,YW,AND QMW',3E12.4, C ' ARE UNPHYSICAL') IF(IMSG.EQ.107) WRITE(ITLIS,907) QTMIN,QTMAX 907 FORMAT(//5X,'BAD LIMITS FOR QTW',2E12.4) IF(IMSG.EQ.108) WRITE(ITLIS,908) QMIN,QMAX 908 FORMAT(//5X,'BAD LIMITS FOR QMW',2E12.4) IF(IMSG.EQ.109) WRITE(ITLIS,909) THWMIN,THWMAX 909 FORMAT(//5X,'BAD LIMITS FOR THW',2E12.4,2X,' REMEMBER TH MUST', C ' BE IN RADIANS AND LIE BETWEEN 0 AND PI') IF(IMSG.EQ.110) WRITE(ITLIS,910) PHWMIN,PHWMAX 910 FORMAT(//5X,'BAD LIMITS FOR PHW',2E12.4,' ,REMEMBER PHW MUST', C ' BE IN RADIANS AND PHMAX-PHMIN MUST BE LESS THAN 2PI') IF(IMSG.EQ.111) WRITE(ITLIS,911) XWMIN,XWMAX 911 FORMAT(//5X,'BAD LIMITS FOR XW',2E12.4) IF(IMSG.EQ.112) WRITE(ITLIS,912) YWMIN,YWMAX 912 FORMAT(//5X,'BAD LIMITS FOR YW',2E12.4) IF(IMSG.EQ.113) WRITE(ITLIS,913) 913 FORMAT(//5X,'SORRY, BUT YOU CANNOT FIX THETA FOR DRELLYAN EVENTS.' C,' THINK OF SOMETHING ELSE.') IF(IMSG.EQ.114) WRITE(ITLIS,914) 914 FORMAT(//5X,'YOU CANNOT FIX PARAMETERS FOR THE DECAY OF A', C ' DRELL YAN JET') IF(IMSG.EQ.115) WRITE(ITLIS,915) 915 FORMAT(//5X,'YOU CANNOT FIX QTW,QMW,YW AND XW SIMULTANEUOSLY') C C ERRORS IN E+E- PARAMETERS C IF(IMSG.EQ.116) 1WRITE(ITLIS,631) THMIN(1),THMAX(1),THMIN(2),THMAX(2) 631 FORMAT(//10X,'THETA LIMITS',2E12.4,' FOR JET 1 AND',2E12.4 C ,' FOR JET 2 ARE INCOMPATIBLE') C RETURN END +EOD +DECK,LOGIC. SUBROUTINE LOGIC C C 10/ 3/80 C STARTING FROM USER DATA FIND OUT WHICH PARAMETERS SHOULD C BE FIXED AND WHICH LIMITS SHOULD BE SET C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 LOGICAL COMB(8) DIMENSION DELPH(3) C C LOGICAL FUNCTIONS C LOGICAL LOGP,LOGPT,LOGYTH,LOGX,LOGPHI LOGICAL LOGQM,LOGQT,LOGYW,LOGTHW,LOGPHW,LOGXW LOGICAL LOGMIJ,LOGMGM,LOGMGY DATA UNDEF/-.9E9/ DATA ZERO/.00001/,ONE/.99999/ C C INVERSE HYPERBOLIC COSINE FUNCTION ACOSH(X)=ALOG(X+SQRT(X**2-1.0)) C INVERSE HYPERBOLIC SINE FUNCTION ASINH(X)=ALOG(X+SQRT(X**2+1.0)) C C INITIALIZE CONSTANTS C HALFPI=PI/2. IFATAL=0 IERR=0 DO 1 I=1,36 SETLMJ(I)=.TRUE. IF(BLIMS(I).GT.UNDEF) SETLMJ(I)=.FALSE. 1 CONTINUE DO 2 I=1,12 SETLMQ(I)=.TRUE. IF(BLIM1(I).GT.UNDEF) SETLMQ(I)=.FALSE. 2 CONTINUE C C SET STANDARD DRELL-YAN IF FIXED QTW=0. IF(KEYS(3)) THEN IF(QTMIN.EQ.0..AND.QTMAX.LT.UNDEF) THEN STDDY=.TRUE. ELSE STDDY=.FALSE. ENDIF ELSEIF(KEYS(7).OR.KEYS(9)) THEN STDDY=.TRUE. ELSEIF(KEYS(11)) THEN STDDY=.FALSE. ENDIF C IF(STDDY) THEN NJET=2 FIXPT(3)=.TRUE. PT(3)=0. PTMIN(3)=0. PTMAX(3)=0. FIXPHI(3)=.FALSE. PHIMIN(3)=0. PHIMAX(3)=2.*PI DELPH(3)=2.*PI FIXPHW=.TRUE. PHWMIN=0. PHWMAX=-1.E9 PHIW=0. QTMIN=0. QTMAX=-1.E9 QTW=0. FIXQT=.FALSE. ENDIF C C CHECK THAT PARAMETER RANGES MAKE SENSE C C DO LOGIC FOR P IF(.NOT.LOGP(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR PT IF(.NOT.LOGPT(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR THETA AND YJ(RAPIDITY) IF(.NOT.LOGYTH(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR XJ(FEYNMAN X) C XJ LIMITS DO NOT REDEFINE PT LIMITS IF(.NOT.LOGX(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR PHI C NOTE THAT PHI INTERVAL IS DEFINED BY PHIMAX-PHIMIN IF(.NOT.LOGPHI(IERR,DELPH)) IFATAL=IFATAL+1 C C DO LOGIC FOR MADGRAPH IF APPLICABLE IF(KEYS(12)) THEN IF(.NOT.LOGMGM(IERR)) IFATAL=IFATAL+1 IF(.NOT.LOGMGY(IERR)) IFATAL=IFATAL+1 IF(.NOT.LOGMIJ(IERR)) IFATAL=IFATAL+1 ENDIF C C SET DEFAULT PT LIMITS IF NONE WERE SET IF((KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)).AND. $(PTMAX(1).GT..99*HALFE).AND.(PTMAX(2).GT..99*HALFE)) THEN PTMIN(1)=0.1*HALFE PTMIN(2)=PTMIN(1) PTMAX(1)=0.4*HALFE PTMAX(2)=PTMAX(1) CALL LOGERR(0,1,IERR) ENDIF C C CHECK Y LIMITS WITH FINAL PT LIMITS. IF(KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)) THEN YMXPT=ALOG(ECM/PTMIN(1)) DO 11 I=1,2 YJMAX(I)=AMIN1(YJMAX(I),YMXPT) 11 YJMIN(I)=AMAX1(YJMIN(I),-YMXPT) ENDIF C C DO LOGIC FOR DRELL YAN VARIABLES IF(KEYS(3).OR.KEYS(7).OR.KEYS(9).OR.KEYS(11)) THEN C DO LOGIC FOR QM IF(.NOT.LOGQM(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR QT IF(.NOT.LOGQT(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR YW IF(.NOT.LOGYW(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR THETA IF(.NOT.LOGTHW(IERR)) IFATAL=IFATAL+1 C DO LOGIC FOR PHW C NOTE THAT PHW INTERVAL DEFINED BY PHWMAX-PHWMIN IF(.NOT.LOGPHW(IERR,DELPH)) IFATAL=IFATAL+1 C DO LOGIC FOR XW IF(.NOT.LOGXW(IERR)) IFATAL=IFATAL+1 C ENDIF C C CHECK FOR INCONSISTENCIES DO 21 I=1,NJET SMIN=SIN(THMIN(I)) SMAX=SIN(THMAX(I)) IF(SMAX.LT.SMIN) SMIN=SMAX PT1=PMIN(I)*SMIN IF(PT1.GT.PTMIN(I)) PTMIN(I)=PT1 SMAX=1.0 IF(THMAX(I).LT.ONE*HALFPI) SMAX=SIN(ONE*THMAX(I)) IF(THMIN(I).GT.ONE*HALFPI) SMAX=SIN(ONE*THMIN(I)) PT1=PMAX(I)*SMAX IF(PT1.LT.ONE*PTMAX(I)) PTMAX(I)=PT1 IF(PTMAX(I).LT.ONE*PTMIN(I)) CALL LOGERR(2,I,IFATAL) IF(PMAX(I).LT.ONE*PMIN(I)) CALL LOGERR(1,I,IFATAL) IF(THMAX(I).LT.ONE*THMIN(I)) CALL LOGERR(3,I,IFATAL) IF(XJMAX(I).LT.ONE*XJMIN(I)) CALL LOGERR(4,I,IFATAL) IF(ABS(XJMAX(I)).GT.1.0+ZERO.OR.ABS(XJMIN(I)).GT.1.0+ZERO) 1 CALL LOGERR(4,I,IFATAL) IF(THMIN(I).LT.-ZERO.OR.THMAX(I).GT.PI+ZERO) $CALL LOGERR(6,I,IFATAL) C IF(FIXXJ(I)) THEN X1=PMAX(I)*COS(THMIN(I))/HALFE X2=PMIN(I)*COS(THMAX(I))/HALFE X3=PMAX(I)*COS(THMIN(I))/HALFE IF(X3.LT.X2) X2=X3 IF(X1.EQ.X2) XJ(I)=X1 IF(XJ(I).LT.ONE*X2.OR.XJ(I).GT.X1/ONE) CALL LOGERR(7,I,IFATAL) ENDIF C 21 CONTINUE C C CHECK THAT PARAMETERS FOR DRELL YAN ARE CONSISTENT C IF(KEYS(3)) THEN COMB(1)=.FALSE. DO 31 I=1,2 COMB(1)=COMB(1).OR.FIXP(I).OR.FIXPT(I).OR.FIXYJ(I).OR.FIXPHI(I) 1 .OR.FIXXJ(I) 31 CONTINUE IF(COMB(1)) CALL LOGERR(114,1,IFATAL) COMB(1)=FIXQT.AND.FIXQM COMB(2)=FIXQT.AND.FIXYW COMB(3)=FIXQM.AND.FIXYW COMB(4)=COMB(1).AND.FIXYW COMB(5)=COMB(1).AND.FIXXW COMB(6)=COMB(2).AND.FIXXW COMB(7)=COMB(3).AND.FIXXW IF(COMB(4).AND.FIXXW) CALL LOGERR(115,1,IFATAL) IF(COMB(4)) FIXXW=.TRUE. C IF(COMB(4)) THEN FIXXW=.TRUE. XW=SQRT(QTW**2+QMW**2)*SINH(YW)/HALFE IF(XW.LT.XWMIN-ZERO.OR.XW.GT.XWMAX+ZERO) $ CALL LOGERR(101,1,IFATAL) XWMIN=XW XWMAX=XW ENDIF C IF(COMB(5)) THEN FIXYW=.TRUE. YW=ASINH(HALFE*XW/SQRT(QTW**2+QMW**2)) IF(YW.LT.YWMIN-ZERO.OR.YW.GT.YWMAX+ZERO) $CALL LOGERR(102,1,IFATAL) YWMIN=YW YWMAX=YW ENDIF C IF(COMB(6)) THEN IF(XW.NE.0.) THEN QMW2=((XW*HALFE)/SINH(YW))**2-QTW**2 IF(QMW2.GE.0) THEN QMW=SQRT(QMW2) IF(QMW.LT.ONE*QMIN.OR.QMW.GT.QMAX/ONE) $CALL LOGERR(103,1,IFATAL) ENDIF CALL LOGERR(104,1,IFATAL) ENDIF ENDIF C IF(COMB(7).AND.(YW.NE.0)) THEN FIXQT=.TRUE. FIXPT(3)=.TRUE. QTW2=((XW*HALFE)/SINH(YW))**2-QMW**2 IF(QTW2.GE.0) THEN QTW=SQRT(QTW2) PT(3)=QTW IF(QTW.LT.ONE*QTMIN.OR.QTW.GT.QTMAX/ONE) $CALL LOGERR(105,1,IFATAL) ENDIF CALL LOGERR(106,1,IFATAL) ENDIF C IF(QTMIN.GT.QTMAX/ONE) CALL LOGERR(107,1,IFATAL) IF(QMIN.GT.QMAX/ONE) CALL LOGERR(108,1,IFATAL) IF(THWMIN.GT.THWMAX/ONE) CALL LOGERR(109,1,IFATAL) IF(PHWMIN.GT.PHWMAX/ONE) CALL LOGERR(110,1,IFATAL) IF(XWMIN.GT.XWMAX/ONE) CALL LOGERR(111,1,IFATAL) IF(YWMIN.GT.YWMAX+ZERO) CALL LOGERR(112,1,IFATAL) IF(ABS(XWMIN).GT.1.0+ZERO.OR.ABS(XWMAX).GT.1.0+ZERO) 1 CALL LOGERR(111,1,IFATAL) IF(THWMIN.LT.-ZERO.OR.THWMAX.GT.PI+ZERO) $CALL LOGERR(109,1,IFATAL) ENDIF C C SPECIAL LOGIC FOR E+E- EVENTS C IF(KEYS(2)) THEN THLOW=AMAX1(THMIN(1),PI-THMAX(2)) THHIGH=AMAX1(THMAX(1),PI-THMIN(2)) IF(THHIGH-THLOW.LT.ZERO.AND..NOT.(FIXYJ(1).OR.FIXYJ(2))) THEN CALL LOGERR(116,1,IFATAL) ELSE DO 61 I=1,2 FIXYJ(I)=FIXYJ(1).OR.FIXYJ(2) FIXXJ(I)=FIXXJ(1).OR.FIXXJ(2) FIXPT(I)=FIXPT(1).OR.FIXPT(2) THMIN(I)=THLOW THMAX(I)=THHIGH IF(FIXYJ(I)) THMAX(I)=THMIN(I) XJMIN(I)=COS(THMAX(I)) XJMAX(I)=COS(THMIN(I)) PTMIN(I)=HALFE*AMIN1(SIN(THMIN(I)),SIN(THMAX(I))) IF(ABS(XJMAX(I)).LT.1.) YJMAX(I)= 1 .5*ALOG((1.+XJMAX(I))/(1.-XJMAX(I))) IF(ABS(XJMIN(I)).LT.1.) YJMIN(I)= 1 .5*ALOG((1.+XJMIN(I))/(1.-XJMIN(I))) 61 CONTINUE ENDIF ENDIF C C IF(IFATAL.NE.0) THEN WRITE(ITLIS,1020) IFATAL 1020 FORMAT(////10X,I10,' FATAL ERRORS, JOB TERMINATED') STOP 99 ENDIF C C RETURN END +EOD +DECK,LOGMGM. LOGICAL FUNCTION LOGMGM(IERR) C C Set and check limits for multijet mass C C Note we use the convention that not setting an upper limit C gives a fixed variable, even though that currently is not C implemented in N-jet phase space. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 +CDE,MGLIMS C REAL UNDEF INTEGER IERR DATA UNDEF/-.9E9/ C LOGMGM=.TRUE. C IF(EHMGMN.LT.UNDEF.OR.EHMGMX.LT.UNDEF) THEN LOGMGM=.FALSE. ENDIF C RETURN END +EOD +DECK,LOGMGY. LOGICAL FUNCTION LOGMGY(IERR) C C Set and check limits for dijet masses. C C Note we use the convention that not setting an upper limit C gives a fixed variable, even though that currently is not C implemented in N-jet phase space. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 +CDE,MGLIMS C REAL UNDEF INTEGER IERR DATA UNDEF/-.9E9/ C LOGMGY=.TRUE. C C Attempt to fix YHMG C IF(YHMGMN.GT.UNDEF.AND.YHMGMX.LT.UNDEF) THEN LOGMGY=.FALSE. RETURN ENDIF C C No limits C IF(EHMGMN.LT.0.OR.EHMGMX.LT.0) THEN LOGMGY=.FALSE. RETURN ENDIF IF(YHMGMN.LT.UNDEF) THEN YHMGMX=LOG(ECM/EHMGMN) YHMGMN=-YHMGMX ENDIF C RETURN END +EOD +DECK,LOGMIJ. LOGICAL FUNCTION LOGMIJ(IERR) C C Set and check limits for dijet masses. C C Note we use the convention that not setting an upper limit C gives a fixed variable, even though that currently is not C implemented in N-jet phase space. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 +CDE,MGLIMS C REAL AMLOW,UNDEF INTEGER I,J,IERR DATA AMLOW/1.0/ DATA UNDEF/-.9E9/ C LOGMIJ=.TRUE. C DO 100 I=1,MXLIM DO 101 J=I+1,MXLIM FIXMIJ(I,J)=.FALSE. FIXMIJ(J,I)=.FALSE. IF(AMIJMN(I,J).LT.UNDEF.AND.AMIJMX(I,J).LT.UNDEF) THEN AMIJMX(I,J)=ECM AMIJMX(J,I)=ECM ENDIF IF(AMIJMX(I,J).GT.ECM) THEN AMIJMX(I,J)=ECM AMIJMX(J,I)=ECM ENDIF IF(AMIJMX(I,J).LT.UNDEF) THEN AMIJMX(I,J)=AMIJMN(I,J) FIXMIJ(I,J)=.TRUE. AMIJMX(J,I)=AMIJMN(I,J) FIXMIJ(J,I)=.TRUE. ENDIF IF(AMIJMN(I,J).LT.UNDEF) THEN AMIJMN(I,J)=AMLOW AMIJMN(J,I)=AMLOW ENDIF 101 CONTINUE 100 CONTINUE C RETURN END +EOD +DECK,LOGP. LOGICAL FUNCTION LOGP(IERR) C C SET AND CHECK LIMITS FOR JET MOMENTA C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA PLOW/1.0/ DATA UNDEF/-.9E9/ C LOGP=.TRUE. DO 10 I=1,NJET FIXP(I)=.FALSE. IF(PMIN(I).LT.UNDEF.AND.PMAX(I).LT.UNDEF) PMAX(I)=HALFE IF(PMAX(I).GT.HALFE) PMAX(I)=HALFE IF(PMAX(I).LT.UNDEF) FIXP(I)=.TRUE. IF(PMIN(I).LT.UNDEF) PMIN(I)=PLOW IF(FIXP(I)) THEN PMAX(I)=PMIN(I) P(I)=PMIN(I) ENDIF IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0) PMIN(I)=QTMIN 10 CONTINUE C RETURN END +EOD +DECK,LOGPHI. LOGICAL FUNCTION LOGPHI(IERR,DELPH) C C SET AND CHECK LIMITS FOR JET PHI C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DIMENSION DELPH(3) DATA UNDEF/-.9E9/ C LOGPHI=.TRUE. C C DO 50 I=1,NJET FIXPHI(I)=.FALSE. C IF(PHIMAX(I).LT.UNDEF.AND.PHIMIN(I).LT.UNDEF) THEN PHIMIN(I)=0. PHIMAX(I)=2.*PI DELPH(I)=PHIMAX(I) ELSE IF(PHIMAX(I).LT.UNDEF) FIXPHI(I)=.TRUE. C IF(FIXPHI(I)) THEN PHI(I)=PHIMIN(I) PHIMAX(I)=PHIMIN(I) IF(KEYS(3).AND.I.LT.3) THEN LOGPHI=.FALSE. CALL LOGERR(105,I,IERR) ENDIF IF(I.EQ.2) THEN FIXPHI(1)=.TRUE. PHIMIN(1)=PHIMIN(2) PHIMAX(1)=PHIMIN(1) ENDIF ENDIF C DELPH(I)=PHIMAX(I)-PHIMIN(I) C IF(DELPH(I).GT.2.*PI.OR.DELPH(I).LT.0) THEN LOGPHI=.FALSE. CALL LOGERR(8,I,IERR) ENDIF C ENDIF C 50 CONTINUE C C IF(KEYS(1).AND.DELPH(1).GT.DELPH(2)) THEN PHIMIN(1)=PHIMIN(2)+PI PHIMAX(1)=PHIMIN(1)+DELPH(2) ENDIF C RETURN END +EOD +DECK,LOGPHW. LOGICAL FUNCTION LOGPHW(IERR,DELPH) C C SET AND CHECK LIMITS FOR W(Z0) PHI C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DIMENSION DELPH(3) DATA UNDEF/-.9E9/ C LOGPHW=.TRUE. FIXPHW=.FALSE. C IF(FIXPHI(3)) THEN FIXPHW=.TRUE. PHIW=AMOD(PHI(3)+PI,2.*PI) ELSEIF(PHWMIN.LT.UNDEF.AND.PHWMAX.LT.UNDEF) THEN PHWMIN=0. PHWMAX=2.*PI ELSEIF(PHWMAX.LT.UNDEF) THEN FIXPHW=.TRUE. PHW=PHWMIN FIXPHI(3)=.TRUE. PHWMAX=PHWMIN PHI(3)=PHIW+PI PHIMIN(3)=PHIW PHIMAX(3)=PHIW ENDIF C DELPHW=PHWMAX-PHWMIN C IF(DELPHW.LT.0.OR.DELPHW.GT.2.*PI) THEN CALL LOGERR(110,1,IERR) LOGPHW=.FALSE. ENDIF C IF(DELPHW.LE.DELPH(3)) THEN PHIMIN(3)=PHWMIN+PI PHIMAX(3)=PHIMIN(3)+DELPHW ELSE PHWMIN=PHIMIN(3)+PI PHWMAX=PHWMIN+DELPH(3) ENDIF C RETURN END +EOD +DECK,LOGPT. LOGICAL FUNCTION LOGPT(IERR) C C SET AND CHECK LIMITS FOR JET PT C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA PTLOW/1.0/ DATA UNDEF/-.9E9/ C LOGPT=.TRUE. DO 20 I=1,NJET FIXPT(I)=.FALSE. C IF(PTMIN(I).LT.UNDEF.AND.PTMAX(I).LT.UNDEF) THEN PTMAX(I)=PMAX(I) PTMIN(I)=PTLOW IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0.) PTMIN(I)=QTMIN IF(PMIN(I).LT.PTMIN(I)) PMIN(I)=PTMIN(I) ELSEIF(PTMAX(I).LT.UNDEF) THEN FIXPT(I)=.TRUE. PTMAX(I)=PTMIN(I) ELSEIF(PTMIN(I).LT.UNDEF) THEN PTMIN(I)=PTLOW IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0.) PTMIN(I)=QTMIN ENDIF C IF(FIXPT(I)) PTMAX(I)=PTMIN(I) IF(FIXPT(I)) PT(I)=PTMIN(I) IF(PTMAX(I).GT.PMAX(I)) PTMAX(I)=PMAX(I) IF(PMIN(I).LT.PTMIN(I)) PMIN(I)=PTMIN(I) C 20 CONTINUE C RETURN END +EOD +DECK,LOGQM. LOGICAL FUNCTION LOGQM(IERR) C C Set and check limits for gamma*/W/Z0/Higgs mass range C Ver 7.14: Use HMASS+-5*HGAM for MSSM default range C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 +CDE,HCON +CDE,XMSSM C REAL UNDEF INTEGER IERR DATA UNDEF/-.9E9/ C LOGQM=.TRUE. FIXQM=.FALSE. IF(QMIN.LT.UNDEF.AND.QMAX.LT.UNDEF) THEN IF(KEYS(7).AND.GOMSSM) THEN C For MSSM Higgs, set default limits around Higgs QMAX=HMASS+5*HGAM QMIN=HMASS-5*HGAM ELSE C Set default QMW limits if none were set. QMAX=0.2*ECM QMIN=0.05*ECM ENDIF CALL LOGERR(0,1,IERR) ENDIF IF(QMAX.LT.UNDEF) FIXQM=.TRUE. IF(FIXQM) THEN QMW=QMIN QMAX=QMIN ENDIF C RETURN END +EOD +DECK,LOGQT. LOGICAL FUNCTION LOGQT(IERR) C C SET AND CHECK W(Z0) PT RANGE C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA UNDEF/-.9E9/ C LOGQT=.TRUE. FIXQT=.FALSE. IF(QTMIN.LT.UNDEF.AND.QTMAX.LT.UNDEF) THEN QTMAX=PTMAX(3) QTMIN=PTMIN(3) C SET DEFAULT QTW LIMITS IF NONE WERE SET IF(QTMAX.GT.0.99*HALFE) THEN NJET=2 QTMIN=0. QTMAX=0. QTW=0. STDDY=.TRUE. FIXQT=.TRUE. PTMIN(3)=0. PTMAX(3)=0. FIXPT(3)=.TRUE. CALL LOGERR(0,1,IERR) ENDIF ELSEIF(FIXPT(3)) THEN QTW=PT(3) QTMIN=PTMIN(3) QTMAX=QTMIN FIXQT=.TRUE. ELSEIF(QTMAX.LT.UNDEF) THEN FIXQT=.TRUE. QTW=QTMIN QTMAX=QTMIN FIXPT(3)=.TRUE. PT(3)=QTW PTMIN(3)=QTMIN PTMAX(3)=QTMAX ELSE IF(QTMAX.LT.PTMAX(3)) PTMAX(3)=QTMAX IF(QTMIN.GT.PTMIN(3)) PTMIN(3)=QTMIN IF(QTMAX.GT.PTMAX(3)) QTMAX=PTMAX(3) IF(QTMIN.LT.PTMIN(3)) QTMIN=PTMIN(3) ENDIF C RETURN END +EOD +DECK,LOGTHW. LOGICAL FUNCTION LOGTHW(IERR) C C SET AND CHECK THETA LIMITS FOR W(Z0) C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA UNDEF/-.9E9/ C C INVERSE HYPERBOLIC COSINE FUNCTION ACOSH(X)=ALOG(X+SQRT(X**2-1.0)) C INVERSE HYPERBOLIC SINE FUNCTION ASINH(X)=ALOG(X+SQRT(X**2+1.0)) C HALFPI=PI/2. LOGTHW=.TRUE. C IF(THWMIN.LT.UNDEF.AND.THWMAX.LT.UNDEF) THEN THWMIN=2.*ATAN(EXP(-YWMAX)) THWMAX=2.*ATAN(EXP(-YWMIN)) ELSEIF(THWMIN.GT.UNDEF) THEN IF(THWMAX.GT.UNDEF) THEN LOGTHW=.FALSE. CALL LOGERR(113,1,IERR) ELSE TAMIN=TAN(THWMIN) TAMAX=TAN(THWMAX) IF(THWMIN.LT.HALFPI) 1 YWMX=ASINH(QTMAX/SQRT(QTMAX**2+QMIN**2)/TAMIN) IF(THWMIN.GE.HALFPI) 1 YWMX=ASINH(QTMIN/SQRT(QTMIN**2+QMAX**2)/TAMIN) IF(THWMAX.GT.HALFPI) 1 YWMN=ASINH(QTMAX/SQRT(QTMAX**2+QMIN**2)/TAMAX) IF(THWMAX.LT.HALFPI) 1 YWMN=ASINH(QTMIN/SQRT(QTMIN**2+QMAX**2)/TAMAX) IF(YWMIN.LT.YWMN) YWMIN=YWMN IF(YWMAX.GT.YWMX) YWMAX=YWMX IF(FIXYW.AND.(YW.LT.YWMIN.OR.YW.GT.YWMAX)) THEN CALL LOGERR(102,1,IERR) LOGTHW=.FALSE. ENDIF ENDIF ENDIF C IF(YWMIN.LT.0) THWMAX=ATAN2(QTMIN,SQRT(QTMIN**2+QMAX**2)* 1 SINH(YWMIN)) IF(YWMIN.GE.0) THWMAX=ATAN2(QTMAX,SQRT(QTMAX**2+QMIN**2)* 1 SINH(YWMIN)) IF(YWMAX.GE.0) THWMIN=ATAN2(QTMIN,SQRT(QTMIN**2+QMAX**2)* U SINH(YWMAX)) IF(YWMAX.LT.0) THWMIN=ATAN2(QTMAX,SQRT(QTMAX**2+QMIN**2)* 1 SINH(YWMAX)) C RETURN END +EOD +DECK,LOGX. LOGICAL FUNCTION LOGX(IERR) C C SET AND CHECK LIMITS FOR JET FEYNMAN X C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA UNDEF/-.9E9/ C HALFPI=PI/2. LOGX=.TRUE. C DO 40 I=1,NJET FIXXJ(I)=.FALSE. IF(FIXYJ(I).AND.(FIXP(I).OR.FIXPT(I)))FIXXJ(I)=.TRUE. IF(FIXXJ(I)) GOTO 40 C IF(XJMIN(I).LT.UNDEF.AND.XJMAX(I).LT.UNDEF) THEN XJMAX(I)=1.0 XJMIN(I)=-1.0 ENDIF C IF(XJMAX(I).LT.UNDEF) FIXXJ(I)=.TRUE. IF(FIXXJ(I)) XJMAX(I)=XJMIN(I) C IF(.NOT.FIXXJ(I)) THEN IF(THMIN(I).LT.HALFPI) X1=PMAX(I)*COS(THMIN(I))/HALFE IF(THMIN(I).GE.HALFPI) X1=PMIN(I)*COS(THMIN(I))/HALFE IF(THMAX(I).GT.HALFPI) X2=PMAX(I)*COS(THMAX(I))/HALFE IF(THMAX(I).LT.HALFPI) X2=PMIN(I)*COS(THMAX(I))/HALFE IF(X1.LT.XJMAX(I)) XJMAX(I)=X1 IF(X2.GT.XJMIN(I)) XJMIN(I)=X2 ELSE C XJ(I)=XJMIN(I) C IF(FIXP(I)) THEN CTH(I)=XJ(I)*HALFE/P(I) IF(ABS(CTH(I)).LE.1.0) THEN STH(I)=SQRT(1.-CTH(I)**2) TH(I)=ATAN2(STH(I),CTH(I)) YJ(I)=-ALOG(TAN(TH(I)/2.)) FIXYJ(I)=.TRUE. PT(I)=P(I)*STH(I) FIXPT(I)=.TRUE. YJMIN(I)=YJ(I) YJMAX(I)=YJ(I) PTMIN(I)=PT(I) PTMAX(I)=PT(I) ELSE LOGX=.FALSE. CALL LOGERR(5,I,IERR) ENDIF ENDIF C IF(FIXPT(I)) THEN TH(I)=ATAN(PT(I)/XJ(I)/HALFE) FIXYJ(I)=.TRUE. YJ(I)=-ALOG(TAN(TH(I)/2.)) CTH(I)=COS(TH(I)) STH(I)=SIN(TH(I)) P(I)=PT(I)/STH(I) FIXP(I)=.TRUE. YJMIN(I)=YJ(I) YJMAX(I)=YJ(I) PMAX(I)=P(I) PMIN(I)=P(I) ENDIF C IF(FIXYJ(I)) THEN FIXPT(I)=.TRUE. P(I)=XJ(I)*HALFE/CTH(I) PT(I)=P(I)*STH(I) FIXP(I)=.TRUE. PTMIN(I)=PT(I) PTMAX(I)=PT(I) PMAX(I)=P(I) PMIN(I)=P(I) ENDIF C ENDIF C 40 CONTINUE C RETURN END +EOD +DECK,LOGXW. LOGICAL FUNCTION LOGXW(IERR) C C SET AND CHECK X LIMITS FOR W(Z0) C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA UNDEF/-.9E9/ C LOGXW=.TRUE. FIXXW=.FALSE. C IF(XWMIN.LT.UNDEF.AND.XWMAX.LT.UNDEF) THEN XWMIN=-1.0 XWMAX=1.0 ELSEIF(XWMAX.GT.UNDEF) THEN FIXXW=.TRUE. XW=XWMIN XWMAX=XW C IF XW=0 THEN YW=0 IF(XW.NE.0) THEN FIXYW=.TRUE. YW=0 YWMIN=0 YWMAX=0 ENDIF ENDIF C C IF YW=0 THAN XW=0 IF(YW.EQ.0) THEN FIXXW=.TRUE. XW=0 XWMAX=0 ENDIF C RETURN END +EOD +DECK,LOGYTH. LOGICAL FUNCTION LOGYTH(IERR) C C SET AND CHECK LIMITS FOR JET Y AND THETA C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 DATA UNDEF/-.9E9/ C C INVERSE HYPERBOLIC COSINE FUNCTION ACOSH(X)=ALOG(X+SQRT(X**2-1.0)) C INVERSE HYPERBOLIC SINE FUNCTION ASINH(X)=ALOG(X+SQRT(X**2+1.0)) C HALFPI=PI/2. LOGYTH=.TRUE. C DO 30 I=1,NJET FIXYJ(I)=.FALSE. C IF(FIXP(I).AND.FIXPT(I)) THEN STH(I)=PT(I)/P(I) CTHS(1,I)=SQRT(1.-STH(I)**2) CTHS(2,I)=-CTHS(1,I) THS(1,I)=ATAN2(STH(I),CTHS(1,I)) THS(2,I)=ATAN2(STH(I),CTHS(2,I)) YJS(1,I)=-ALOG(TAN(THS(1,I)/2.)) YJS(2,I)=-ALOG(TAN(THS(2,I)/2.)) XJS(1,I)=P(I)*CTHS(1,I)/HALFE XJS(2,I)=P(I)*CTHS(2,I)/HALFE YJMAX(I)=YJS(2,I) THMAX(I)=THS(1,I) THMIN(I)=THS(2,I) IF(YJMIN(I).EQ.YJMAX(I)) FIXYJ(I)=.TRUE. ENDIF C C IF(YJMIN(I).LT.UNDEF.AND.YJMAX(I).LT.UNDEF) THEN C IF(THMIN(I).LT.UNDEF.AND.THMAX(I).LT.UNDEF) THEN YJMAX(I)=ACOSH(HALFE/PTMIN(I)) YJMIN(I)=-YJMAX(I) THMIN(I)=2.*ATAN(EXP(-YJMAX(I))) THMAX(I)=2.*ATAN(EXP(-YJMIN(I))) ENDIF C IF(THMAX(I).LT.UNDEF) FIXYJ(I)=.TRUE. IF(THMIN(I).LT.UNDEF) THMIN(I)=.001 IF(FIXYJ(I)) THMAX(I)=THMIN(I) YJMIN(I)=-ALOG(TAN(THMAX(I)/2.)) YJMAX(I)=-ALOG(TAN(THMIN(I)/2.)) THMIN(I)=2.*ATAN(EXP(-YJMAX(I))) THMAX(I)=2.*ATAN(EXP(-YJMIN(I))) ENDIF C C IF(YJMAX(I).LT.UNDEF) FIXYJ(I)=.TRUE. IF(YJMIN(I).LT.UNDEF) YJMIN(I)=-YJMAX(I) IF(FIXYJ(I)) YJMAX(I)=YJMIN(I) THMIN(I)=2.*ATAN(EXP(-YJMAX(I))) THMAX(I)=2.*ATAN(EXP(-YJMIN(I))) C IF(FIXYJ(I)) THEN YJ(I)=YJMIN(I) TH(I)=THMIN(I) STH(I)=SIN(TH(I)) CTH(I)=COS(TH(I)) IF(FIXPT(I)) P(I)=PT(I)/STH(I) IF(FIXP(I)) PT(I)=P(I)*STH(I) C IF((FIXP(I).OR.FIXPT(I))) THEN XJ(I)=P(I)*CTH(I)/HALFE XJMIN(I)=XJ(I) XJMAX(I)=XJ(I) ENDIF C ENDIF C C CHECK PT LIMITS WITH P AND THETA LIMITS IF(.NOT.FIXPT(I)) THEN THETA1=AMIN1(THMIN(I),PI-THMAX(I)) THETA2=HALFPI IF(THMAX(I).LT.HALFPI) THETA2=THMAX(I) IF(THMIN(I).GT.HALFPI) THETA2=THMIN(I) PT1=PMIN(I)*SIN(THETA1) PTMIN(I)=AMAX1(PTMIN(I),PT1) PT2=PMAX(I)*SIN(THETA2) PTMAX(I)=AMIN1(PTMAX(I),PT2) ENDIF C 30 CONTINUE C RETURN END +EOD +DECK,LOGYW. LOGICAL FUNCTION LOGYW(IERR) C C SET AND CHECK Y LIMITS FOR W(Z0) C +CDE,ITAPES +CDE,JETLIM +CDE,PRIMAR +CDE,JETPAR +CDE,CONST +CDE,DYLIM +CDE,KEYS +CDE,Q1Q2 LOGICAL COMB(2) DATA UNDEF/-.9E9/ C C INVERSE HYPERBOLIC COSINE FUNCTION ACOSH(X)=ALOG(X+SQRT(X**2-1.0)) C INVERSE HYPERBOLIC SINE FUNCTION ASINH(X)=ALOG(X+SQRT(X**2+1.0)) YW=1.0 LOGYW=.TRUE. FIXYW=.FALSE. C IF(YWMIN.LT.UNDEF.AND.YWMAX.LT.UNDEF) THEN YWMAX=ACOSH(HALFE/SQRT(QTMIN**2+QMIN**2)) YWMIN=-YWMAX ENDIF C IF(YWMAX.LT.UNDEF) THEN FIXYW=.TRUE. YW=YWMIN YWMAX=YWMIN ENDIF C YWMX=ACOSH(HALFE/SQRT(QTMIN**2+QMIN**2)) YWMN=-YWMX COMB(1)=YWMX.LT.YWMAX COMB(2)=YWMN.GT.YWMIN C IF(FIXYW.AND.(COMB(1).OR.COMB(2))) THEN LOGYW=.FALSE. CALL LOGERR(102,1,IERR) ENDIF C IF(.NOT.FIXYW) THEN IF(COMB(1)) YWMAX=YWMX IF(COMB(2)) YWMIN=YWMN ENDIF C RETURN END +EOD +DECK,LSTSQ. SUBROUTINE LSTSQ(X,Y,NPT,A,B) C C DO LEAST SQUARE FIT TO A STRAIGHT LINE Y=A+B*X C +CDE,ITAPES DIMENSION X(NPT),Y(NPT) SUM1=0 SUM2=0 SUM3=0 SUM4=0 DO 1 I=1,NPT SUM1=SUM1+X(I) SUM2=SUM2+Y(I) SUM3=SUM3+X(I)**2 SUM4=SUM4+X(I)*Y(I) 1 CONTINUE B=(SUM2*SUM1-SUM4*NPT)/(SUM1**2-SUM3*NPT) A=(SUM2-B*SUM1)/NPT RETURN END +EOD +DECK,MBIAS. SUBROUTINE MBIAS C C Generate minbias event or beam jets for high-pt event using C parameters set in MBSET: C C (1) Select number NPOM of cut pomerons -- cf cut Reggeon C field theory of Abramovskii, Kanchelli, and Gribov. C (2) Generate xf for leading baryons including 1/(1-xf) C diffractive term and guessed NPOM dependence, C F(XF)=(1-XF)**(A+B/NPOM) C (3) Select xf for each half of each Pomeron. then fragment C each half Pomeron into mesons and baryons independently C in the Pomeron-Pomeron center of mass. This avoids C making xf=0 a singular point. C C Note that multiple cut Pomerons give approximate KNO scaling. C The only short-range correlations are from resonances. C C Ver. 7.09: Add traps on free loops and IMPLICIT NONE. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES. +CDE,KEYS. +CDE,MBGEN. +CDE,PRIMAR. +CDE,JETPAR. +CDE,CONST. +CDE,PARTCL. +CDE,MBPAR. C DIMENSION IFL(3),IFLEXC(2),PXEXC(2),PYEXC(2),SIGN(2) DIMENSION PSUM(5) DIMENSION LDIFFR(2) LOGICAL LDIFFR REAL RANF,AMASS REAL RND,XX,XSUM,P0,PPOM,PXEXC,PSUM,SIGN,PYEXC,GAM,BETA,X, $AM,PPLUS,EPSDIF,PEND0,TRY,PX,PY,PX2,PY2,QMINUS,PZ,QPLUS,PT1, $PHI1,XBGEN,PT2,PHI2,PX1,PY1,AMT2 INTEGER ID1,ID2,IFL1,IFL2,IMOD1,IMOD2,ITWIST,IPOM,LOOP,NFIRST, $ID3,IFLEXC,IFL,I,NP2,IP,NP1,IFAIL,NPTLV1,IDHAD,IB,NEW,JSPIN, $INDEX,NBEGIN,IPASS,MXPASS,N,IDIFF,IPASSB,IFLNEW,ISWAP DATA SIGN/1.,-1./,PEND0/.14/ DATA PSUM/5*0./ DATA MXPASS/200/ C C Start NBEGIN=NPTCL+1 IPASS=1 IPASSB=1 C C Select number of cut Pomerons. C 1 CONTINUE TRY=RANF() DO 10 N=MNPOM,MXPOM NPOM=N IF(POMGEN(N).GT.TRY) GO TO 20 10 CONTINUE 20 CONTINUE C C Decide if diffractive event IF(RANF().LT.PDIFFR) THEN IDIFF=INT(1.99999*RANF())+1 LDIFFR(IDIFF)=.TRUE. LDIFFR(3-IDIFF)=.FALSE. ELSE LDIFFR(1)=.FALSE. LDIFFR(2)=.FALSE. ENDIF C C Generate leading baryons. C DO 100 IB=1,2 PPLUS=2.*PBEAM(IB) C C Special treatment for diffractive beam. IF(LDIFFR(IB)) THEN IDHAD=IDIN(IB) AM=AMASS(IDHAD) CALL FLAVOR(IDIN(IB),IFL(1),IFL(2),IFL(3),JSPIN,INDEX) NEW=INT(3.*RANF())+1 IFLEXC(1)=+IFL(NEW) IFLEXC(2)=-IFL(NEW) EPSDIF=2./SCM DXBARY(IB)=EPSDIF**RANF() XBARY(IB)=1.-DXBARY(IB) GO TO 115 ENDIF C C If not diffractive, construct IDENT of leading baryon CALL FLAVOR(IDIN(IB),IFL(1),IFL(2),IFL(3),JSPIN,INDEX) NEW=INT(3.*RANF())+1 IFLNEW=ISIGN(INT(RANF()/PUD0)+1,IDIN(IB)) IFLEXC(1)=IFL(NEW) IFLEXC(2)=-IFLNEW IFL(NEW)=IFLNEW IF(IABS(IFL(1)).GT.IABS(IFL(2))) THEN ISWAP=IFL(1) IFL(1)=IFL(2) IFL(2)=ISWAP ENDIF IF(IABS(IFL(2)).GT.IABS(IFL(3))) THEN ISWAP=IFL(2) IFL(2)=IFL(3) IFL(3)=ISWAP ENDIF IF(IABS(IFL(1)).GT.IABS(IFL(2))) THEN ISWAP=IFL(1) IFL(1)=IFL(2) IFL(2)=ISWAP ENDIF JSPIN=1 IF(IFL(1).EQ.IFL(2).AND.IFL(2).EQ.IFL(3)) THEN JSPIN=1 ELSE JSPIN=INT(RANF()+PJSPN) ENDIF IF(JSPIN.EQ.0.AND.IFL(1).NE.IFL(2).AND.IFL(2).NE.IFL(3)) THEN IF(RANF().GT.PISPN) THEN ISWAP=IFL(1) IFL(1)=IFL(2) IFL(2)=ISWAP ENDIF ENDIF IDHAD=1000*IABS(IFL(1))+100*IABS(IFL(2))+10*IABS(IFL(3))+JSPIN IDHAD=ISIGN(IDHAD,IDIN(IB)) AM=AMASS(IDHAD) C C Select xf for nondiffractive baryon, flat for NPOM=1 and C like mesons for NPOM=infinity. 110 XBGEN=XGEN0(2)*(1.-1./NPOM) DXBARY(IB)=RANF()**(1./(XBGEN+1.)) XBARY(IB)=1.-DXBARY(IB) C C Select transverse momentum of baryon 115 CALL GETPT(PT1,SIGQT0) PHI1=2.*PI*RANF() PX1=PT1*COS(PHI1) PY1=PT1*SIN(PHI1) PXEXC(1)=PX1 PYEXC(1)=PY1 CALL GETPT(PT2,SIGQT0) PHI2=2.*PI*RANF() PX2=PT2*COS(PHI2) PY2=PT2*SIN(PHI2) PXEXC(2)=PX2 PYEXC(2)=PY2 PX=-PX1-PX2 PY=-PY1-PY2 AMT2=PX**2+PY**2+AM**2 C QPLUS=XBARY(IB)*PPLUS QPLUS=AMAX1(QPLUS,1.E-6) QMINUS=AMT2/QPLUS PZ=.5*(QPLUS-QMINUS) P0=.5*(QPLUS+QMINUS) C C Add baryon to /PARTCL/ if PZ>0. IF(NPTCL.GE.MXPTCL) GO TO 9999 IF(PZ.GE.0.) THEN NPTCL=NPTCL+1 PPTCL(1,NPTCL)=PX PPTCL(2,NPTCL)=PY PPTCL(3,NPTCL)=PZ*SIGN(IB) PPTCL(4,NPTCL)=P0 PPTCL(5,NPTCL)=AM IORIG(NPTCL)=0 IDCAY(NPTCL)=0 IDENT(NPTCL)=IDHAD ELSE IPASSB=IPASSB+1 IF(IPASSB.LT.MXPASS) GO TO 110 C Just give up if it fails MXPASS times WRITE(ITLIS,998) 998 FORMAT(//5X,'ERROR IN MBIAS ... COULD NOT MAKE BARYON') XBARY(IB)=0. DXBARY(IB)=1. ENDIF C C Having accepted baryon, set up XPOM array for cut Pomerons, C rescaling to 1.-XBARY(IB). XSUM=0. DO 120 N=1,NPOM XX=RANF() XPOM(N,IB)=XX XSUM=XSUM+XX 120 CONTINUE XSUM=1./XSUM DO 130 N=1,NPOM XPOM(N,IB)=XSUM*XPOM(N,IB)*DXBARY(IB) 130 CONTINUE 100 CONTINUE C C Fragment each Pomeron into mesons and baryon pairs in the C Pomeron-Pomeron center of mass. C DO 1000 IB=1,2 DO 2000 IPOM=1,NPOM PPOM=SQRT(PBEAM(1)*XPOM(IPOM,1)*PBEAM(2)*XPOM(IPOM,2)) PPLUS=2.*PPOM NFIRST=NPTCL+1 LOOP=0 C 200 CONTINUE ITWIST=INT(1.99999*RANF())+1 LOOP=LOOP+1 C C Select new quark or diquark. Old diquark implies new quark. C Old quark implies new diquark with probability PBARY0. IFL1=IFLEXC(ITWIST) IF(MOD(IFL1,100).EQ.0) THEN IFL2=ISIGN(INT(RANF()/PUD0)+1,+IFL1) ELSEIF(RANF().GT.PBARY0) THEN IFL2=ISIGN(INT(RANF()/PUD0)+1,-IFL1) ELSE ID1=INT(RANF()/PUD0)+1 ID2=INT(RANF()/PUD0)+1 IF(IABS(ID1).GT.IABS(ID2)) THEN ISWAP=ID1 ID1=ID2 ID2=ISWAP ENDIF IFL2=ISIGN(1000*ID1+100*ID2,IFL1) ENDIF IFLEXC(ITWIST)=-IFL2 C Construct meson from quark+antiquark. Else, construct baryon C IDENT from quark+diquark. IMOD1=MOD(IFL1,100) IMOD2=MOD(IFL2,100) IF(IMOD1.NE.0.AND.IMOD2.NE.0) THEN JSPIN=INT(RANF()+PJSPN) ID1=IFL1 ID2=IFL2 IF(ID1+ID2.EQ.0) THEN RND=RANF() ID1=IABS(ID1) ID1=INT(PMIX01(ID1,JSPIN+1)+RND) $ +INT(PMIX02(ID1,JSPIN+1)+RND)+1 ID2=-ID1 ELSEIF(IABS(ID1).GT.IABS(ID2)) THEN ISWAP=ID1 ID1=ID2 ID2=ISWAP ENDIF IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1) ELSE IF(IMOD1.EQ.0) THEN ID3=MOD(IFL1/100,10) ID2=IFL1/1000 ID1=IFL2 ELSE ID3=MOD(IFL2/100,10) ID2=IFL2/1000 ID1=IFL1 ENDIF IF(IABS(ID1).GT.IABS(ID2)) THEN ISWAP=ID1 ID1=ID2 ID2=ISWAP ENDIF IF(IABS(ID2).GT.IABS(ID3)) THEN ISWAP=ID2 ID2=ID3 ID3=ISWAP ENDIF IF(IABS(ID1).GT.IABS(ID2)) THEN ISWAP=ID1 ID1=ID2 ID2=ISWAP ENDIF IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) THEN JSPIN=1 ELSE JSPIN=INT(RANF()+PJSPN) ENDIF IF(JSPIN.EQ.0.AND.ID1.NE.ID2.AND.ID2.NE.ID3) THEN IF(RANF().LT.PISPN) THEN ISWAP=ID1 ID1=ID2 ID2=ISWAP ENDIF ENDIF IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN IDHAD=ISIGN(IDHAD,IFL1) ENDIF C AM=AMASS(IDHAD) PX1=PXEXC(ITWIST) PY1=PYEXC(ITWIST) CALL GETPT(PT2,SIGQT0) PHI2=2.*PI*RANF() PX2=PT2*COS(PHI2) PY2=PT2*SIN(PHI2) PXEXC(ITWIST)=PX2 PYEXC(ITWIST)=PY2 PX=PX1-PX2 PY=PY1-PY2 AMT2=PX**2+PY**2+AM**2 C C Select x -- same distribution for all particles. X=RANF() IF(RANF().LT.XGEN0(1)) X=1.-X**(1./(XGEN0(2)+1.)) QPLUS=X*PPLUS QPLUS=AMAX1(QPLUS,1.E-6) QMINUS=AMT2/QPLUS P0=.5*(QPLUS+QMINUS) PZ=.5*(QPLUS-QMINUS) C C Add particle to /PARTCL/ if PZ>0. IF(NPTCL.GE.MXPTCL) GO TO 9999 IF(PZ.GE.0.) THEN NPTCL=NPTCL+1 PPTCL(1,NPTCL)=PX PPTCL(2,NPTCL)=PY PPTCL(3,NPTCL)=PZ*SIGN(IB) PPTCL(4,NPTCL)=P0 PPTCL(5,NPTCL)=AM IORIG(NPTCL)=0 IDCAY(NPTCL)=0 IDENT(NPTCL)=IDHAD ENDIF C C Continue if sufficient pplus PPLUS=(1.-X)*PPLUS IF(PPLUS.GT.PEND0.AND.LOOP.LT.MXPTCL) GO TO 200 C C Boost hadrons to lab frame. IF(NPTCL.LT.NFIRST) GO TO 2000 BETA=(XPOM(IPOM,1)*PBEAM(1)-XPOM(IPOM,2)*PBEAM(2))/(2.*PPOM) GAM=(XPOM(IPOM,1)*PBEAM(1)+XPOM(IPOM,2)*PBEAM(2))/(2.*PPOM) DO 400 IP=NFIRST,NPTCL P0=GAM*PPTCL(4,IP)+BETA*PPTCL(3,IP) PZ=BETA*PPTCL(4,IP)+GAM*PPTCL(3,IP) PPTCL(3,IP)=PZ PPTCL(4,IP)=P0 400 CONTINUE C 2000 CONTINUE 1000 CONTINUE C C Rescale hadron momenta for correct four-momentum. C NPTLV1=NPTCL IF(KEYS(4)) THEN PSUM(4)=ECM PSUM(5)=ECM CALL RESCAL(NBEGIN,NPTLV1,PSUM,IFAIL) ELSE CALL RESCAL(NBEGIN,NPTLV1,PBEAMS,IFAIL) ENDIF IF(IFAIL.NE.0.AND.IPASS.LT.MXPASS) THEN IPASS=IPASS+1 NPTCL=NBEGIN-1 GO TO 1 ENDIF C C Decay hadrons C NP1=NBEGIN 500 NP2=NPTCL DO 510 I=NP1,NP2 CALL DECAY(I) 510 CONTINUE NP1=NP2+1 IF(NP1.LE.NPTCL) GO TO 500 RETURN C 9999 CALL PRTEVT(0) WRITE(ITLIS,999) NPTCL 999 FORMAT(//5X,'ERROR IN MBIAS...NPTCL >',I5) RETURN END +EOD +DECK,MBSET. SUBROUTINE MBSET C C SET PARAMETERS FOR GENERATING MINBIAS EVENTS OR BEAM JETS, C ALLOWING DIFFERENT PARAMETERS FOR TWO CASES. C +CDE,ITAPES +CDE,MBPAR +CDE,MBGEN +CDE,PRIMAR +CDE,TOTALS +CDE,KEYS C C C DN/DY INCREASES WITH LOG(S). INCLUDED IN SPLITTING FUNCTION C BECAUSE AVERAGE MULTIPLICITY COMES FROM SINGLE CHAIN GRAPH. XGEN0(1)=.9 XGEN0(2)=1.+0.35*ALOG(ECM/60.) C C POMWT ARE (RELATIVE) PROBABILITIES FOR N CUT POMERONS. C PDIFFR IS DIFFRACTIVE PROBABILITY. C SIGQT0 IS MEAN PT. IF(KEYS(4)) THEN PDIFFR=.15 SIGQT0=.35 PSUM=0. DO 100 I=1,LIMPOM POMWT(I)=(1.+4.*I**2)*EXP(-1.8*I) PSUM=PSUM+POMWT(I) 100 CONTINUE ELSE PDIFFR=0. SIGQT0=.45 PSUM=0. DO 110 I=1,LIMPOM POMWT(I)=(1.+4.*I**2)*EXP(-1.8*I) PSUM=PSUM+POMWT(I) 110 CONTINUE POMWT(1)=.1*POMWT(1) POMWT(2)=.2*POMWT(2) POMWT(3)=.5*POMWT(3) ENDIF C C RENORMALIZE POMWT. PSUM=1./PSUM DO 200 I=1,LIMPOM POMWT(I)=PSUM*POMWT(I) 200 CONTINUE PSUM=0. DO 210 I=MNPOM,MXPOM PSUM=PSUM+POMWT(I) 210 CONTINUE C C POMGEN IS USED TO SELECT NUMBER OF POMERONS. PGEN=0. PSUM=1./PSUM DO 300 I=1,LIMPOM POMGEN(I)=0. 300 CONTINUE DO 310 I=MNPOM,MXPOM PGEN=PGEN+PSUM*POMWT(I) POMGEN(I)=PGEN 310 CONTINUE POMGEN(MXPOM)=1. C C SET /TOTALS/ FOR MINBIAS EVENTS USING LOG**2(S) FIT TO C TOTAL CROSS SECTION. IF(KEYS(4)) THEN SIGTOT=25.65*(1.+.0102*ALOG(SCM/1.76)**2) SIGTOT=PSUM*SIGTOT NKINPT=NEVENT SUMWT=SIGTOT*NKINPT ENDIF C RETURN END +EOD +DECK,MGINIT SUBROUTINE MGINIT C C Initialize common blocks for MadGraph code in ISAJET C Note the QCD coupling constant is g=1. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C +CDE,ITAPES +CDE,SSTYPE +CDE,MGCOMS C INTEGER I REAL AMGMW REAL*8 SW2 C C Fermion masses and widths C FMASS(1) = AMGMW(IDE,1) FMASS(2) = 0D0 FMASS(3) = AMGMW(IDUP,1) FMASS(4) = AMGMW(IDDN,1) FMASS(5) = AMGMW(IDMU,1) FMASS(6) = 0D0 FMASS(7) = AMGMW(IDCH,1) FMASS(8) = AMGMW(IDST,1) FMASS(9) = AMGMW(IDTAU,1) FMASS(10)= 0D0 FMASS(11)= AMGMW(IDTP,1) FMASS(12)= AMGMW(IDBT,1) DO 100 I=1,12 FWIDTH(I)=0D0 100 CONTINUE C C Boson masses and widths C AMASS=0D0 AWIDTH=0D0 WMASS=AMGMW(IDW,1) WWIDTH=AMGMW(IDW,2) ZMASS=AMGMW(IDZ,1) ZWIDTH=AMGMW(IDZ,2) HMASS=AMGMW(IDH,1) HWIDTH=AMGMW(IDH,2) SW2=AMGMW(1,3) C C Calls to Helas routines to set couplings C CALL COUP1X(SW2,GW,GWWA,GWWZ) CALL COUP2X(SW2,GAL,GAU,GAD,GWF,GZN,GZL,GZU,GZD,G1) CALL COUP3X(SW2,ZMASS,HMASS,GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH) DO 110 I=1,12 CALL COUP4X(SW2,ZMASS,FMASS(I),GCHF(1,I)) 110 CONTINUE C C QCD couplings C G = 1D0 GG(1)=-G GG(2)=-G RETURN END +EOD +DECK,MULJET SUBROUTINE MULJET(WT) C C Using masses from /MGKIN/, generate NJET<=MXJETS body phase C space point satisfying cuts: C (1) Generate kinematic point using successive 2-body decays C with Jacobean C dPhi_N(p1...pN) = dQ1 p1/(4*pi) dPhi_(N-1)(q1...pN) C (2) Apply individual jet cuts from /JETLIM/ and dijet C cuts from /MGLIMS/ to ensure IR-safe cross section. C (3) Return weight WT or 0 if outside limits. C C Note that WT contains various constant factors that were C dropped in DECAY: C 1/(2*SHMG) Jacobean C Jacobean for dQ = (EHMG-SUM)*dRANF C Factors of 4pi C C MadGraph/Helas notation: C PJETS8(0:3,1:2) = initial momenta C PJETS8(0:3,3:NJET+2) = final momenta C Note: ANSI extensions, e.g. REAL*8 P(0:3) are required for C compatibility with Helas and MadGraph. :-( C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. C +CDE,ITAPES +CDE,JETLIM +CDE,MGLIMS +CDE,PJETS +CDE,MGKIN +CDE,PRIMAR C C Local variables; MXJETS defined in /PJETS/ C REAL*8 PGEN(0:3,MXJETS),AMGEN(MXJETS),RND(MXJETS) REAL*8 SHMG,EHMG,YHMG,SUM,SUM1,RNEW,WT,QCM,PI, $U(3),PHI,BETA(3),GAMMA,BP,PTI,PPI,YI,XJI,PHII,AMIJ REAL*8 CYHMG,SYHMG,E1,E2,P12,DELTAQ REAL*8 PCM,A,B,C INTEGER NJET1,I,JJ1,NTRY,J,JSAVE,II,K REAL RANF C C Function definition C PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A) C C C Generate COM mass and rapidity C PI=4.D0*DATAN(1.D0) 100 CONTINUE SHMG=EHMGMN**2+(EHMGMX**2-EHMGMN**2)*RANF() EHMG=SQRT(SHMG) YHMG=YHMGMN+(YHMGMX-YHMGMN)*RANF() IF(EHMG*EXP(ABS(YHMG)).GT.ECM) GO TO 999 IF(EHMG.LT.AMJET8(1)+AMJET8(2)) GO TO 999 CYHMG=DCOSH(YHMG) SYHMG=SINH(YHMG) AMGEN(1)=EHMG PGEN(1,1)=0 PGEN(2,1)=0 PGEN(3,1)=EHMG*SYHMG PGEN(0,1)=EHMG*CYHMG E1=(EHMG**2+AMJET8(1)**2-AMJET8(2)**2)/(2*EHMG) E2=(EHMG**2-AMJET8(1)**2+AMJET8(2)**2)/(2*EHMG) P12=PCM(EHMG,AMJET8(1),AMJET8(2)) C Initial momenta PJETS8(1,1)=0 PJETS8(2,1)=0 PJETS8(3,1)=SYHMG*E1+CYHMG*P12 PJETS8(0,1)=CYHMG*E1+SYHMG*P12 PJETS8(1,2)=0 PJETS8(2,2)=0 PJETS8(3,2)=SYHMG*E1-CYHMG*P12 PJETS8(0,2)=CYHMG*E1-SYHMG*P12 C NJET1=NJET-1 SUM=0 DO 110 I=1,NJET SUM=SUM+AMJET8(I+2) 110 CONTINUE IF(SUM.GE.EHMG) GO TO 999 DELTAQ=EHMG-SUM C C Generate masses for uniform NJET-body phase space. C NTRY=0 200 CONTINUE NTRY=NTRY+1 IF(NTRY.GT.NTRIES) THEN WRITE(ITLIS,9999) NTRY 9999 FORMAT(//2X,'ERROR IN MULJET ... NTRY = ',I8) STOP99 ENDIF RND(1)=1 DO 210 I=2,NJET1 RNEW=RANF() DO 220 JJ1=1,I-1 J=I-JJ1 JSAVE=J+1 IF(RNEW.LE.RND(J)) GO TO 210 RND(JSAVE)=RND(J) 220 CONTINUE 210 RND(JSAVE)=RNEW RND(NJET)=0 C Jacobean for d(shmg)d(yhmg) and overall 1/(2*shmg) WT=(EHMGMX**2-EHMGMN**2)*(YHMGMX-YHMGMN)/(2*SHMG) SUM1=SUM DO 230 I=2,NJET SUM1=SUM1-AMJET8(I-1+2) AMGEN(I)=SUM1+RND(I)*(AMGEN(1)-SUM) IF(AMGEN(I-1).LE.AMGEN(I)+AMJET8(I-1+2)) GO TO 200 C Jacobean for sigma_n -> sigma_n-1 WT=WT*PCM(AMGEN(I-1),AMGEN(I),AMJET8(I-1+2))*DELTAQ/(4*PI**2) 230 CONTINUE C Jacobean for final 2-body decay differs by this factor WT=WT*PI/(DELTAQ*EHMG) C C Carry out 2-body decays C DO 310 I=1,NJET1 QCM=PCM(AMGEN(I),AMGEN(I+1),AMJET8(I+2)) U(3)=2.*RANF()-1 PHI=2*PI*RANF() U(1)=SQRT(1-U(3)**2)*COS(PHI) U(2)=SQRT(1-U(3)**2)*SIN(PHI) DO 320 J=1,3 PJETS8(J,I+2)=QCM*U(J) PGEN(J,I+1)=-PJETS8(J,I+2) 320 CONTINUE PJETS8(0,I+2)=SQRT(QCM**2+AMJET8(I+2)**2) PGEN(0,I+1)=SQRT(QCM**2+AMGEN(I+1)**2) 310 CONTINUE C DO 330 J=0,3 PJETS8(J,NJET+2)=PGEN(J,NJET) 330 CONTINUE C C Boost PGEN frames to lab frame. C DO 400 II=1,NJET1 I=NJET-II DO 410 J=1,3 BETA(J)=PGEN(J,I)/PGEN(0,I) 410 CONTINUE GAMMA=PGEN(0,I)/AMGEN(I) DO 420 K=I,NJET BP=BETA(1)*PJETS8(1,K+2)+BETA(2)*PJETS8(2,K+2)+ $ BETA(3)*PJETS8(3,K+2) DO 430 J=1,3 PJETS8(J,K+2)=PJETS8(J,K+2)+GAMMA*BETA(J)*(PJETS8(0,K+2) $ +BP*GAMMA/(GAMMA+1.)) 430 CONTINUE PJETS8(0,K+2)=GAMMA*(PJETS8(0,K+2)+BP) 420 CONTINUE 400 CONTINUE C C Check limits C DO 500 I=1,NJET PTI=SQRT(PJETS8(1,I+2)**2+PJETS8(2,I+2)**2) IF(PTI.LE.PTMIN(I).OR.PTI.GE.PTMAX(I)) GO TO 999 PPI=SQRT(PTI**2+PJETS8(3,I+2)**2) IF(PPI.LE.PMIN(I).OR.PPI.GE.PMAX(I)) GO TO 999 XJI=PJETS8(3,I+2)/PPI IF(XJI.LE.XJMIN(I).OR.XJI.GE.XJMAX(I)) GO TO 999 PHII=ATAN2(PJETS8(2,I+2),PJETS8(1,I+2)) IF(PHII.LT.0) PHII=PHII+2*PI IF(PHII.LE.PHIMIN(I).OR.PHII.GE.PHIMAX(I)) GO TO 999 YI=-LOG(TAN(ACOS(XJI)/2)) IF(YI.LE.YJMIN(I).OR.YI.GE.YJMAX(I)) GO TO 999 500 CONTINUE C DO 510 I=1,NJET DO 520 J=I+1,NJET AMIJ=(PJETS8(0,I+2)+PJETS8(0,J+2))**2 $ -(PJETS8(1,I+2)+PJETS8(1,J+2))**2 $ -(PJETS8(2,I+2)+PJETS8(2,J+2))**2 $ -(PJETS8(3,I+2)+PJETS8(3,J+2))**2 AMIJ=SIGN(SQRT(ABS(AMIJ)),AMIJ) IF(AMIJ.LE.AMIJMN(I,J).OR.AMIJ.GE.AMIJMX(I,J)) GO TO 999 520 CONTINUE 510 CONTINUE C RETURN C 999 WT=0 RETURN END +EOD +DECK,NOGOOD. LOGICAL FUNCTION NOGOOD(KK) C C Insure proper distribution and check kinematics. C Select jet types. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,KEYS +CDE,WCON +CDE,CONST +CDE,WSIG +CDE,WGEN +CDE,DYLIM +CDE,JETLIM +CDE,JETPAR +CDE,JETSIG +CDE,PTPAR +CDE,HCON +CDE,XMSSM C REAL RANF,SIGINV,SUM,TRY,BRANCH INTEGER KK,I,II,K,IFL C NOGOOD=.TRUE. GO TO (1,2,3,4,5,6),KK C C TWOJET, SUPERSYM, WPAIR or PHOTON events C 1 CONTINUE IF(KEYS(1)) THEN CALL SIGQCD ELSEIF(KEYS(5)) THEN CALL SIGSSY ELSEIF(KEYS(6)) THEN CALL SIGWW ELSEIF(KEYS(8)) THEN CALL SIGGAM ELSEIF(KEYS(10)) THEN CALL SIGWH ENDIF IF(SIGMA.LE.0) RETURN IF(SIGMAX*RANF().GT.SIGMA) RETURN NOGOOD=.FALSE. SIGINV=1./SIGMA SUM=0. TRY=RANF() DO 100 I=1,NSIGS SUM=SUM+SIGS(I)*SIGINV IF(SUM.LT.TRY) GO TO 100 C Find reaction ISIGS=I SIGEVT=SIGS(ISIGS) II=INOUT(I) DO 110 K=1,2 INITYP(K)=MOD(II,IOPAK) 110 II=II/IOPAK DO 120 K=1,2 JETTYP(K)=MOD(II,IOPAK) 120 II=II/IOPAK RETURN 100 CONTINUE RETURN C C DRELLYAN events--test of SIGDY C 2 CONTINUE IF(KEYS(3)) THEN CALL SIGDY ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN CALL SIGH ELSEIF(KEYS(7).AND.GOMSSM) THEN CALL SIGHSS ELSEIF(KEYS(9)) THEN CALL SIGTC ELSEIF(KEYS(11)) THEN CALL SIGKKG ENDIF IF(SIGMA.LE.0.) RETURN IF(SIGSL(KSEL)*RANF().GT.SIGMA) RETURN NOGOOD=.FALSE. SIGINV=1./SIGMA SUM=0. TRY=RANF() C Find reaction. DO 200 I=1,NSIGS SUM=SUM+SIGS(I)*SIGINV IF(SUM.LT.TRY) GO TO 200 ISIGS=I SIGEVT=SIGS(ISIGS) GO TO 210 200 CONTINUE C Unpack INOUT to find JETTYP and INITYP 210 IF(KEYS(3).OR.KEYS(11)) THEN II=INOUT(I) DO 220 K=1,2 INITYP(K)=MOD(II,IOPAK) 220 II=II/IOPAK JWTYP=MOD(II,IOPAK) II=II/IOPAK JETTYP(3)=MOD(II,IOPAK) ELSEIF(KEYS(7).OR.KEYS(9)) THEN II=INOUT(ISIGS) DO 230 I=1,2 INITYP(I)=MOD(II,IOPAK) 230 II=II/IOPAK DO 240 I=1,2 JETTYP(I)=MOD(II,IOPAK) 240 II=II/IOPAK ENDIF RETURN C C DRELLYAN events--test of SIGDY2 C 3 CONTINUE IF(KEYS(3)) THEN CALL SIGDY2 IFL=JETTYP(1)/2 BRANCH=(AQ(IFL,JWTYP)**2+BQ(IFL,JWTYP)**2)/COUT(JWTYP) ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN CALL SIGH2 BRANCH=1. ELSEIF(KEYS(7).AND.GOMSSM) THEN SIGLLQ=SIGMA/(4*PI) NOGOOD=.FALSE. RETURN ELSEIF(KEYS(9)) THEN CALL SIGTC2 BRANCH=1. ENDIF IF(SIGLLQ.GT.SIGS(ISIGS)*BRANCH*3.*RANF()/(4.*PI)) 1NOGOOD=.FALSE. RETURN C C DRELLYAN events--test of kinematics C 4 CONTINUE DO 400 I=1,2 IF(P(I).LT.PMIN(I).OR.P(I).GT.PMAX(I)) GO TO 410 IF(PT(I).LT.PTMIN(I).OR.PT(I).GT.PTMAX(I)) GO TO 410 IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GO TO 410 IF(PHI(I).LT.PHIMIN(I).OR.PHI(I).GT.PHIMAX(I)) GO TO 410 400 CONTINUE NOGOOD=.FALSE. 410 RETURN C 5 CONTINUE 6 CONTINUE RETURN C END +EOD +DECK,ORDECR. SUBROUTINE ORDECR(IA,IB,N) C---------------------------------------------------------------------- C- C- Purpose and Methods : C- return an ordered array (by size of absolute values) C- Warning: input array is destroyed C- C- Inputs : C- IA(N) = input array C- Outputs : C- IB(N) = output ordered array C- C- Created 9-MAY-1988 Serban D. Protopopescu C- C---------------------------------------------------------------------- +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. INTEGER IA(*),IB(*),N,I,J,JSEL C---------------------------------------------------------------------- DO 2 I=1,N JSEL=0 IB(I)=0 DO 1 J=1,N IF(IABS(IA(J)).GT.IABS(IB(I))) THEN IB(I)=IA(J) JSEL=J ENDIF 1 CONTINUE IF(JSEL.GT.0) IA(JSEL)=0 2 CONTINUE 999 RETURN END +EOD +DECK,ORDER. SUBROUTINE ORDER(ID,MODEIN,MODOUT,MEOUT,LPRT) C C Search for mode MODEIN of particle ID in standard /DKYTAB/. C If found, return MODOUT = standard order and MEOUT=MELEM. C Otherwise return MODOUT = MODEIN and MEOUT=0. C If ID<0, use antiparticles instead. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. C +CDE,ITAPES +CDE,DKYTAB +CDE,FORCE C INTEGER ID,MODEIN(5),MODOUT(5),MODTST(5) INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,LOOK0,IUSE(5),ISAME,I,J, $NADD,NADDI,K,K1,K2,IDANTI,MEOUT LOGICAL LPRT C C Find standard starting point C CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX) ISAME=0 IF(LOOK(INDEX).GT.0) THEN LOOK0=LOOK(INDEX) ELSEIF(LOOK(INDEX).LT.0) THEN LOOK0=LOOKST(-LOOK(INDEX)) ELSE GO TO 300 ENDIF C C Find NADD C DO 100 I=1,5 100 IF(MODEIN(I).NE.0) NADD=I C C If ID<0, compare antiparticles C IF(ID.GE.0) THEN DO 110 K=1,NADD 110 MODTST(K)=MODEIN(K) ELSE DO 120 K=1,NADD 120 MODTST(K)=IDANTI(MODEIN(K)) ENDIF C C Scan all modes starting at LOOK0. Check for correct NADD. C Then check that particles match in arbitrary order. C IF(LOOK0.LE.0) GO TO 300 DO 200 I=LOOK0,MXDKY DO 210 K=1,5 210 IF(MODE(K,I).NE.0) NADDI=K IF(NADDI.EQ.NADD) THEN DO 220 K=1,5 220 IUSE(K)=0 C DO 230 K1=1,NADD DO 240 K2=1,NADD IF(MODTST(K1).EQ.MODE(K2,I).AND.IUSE(K2).EQ.0) THEN IUSE(K2)=K1 GO TO 230 ENDIF 240 CONTINUE GO TO 201 230 CONTINUE C ISAME=I GO TO 300 ENDIF 201 IF(CBR(I).GE.1.) THEN ISAME=0 GO TO 300 ENDIF 200 CONTINUE STOP 99 C C Return matching mode or original mode. C 300 IF(ISAME.EQ.0) THEN IF(LPRT) WRITE(ITLIS,3001) 3001 FORMAT(' ***** WARNING: NONSTANDARD MODE') DO 310 K=1,5 310 MODOUT(K)=MODEIN(K) MEOUT=0 ELSEIF(ID.GT.0) THEN DO 320 K=1,5 320 MODOUT(K)=MODE(K,ISAME) MEOUT=MELEM(ISAME) ELSE DO 330 K=1,5 330 MODOUT(K)=IDANTI(MODE(K,ISAME)) MEOUT=MELEM(ISAME) ENDIF C RETURN END +EOD +DECK,PRTEVT. SUBROUTINE PRTEVT(IPRT) C C PRINT THE EVENT STORED IN /PJETS/, /JETSET/, AND /PARTCL/ C IF IPRT IS SELECTED BY NEVPRT AND NJUMP. C IPRT=0 ALWAYS PRINTS EVENT C IPRT<0 PRINTS ONLY JET PARAMETERS C +CDE,ITAPES +CDE,MBGEN +CDE,PJETS +CDE,PINITS +CDE,JETSET +CDE,IDRUN +CDE,JETSIG +CDE,KEYS +CDE,JETPAR +CDE,LSTPRT +CDE,PARTCL +CDE,PRIMAR +CDE,PRTOUT +CDE,WSIG +CDE,SEED. C C LABELS ARE CHARACTER*8 CHARACTER*8 LABEL,LW,LJET,LPTCL INTEGER N0J INTEGER LUX,LUXINT,LUXK1,LUXK2 C C DECIDE WHETHER TO PRINT IF(IPRT.GT.NJUMP*NEVPRT) THEN IF(NJUMP.GT.0) THEN +SELF,IF=NORANLUX IF(MOD(IPRT,NJUMP).EQ.0) WRITE(ITLIS,5) IDG,IEVT,XSEED 5 FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'SEED',2X,A24) +SELF,IF=RANLUX CALL RLUXAT(LUX,LUXINT,LUXK1,LUXK2) IF(MOD(IPRT,NJUMP).EQ.0) WRITE(ITLIS,5) IDG,IEVT,LUXINT, $ LUXK1,LUXK2 5 FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'RANLUX SEEDS', $ 3I12) +SELF ENDIF RETURN ENDIF IF(IPRT.GT.1.AND.MOD(IPRT,NJUMP).NE.0) RETURN IF(IEVT.EQ.LSTPRT) RETURN PI=4.*ATAN(1.) LSTPRT=IEVT C PRINT EVENT NUMBER +SELF,IF=NORANLUX WRITE(ITLIS,10) IDG,IEVT,XSEED 10 FORMAT('1',5X,'RUN ID',2I10.6,5X,'EVENT NO',I8,5X,'SEED',2X,A24) +SELF,IF=RANLUX CALL RLUXAT(LUX,LUXINT,LUXK1,LUXK2) WRITE(ITLIS,10) IDG,IEVT,LUXINT,LUXK1,LUXK2 10 FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'RANLUX SEEDS', $ 3I12) +SELF C C PRINT JET PARAMETERS IF(NJET.EQ.0) GO TO 300 WRITE(ITLIS,20) 20 FORMAT(//20X,'JET PARAMETERS'//3X,'JET',4X,'TYPE ', 18X,'PX',8X,'PY',8X,'PZ',8X,'P0',8X,'PT', 25X,'THETA',7X,'PHI',9X,'X',9X,'Y') IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN LW=LABEL(IDENTW) WRITE(ITLIS,31) LW,(QWJET(K),K=1,4),QTW,THW,PHIW,XW,YW 31 FORMAT(5X,'-',4X,A5,5F10.2,4F10.4) ENDIF IF(KEYS(11)) THEN N0J=3 ELSE N0J=1 ENDIF DO 100 I=N0J,NJET LJET=LABEL(IDJETS(I)) WRITE(ITLIS,30) I,LJET,(PJETS(K,I),K=1,4),PT(I),TH(I),PHI(I), $XJ(I),YJ(I) 30 FORMAT(1X,I5,4X,A5,5F10.2,4F10.4) 100 CONTINUE C PRINT WPAIR DECAY PARAMETERS IF(KEYS(6).OR.KEYS(7).OR.KEYS(10)) THEN IF(NPAIR.NE.0) THEN WRITE(ITLIS,101) 101 FORMAT(//20X,'WPAIR DECAY PARAMETERS'//3X,'JET',4X,'TYPE ', $ 8X,'PX',8X,'PY',8X,'PZ',8X,'P0',8X,'PT', $ 5X,'THETA',7X,'PHI',9X,'X',9X,'Y') DO 102 I=1,NPAIR JET=JPAIR(I) LJET=LABEL(IDPAIR(I)) PTPRT=SQRT(PPAIR(1,I)**2+PPAIR(2,I)**2) THPRT=ACOS(PPAIR(3,I)/SQRT(PTPRT**2+PPAIR(3,I)**2)) PHIPRT=ATAN2(PPAIR(2,I),PPAIR(1,I)) XPRT=2*PPAIR(3,I)/ECM YPRT=-ALOG(TAN(THPRT/2.)) WRITE(ITLIS,30) JET,LJET,(PPAIR(K,I),K=1,4), $ PTPRT,THPRT,PHIPRT,XPRT,YPRT 102 CONTINUE ENDIF ENDIF IF(IPRT.LT.0) RETURN C C PRINT JET CROSS SECTIONS 201 CONTINUE IF(KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)) THEN WRITE(ITLIS,39) SIGEVT 39 FORMAT(//5X,'D(SIGMA)/D(PT**2)D(Y1)D(Y2) = ',E12.4) ENDIF IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN IF(NJET.EQ.3) THEN WRITE(ITLIS,38) LW,QMW,SIGEVT,SIGLLQ 38 FORMAT(//5X,'MASS OF ',A8,' = ',F10.3// C 5X,'D(SIGMA)/D(Q**2)D(QT**2)D(YW)D(YJ) = ',E12.4/ C 5X,'D(SIGMA)/D(Q**2)D(QT**2)D(YW)D(YJ)D(OMEGA) = ',E12.4) ELSE WRITE(ITLIS,37) LW,QMW,SIGEVT,SIGLLQ 37 FORMAT(//5X,'MASS OF ',A8,' = ',F10.3// 1 5X,'D(SIGMA)/D(Q**2)D(YW) =',E12.4/ 2 5X,'D(SIGMA)/D(Q**2)D(YW)D(OMEGA) =',E12.4) ENDIF ENDIF IF(KEYS(2)) THEN WRITE(ITLIS,32) SIGEVT 32 FORMAT(//5X,'D(SIGMA)/D(COS THETA) = ',E12.4) ENDIF C C PRINT /JETSET/ PARAMETERS IF(KEYS(4)) GO TO 300 IF(NJSET.EQ.0) GO TO 300 WRITE(ITLIS,70) 70 FORMAT(//20X,'PARTON CASCADE PARAMETERS'// C 6X,'I',3X,'JET',4X,'ORIG',4X,'TYPE',9X,'DECAY', C 8X,'PX',8X,'PY',8X,'PZ',8X,'P0',6X,'MASS') DO 310 I=1,NJSET JET=JORIG(I)/JPACK I1=MOD(JORIG(I),JPACK) JTLV1=JTYPE(I) LJET=LABEL(JTLV1) J1=JDCAY(I)/JPACK J2=MOD(JDCAY(I),JPACK) IF(JDCAY(I).EQ.0) THEN WRITE(ITLIS,71) I,JET,I1,LJET,(PJSET(K,I),K=1,5) 71 FORMAT(1X,I6,I6,I8,4X,A5,8X,'FINAL',5F10.2) ELSEIF(J1.NE.J2) THEN WRITE(ITLIS,72) I,JET,I1,LJET,J1,J2,(PJSET(K,I),K=1,5) 72 FORMAT(1X,I6,I6,I8,4X,A5,4X,I4,'-',I4,5F10.2) ELSE WRITE(ITLIS,73) I,JET,I1,LJET,(PJSET(K,I),K=1,5) 73 FORMAT(1X,I6,I6,I8,4X,A5,6X,'INITIAL',5F10.2) ENDIF 310 CONTINUE C C PRINT HADRON PARAMETERS 300 IF(NPTCL.EQ.0) RETURN IF(.NOT.KEYS(2)) WRITE(ITLIS,45) NPOM 45 FORMAT(//' NUMBER OF POMERONS =',I5) WRITE(ITLIS,40) 40 FORMAT(//20X,'HADRON PARAMETERS'//7X,'I',3X,'JET',5X,'ORIG' C ,4X,'TYPE',11X,'DECAY',8X,'PX',8X,'PY',8X,'PZ',8X,'P0' C ,8X,'PT',5X,'THETA',7X,'PHI') DO 200 I=1,NPTCL I1=IABS(IORIG(I)) JET=I1/IPACK I1=I1-IPACK*JET I1=ISIGN(I1,IORIG(I)) IDLV1=IDENT(I) LPTCL=LABEL(IDLV1) J1=IDCAY(I)/IPACK J2=MOD(IDCAY(I),IPACK) PTHAD=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2) PHAD=SQRT(PPTCL(3,I)**2+PTHAD**2) PHIHAD=ATAN2(PPTCL(2,I),PPTCL(1,I)) IF(PHIHAD.LT.0.) PHIHAD=2.*PI+PHIHAD THHAD=ACOS(PPTCL(3,I)/PHAD) IF(IDCAY(I).EQ.0) THEN WRITE(ITLIS,50) I,JET,I1,LPTCL,(PPTCL(K,I),K=1,4),PTHAD,THHAD, $ PHIHAD 50 FORMAT(1X,I7,I6,I9,4X,A5,9X,'STABLE',5F10.2,2F10.4) ELSE WRITE(ITLIS,60) I,JET,I1,LPTCL,J1,J2,(PPTCL(K,I),K=1,4), $ PTHAD,THHAD,PHIHAD 60 FORMAT(1X,I7,I6,I9,4X,A5,4X,I5,'-',I5,5F10.2,2F10.4) ENDIF 200 CONTINUE RETURN END +EOD +DECK,PRTLIM. SUBROUTINE PRTLIM C C Print initial conditions and limits for generating jets C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,FORCE +CDE,MBGEN +CDE,QCDPAR +CDE,QLMASS +CDE,WCON +CDE,JETPAR +CDE,KEYS +CDE,KKGRAV +CDE,FRGPAR +CDE,NODCAY +CDE,PRTOUT +CDE,SEED +CDE,TYPES +CDE,Q1Q2 +CDE,JETLIM +CDE,PRIMAR +CDE,PTPAR +CDE,IDRUN +CDE,DYLIM +CDE,HCON +CDE,ISLOOP +CDE,XMSSM +CDE,LUXPAR +CDE,SUGXIN +CDE,SUGMG +CDE,SSPAR +CDE,SUGNU C INTEGER I,J,II,K,NPRT,I1,I2,I3,J1,INDEX,IQ,KK,KKK,NN,N0J REAL AMASS CHARACTER*8 LSTRUC(10),LMODE(5),STUF(6),IDFMT(2) CHARACTER*8 WTITL(4) CHARACTER*8 LABEL,L0 CHARACTER*8 BLANK CHARACTER*40 V,VISAJE REAL AM(6),AML(6) INTEGER NPRSS PARAMETER (NPRSS=32) INTEGER IDPRSS(NPRSS) REAL AMPRSS(NPRSS) CHARACTER*8 LPRSS(NPRSS) REAL ALEMI,AS,TANBQ,PI,MU,B,HIGFRZ C DATA LSTRUC/'OWENS','BAIER','EICHTEN','DUKE','CTEQ2L','CTEQ3L', $'CTEQ5L','???','???','???'/ DATA WTITL/'GM','W+','W-','Z0'/ DATA BLANK/' '/ DATA IDPRSS/21,22,23,24,25,26,41,42,43,44,45,46, $31,32,33,34,35,36,52,54,56, $29,30,40,50,60,39,49,82,83,84,86/ C C Print version PI=4.*ATAN(1.) V=VISAJE() WRITE(ITLIS,1000) V 1000 FORMAT('1',44('*')/' *',42X,'*'/ C ' * ',A40,' *'/ C ' *',42X,'*'/' ',44('*')/) C C Print title, reaction, energy, number, run id WRITE(ITLIS,1010) TITLE 1010 FORMAT(/11X,10A8) WRITE(ITLIS,1020) NJET 1020 FORMAT(/2X,'NUMBER OF JETS TO BE GENERATED PER EVENT',I3) DO 100 I=1,2 IDFMT(I)=LABEL(IDIN(I)) 100 CONTINUE WRITE(ITLIS,1030) IDFMT(1),IDFMT(2),ECM 1030 FORMAT(/2X,A8,' ON ',A8,' AT COM ENERGY',E15.4) WRITE(ITLIS,1040) REAC,NEVENT 1040 FORMAT(/2X,'NUMBER OF ',A8,' EVENTS TO BE GENERATED',I10) IF(NEVPRT.GT.0) WRITE(ITLIS,1050) NEVPRT,NJUMP 1050 FORMAT(/2X,'PRINT A MAXIMUM OF ',I6, C ' EVENTS SKIPPING ',I6,' EVENTS AT A TIME') WRITE(ITLIS,1060) IDG 1060 FORMAT(/2X,'RUN ID ',2I10.6) C C Print W/Higgs parameters C IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN IF(KEYS(3)) THEN II=0 DO 200 I=1,4 IF(.NOT.GODY(I)) GOTO 200 II=II+1 STUF(II)=WTITL(I) 200 CONTINUE ELSEIF(KEYS(11)) THEN II=1 STUF(II)='GRAV' ELSE II=1 STUF(II)='HIGGS' IF(IHTYPE.EQ.82) STUF(II)='HL0' IF(IHTYPE.EQ.83) STUF(II)='HH0' IF(IHTYPE.EQ.84) STUF(II)='HA0' ENDIF WRITE(ITLIS,2000) (STUF(K),K=1,II) 2000 FORMAT(//10X,'PARAMETERS FOR',4(2X,A8)) WRITE(ITLIS,2010) QMIN,QMAX 2010 FORMAT(' MASS LIMITS',15X,2E15.4) WRITE(ITLIS,3020) QTMIN,QTMAX WRITE(ITLIS,3030) THWMIN,THWMAX WRITE(ITLIS,3040) PHWMIN,PHWMAX WRITE(ITLIS,3050) YWMIN,YWMAX WRITE(ITLIS,3060) XWMIN,XWMAX NPRT=0 IF(FIXQT) THEN NPRT=NPRT+1 STUF(NPRT)='QTW ' ENDIF IF(FIXQM) THEN NPRT=NPRT+1 STUF(NPRT)='QMW ' ENDIF IF(FIXYW) THEN NPRT=NPRT+1 STUF(NPRT)='YW ' ENDIF IF(FIXXW) THEN NPRT=NPRT+1 STUF(NPRT)='XW ' ENDIF IF(FIXPHW) THEN NPRT=NPRT+1 STUF(NPRT)='PHW ' ENDIF IF(NPRT.NE.0) WRITE(ITLIS,2070) (STUF(K),K=1,NPRT) ENDIF C C Print jet parameters C DO 300 I=1,6 300 STUF(I)=BLANK IF(KEYS(11)) THEN N0J=3 ELSE N0J=1 ENDIF DO 310 I=N0J,NJET NPRT=0 WRITE(ITLIS,3000) I 3000 FORMAT(//10X,'JET NO.',I3,/) WRITE(ITLIS,3010) PMIN(I),PMAX(I) 3010 FORMAT(' MOMENTUM LIMITS',11X,2E15.4) WRITE(ITLIS,3020) PTMIN(I),PTMAX(I) 3020 FORMAT(' TRANSVERSE MOMENTUM LIMITS',2E15.4) WRITE(ITLIS,3030) THMIN(I),THMAX(I) 3030 FORMAT(' THETA LIMITS',14X,2E15.4) WRITE(ITLIS,3040) PHIMIN(I),PHIMAX(I) 3040 FORMAT(' PHI LIMITS',16X,2E15.4) WRITE(ITLIS,3050) YJMIN(I),YJMAX(I) 3050 FORMAT(' RAPIDITY (Y) LIMITS',7X,2E15.4) WRITE(ITLIS,3060) XJMIN(I),XJMAX(I) 3060 FORMAT(' FEYNMAN X LIMITS',10X,2E15.4) IF(.NOT.GOALL(I)) WRITE(ITLIS,3070) (JETYP(K,I),K=1,NJTTYP(I)) 3070 FORMAT(' JET TYPE',23X,A8,1X,A8,1X,A8,1X,A8,1X,A8) IF((KEYS(6).OR.KEYS(7)).AND..NOT.ALLWW(I)) $ WRITE(ITLIS,3080) (WWTYP(K,I),K=1,NWWTYP(I)) 3080 FORMAT(' DECAY MODES',20X,A8,1X,A8,1X,A8,1X,A8,1X,A8) IF(FIXP(I)) THEN NPRT=NPRT+1 STUF(NPRT)='P ' ENDIF IF(FIXPT(I)) THEN NPRT=NPRT+1 STUF(NPRT)='PT ' ENDIF IF(FIXYJ(I)) THEN NPRT=NPRT+1 STUF(NPRT)='TH ' NPRT=NPRT+1 STUF(NPRT)='Y ' ENDIF IF(FIXPHI(I)) THEN NPRT=NPRT+1 STUF(NPRT)='PHI ' ENDIF IF(FIXXJ(I)) THEN NPRT=NPRT+1 STUF(NPRT)='X ' ENDIF IF(NPRT.EQ.0) GOTO 310 WRITE(ITLIS,2070) (STUF(K),K=1,NPRT) 2070 FORMAT(/5X,'FOLLOWING PARAMETERS HAVE BEEN FIXED ',6A8) 310 CONTINUE C C Print structure functions, QCD parameters, W parameters, C and other parameters changed from their default values. C IF(KEYS(1).OR.KEYS(3).OR.KEYS(5).OR.KEYS(6).OR.KEYS(7) $.OR.KEYS(8).OR.KEYS(9).OR.KEYS(11).OR.KEYS(12)) THEN IF(ISTRUC.GT.0) THEN WRITE(ITLIS,4000) LSTRUC(ISTRUC) 4000 FORMAT(//1X,A8,' STRUCTURE FUNCTIONS') ELSEIF(ISTRUC.EQ.-999) THEN WRITE(ITLIS,4001) 4001 FORMAT(//1X,' PDFLIB STRUCTURE FUNCTIONS') ENDIF ENDIF WRITE(ITLIS,4010) ALAM,CUTJET 4010 FORMAT(//' QCD LAMBDA =',F10.4,10X,'JET CUTOFF MASS =',F10.3) WRITE(ITLIS,4020) AMLEP(6),AMLEP(7),AMLEP(8) 4020 FORMAT(/' HEAVY QUARK MASSES =',3F8.2) IF(LOC(36).NE.0) THEN CALL FLAVOR(80,I1,I2,I3,J1,INDEX) WRITE(ITLIS,4030) (AMLEP(INDEX+K),K=1,9) 4030 FORMAT(/' HIGGS MASSES =',6F8.2/15X,3F8.2) ENDIF C C Supersymmetry C IF(KEYS(5).AND..NOT.GOMSSM) THEN DO 410 IQ=1,6 AM(IQ)=AMASS(20+IQ) AML(IQ)=AMASS(30+IQ) 410 CONTINUE WRITE(ITLIS,4040) (AM(KK),KK=1,6) 4040 FORMAT(//' SQUARK MASSES ',7F9.2) WRITE(ITLIS,4050) (AML(KK),KK=1,6) 4050 FORMAT(' SLEPTON MASSES ',7F9.2) AM(1)=AMASS(29) AM(2)=AMASS(30) AM(3)=AMASS(39) AM(4)=AMASS(40) WRITE(ITLIS,4060) (AM(KK),KK=1,4) 4060 FORMAT(' GAUGINO MASSES (WITH SIGNS) ',7F9.2) IF(LOC(44).NE.0) WRITE(ITLIS,4070) XGENSS(9), $ (XGENSS(KK),KK=1,8) 4070 FORMAT(/' FRAG. PARAM. XGENSS = ',9F8.3) ENDIF C C MSSM model, including SUGRA, GMSB, AMSB C IF(GOMSSM) THEN C Print masses DO 420 I=1,NPRSS LPRSS(I)=LABEL(IDPRSS(I)) AMPRSS(I)=AMASS(IDPRSS(I)) 420 CONTINUE WRITE(ITLIS,4100) (LPRSS(I),AMPRSS(I),I=1,NPRSS) 4100 FORMAT(/' MSSM MASSES (WITHOUT SIGNS):'/ $ 10(' M(',A5,') = ',F10.3,5X,'M(',A5,') = ',F10.3, $ 5X,'M(',A5,') = ',F10.3/), $ ' M(',A5,') = ',F10.3,5X,'M(',A5,') = ',F10.3) C IF(.NOT.(GOSUG.OR.GOGMSB.OR.GOAMSB)) THEN C If weak-scale MSSM, just print other inputs WRITE(ITLIS,4110) XTBSS,XMUSS,XATSS 4110 FORMAT(/' OTHER MSSM PARAMETERS:'/ $ ' TAN(BETA) = ',F10.3,5X,'MU = ',F10.3,5X,'A_t = ',F10.3) ELSE C SUGRA, GMSB, or AMSB model C Printout copied from SUGPRT in ISASUGRA ALEMI=4*PI/GSS(2)**2/SIN2W AS=GSS(3)**2/4./PI TANBQ=VUQ/VDQ WRITE(ITLIS,4120) ALEMI,SIN2W,AS 4120 FORMAT(/' 1/ALPHAEM =',F8.2,2X, $ ' SIN**2(THETAW) =',F7.4,1X,' ALPHAS = ',F5.3) WRITE(ITLIS,4121) GSS(7),GSS(8),GSS(9) 4121 FORMAT(' M1 =',F8.2,2X, $ ' M2 =',F8.2,' M3 =',F8.2) CALL GETPAS(MU,B,HIGFRZ) WRITE(ITLIS,4122) MU,B,HIGFRZ 4122 FORMAT(' MU(Q) =',F8.2,2X, $ ' B(Q) =',F8.2,' Q =',F8.2) WRITE(ITLIS,4123) GSS(13),GSS(14),TANBQ 4123 FORMAT(' M**2(H1) =',E10.3,' M**2(H2) =',E10.3, $ ' TANBQ = ',F6.3) C WRITE(ITLIS,4130) THETAT,THETAB,THETAL,ALFAH 4130 FORMAT(/,' theta_t=',F9.4,' theta_b=',F9.4, $ ' theta_l=',F9.4,' alpha_h=',F9.4) C WRITE(ITLIS,4140) AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS 4140 FORMAT(/' NEUTRALINO MASSES (SIGNED) =',4F10.3) DO 4150 J=1,4 WRITE(ITLIS,4151) J,(ZMIXSS(K,J),K=1,4) 4151 FORMAT(' EIGENVECTOR ',I1,' =',4F10.5) 4150 CONTINUE WRITE(ITLIS,4160) AMW1SS,AMW2SS 4160 FORMAT(/' CHARGINO MASSES (SIGNED) =',2F10.3) WRITE(ITLIS,4161) GAMMAL,GAMMAR 4161 FORMAT(' GAMMAL, GAMMAR =',2F10.5/) ENDIF ENDIF C C Other parameters C IF(LOC(30).NE.0) WRITE(ITLIS,4200) XGEN 4200 FORMAT(/' FRAGMENTATION PARAMETER XGEN =',6F8.3) IF(LOC(31).NE.0) WRITE(ITLIS,4210) SIGQT 4210 FORMAT(/' FRAGMENTATION PARAMETER SIGQT =',F8.3) IF(KEYS(2).OR.KEYS(3).OR.KEYS(6).OR.KEYS(7)) THEN WRITE(ITLIS,4220) SIN2W,WMASS(2),WMASS(4),WGAM(2),WGAM(4) 4220 FORMAT(//' WEINBERG MODEL',5X,'SIN**2(THETA-W)=',F8.4/ $ ' MASSES = ',F8.2,',',F8.2,' WIDTHS = ',F8.3,',',F8.3) ENDIF IF(KEYS(3)) THEN IF(.NOT.STDDY) WRITE(ITLIS,4230) CUTOFF,CUTPOW 4230 FORMAT(/' CUTOFF FUNCTION IS QT**2=',E11.4,'*Q**',E11.4) IF(LOC(50).NE.0) WRITE(ITLIS,4240) WFUDGE 4240 FORMAT(/' W fudge factor (WFUDGE) = ',F8.3) ENDIF IF(KEYS(7)) THEN WRITE(ITLIS,4250) HMASS,HGAM 4250 FORMAT(/' HIGGS MASS = ',F8.2,' WIDTH = ',F8.3) ENDIF +SELF,IF=NORANLUX WRITE(ITLIS,4260) XSEED 4260 FORMAT(/' SEED FOR RANDOM NUMBER GENERATOR = ',A24) +SELF,IF=RANLUX WRITE(ITLIS,4260) LUX 4260 FORMAT(/' RANDOM NUMBER GENERATOR IS RANLUX, LUX=',I5) IF(LUXGO) CALL RLUXGO(LUX,LUXINT,LUXK1,LUXK2) LUXGO=.FALSE. +SELF IF(LOC(13).NE.0) WRITE(ITLIS,4270) FRPAR 4270 FORMAT(//' FRAGMENTATION PARAMETERS ',8E11.3,2(/,26X,8E11.3)) IF(LOC(34).NE.0) WRITE(ITLIS,4280) MNPOM,MXPOM 4280 FORMAT(//' NUMBER OF POMERONS =',I4,' TO',I4) C C Print KKG parameters IF(KEYS(11)) THEN WRITE(ITLIS,4291) NEXTRAD WRITE(ITLIS,4292) MASSD WRITE(ITLIS,4296) SURFD WRITE(ITLIS,4295) KKGSD WRITE(ITLIS,4297) UVCUT 4291 FORMAT(//' NB EXTRA-DIMENSIONS',7X,I4) 4292 FORMAT(' SCALE M_D',15X,E15.4) 4295 FORMAT(' KKGSD FACTOR',12X,E15.4) 4296 FORMAT(' SD SURFACE',14X,E15.4) 4297 FORMAT(' UV CUTOFF',17X,L4) ENDIF C C Decay switches C IF(LOC(46).NE.0) THEN WRITE(ITLIS,4300) 4300 FORMAT(//' SECONDARY W DECAY MODES:') NN=MAX0(NWMODE(1),1) WRITE(ITLIS,4310) (WMODES(KKK,1),KKK=1,NN) 4310 FORMAT(' W+ --> ' $ ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8) NN=MAX0(NWMODE(2),1) WRITE(ITLIS,4320) (WMODES(KKK,2),KKK=1,NN) 4320 FORMAT(' W- --> ' $ ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8) WRITE(ITLIS,4330) (WMODES(KKK,3),KKK=1,NN) 4330 FORMAT(' Z0 --> ' $ ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8) ENDIF C IF(NODCAY) WRITE(ITLIS,4400) 4400 FORMAT(//' NO DECAYS OF HADRONS WILL BE GENERATED') IF(NOETA) WRITE(ITLIS,4410) 4410 FORMAT(//' NO DECAYS OF ETAS WILL BE GENERATED') IF(NOPI0) WRITE(ITLIS,4420) 4420 FORMAT(//' NO DECAYS OF PI0S WILL BE GENERATED') IF(NONUNU) WRITE(ITLIS,4430) 4430 FORMAT(//' NO DECAYS Z0---->NU+NU WILL BE GENERATED') IF(NOEVOL) WRITE(ITLIS,4440) 4440 FORMAT(//' NO QCD JET EVOLUTION WILL BE DONE') IF(NOHADR) WRITE(ITLIS,4450) 4450 FORMAT(//' NO JET HADRONIZATION WILL BE DONE') IF(GOGMSB.AND.NOGRAV) WRITE(ITLIS,4460) 4460 FORMAT(//' NO GRAVITINO DECAYS WILL BE GENERATED') C C Print forced decay modes and M.E. flag C IF(NFORCE.NE.0) THEN WRITE(ITLIS,4500) 4500 FORMAT(//7X,'FORCED DECAY MODES (MATRIX ELEMENT FLAGS)'/ $ 2X,'PART',6X,'DECAY MODE') DO 450 I=1,NFORCE IF(IFORCE(I).EQ.0) GOTO 450 L0=LABEL(IFORCE(I)) DO 451 K=1,5 LMODE(K)=BLANK IF(MFORCE(K,I).EQ.0) GO TO 451 LMODE(K)=LABEL(MFORCE(K,I)) 451 CONTINUE WRITE(ITLIS,4510) L0,(LMODE(K),K=1,5),MEFORC(I) 4510 FORMAT(2X,6A10,'(M.E. =',I5,')') 450 CONTINUE ENDIF C C Print multiple evolution/fragmentation information C IF(NEVOLV.NE.1.OR.NFRGMN.NE.1) THEN WRITE(ITLIS,4600) NEVOLV,NFRGMN 4600 FORMAT(//, $ ' MULTIPLE EVOLUTION AND FRAGMENTATION VERSION'/ $ ' EVENTS WILL BE EVOLVED',I6,' TIMES'/ $ ' AND FRAGMENTED ',I6,' TIMES'/) ENDIF C RETURN END SUBROUTINE GETPAS(XMU,XB,XHGFRZ) C Get parameters from SUGPAS to avoid name clashes +CDE,SUGPAS XMU=MU XB=B XHGFRZ=HIGFRZ RETURN END +EOD +DECK,PTFUN. SUBROUTINE PTFUN C C Calculate an envelope C D(SIGMA)/D(PT**2)D(Y1)D(Y2) < PTFUN1*PT**PTFUN2 C used to generate initial PT values. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,KEYS +CDE,CONST +CDE,JETLIM +CDE,PTPAR +CDE,JETPAR +CDE,JETSIG C REAL PCPY(24) EQUIVALENCE(P(1),PCPY(1)) REAL PTS(51),SIGSAV(51),STOR(24),DPT,DPTMIN,A,B,DEVMAX,DEV REAL DY1,DY2,B1 INTEGER I,NPT,NDIV1,NDIV2,I1,I2 C DATA DPTMIN/0.2/ C C Initialize DO 89 I=1,24 89 STOR(I)=PCPY(I) YJ(1)=0 YJ(2)=0 TH(1)=PI/2. TH(2)=PI/2. STH(1)=1. STH(2)=1. CTH(1)=0. CTH(2)=0. PHI(1)=0. PHI(2)=PI IF(FIXPT(1).OR.FIXPT(2)) GOTO 300 DPT=(PTMAX(1)-PTMIN(1))/25. IF(DPT.LT.DPTMIN) DPT=DPTMIN NPT=(PTMAX(1)-PTMIN(1))/DPT+1 IF(NPT.GT.51) NPT=50 IF(NPT.LE.1) NPT=2 C C Calculate sigma vs PT at Y1=Y2=0 DO 100 I=1,NPT PT(1)=PTMIN(1)+DPT*(I-1) PT(2)=PT(1) P(1)=PT(1) P(2)=PT(2) IF(KEYS(1)) THEN CALL SIGQCD ELSEIF(KEYS(5)) THEN CALL SIGSSY ELSEIF(KEYS(6)) THEN CALL SIGWW ELSEIF(KEYS(8)) THEN CALL SIGGAM ELSEIF(KEYS(10)) THEN CALL SIGWH ENDIF IF(SIGMA.EQ.0.) GO TO 9999 SIGSAV(I)=ALOG(SIGMA) PTS(I)=ALOG(PT(1)) 100 CONTINUE C C Fit to power and shift to get envelope C CALL LSTSQ(PTS,SIGSAV,NPT,A,B) DEVMAX=0. DO 101 I=1,NPT DEV=SIGSAV(I)-A-B*PTS(I) IF(DEV.GT.DEVMAX) DEVMAX=DEV 101 CONTINUE C C Scan in Y1, Y2 for 3 PT values C DO 104 I=1,3 IF(I.EQ.1) PT(1)=PTMIN(1) IF(I.EQ.2) PT(1)=(PTMIN(1)+PTMAX(1))/2. IF(I.EQ.3) PT(1)=PTMAX(1) PT(2)=PT(1) NDIV1=YJMAX(1)-YJMIN(1) IF(NDIV1.GT.20) NDIV1=20 NDIV2=YJMAX(2)-YJMIN(2) IF(NDIV2.GT.20) NDIV2=20 IF(NDIV1.LE.1) NDIV1=2 IF(NDIV2.LE.1) NDIV2=2 DY1=(YJMAX(1)-YJMIN(1))/(NDIV1-1) DY2=(YJMAX(2)-YJMIN(2))/(NDIV2-1) IF(FIXYJ(1)) NDIV1=1 IF(FIXYJ(2)) NDIV2=1 C DO 103 I1=1,NDIV1 YJ(1)=YJMIN(1)+(I1-1)*DY1 CTH(1)=TANH(YJ(1)) STH(1)=SQRT(1.-CTH(1)**2) IF(STH(1).EQ.0) GOTO 103 TH(1)=ACOS(CTH(1)) P(1)=PT(1)/STH(1) C DO 102 I2=1,NDIV2 YJ(2)=YJMIN(2)+(I2-1)*DY2 CTH(2)=TANH(YJ(2)) STH(2)=SQRT(1.-CTH(2)**2) IF(STH(2).EQ.0) GOTO 103 TH(2)=ACOS(CTH(2)) P(2)=PT(2)/STH(2) IF(KEYS(1)) THEN CALL SIGQCD ELSEIF(KEYS(5)) THEN CALL SIGSSY ELSEIF(KEYS(6)) THEN CALL SIGWW ELSEIF(KEYS(8)) THEN CALL SIGGAM ELSEIF(KEYS(10)) THEN CALL SIGWH ENDIF IF(SIGMA.EQ.0.) GO TO 102 DEV=ALOG(SIGMA)-A-B*ALOG(PT(1)) IF(DEV.GT.DEVMAX) DEVMAX=DEV 102 CONTINUE 103 CONTINUE 104 CONTINUE C A=A+DEVMAX B1=B+2. PTFUN1=EXP(A) PTFUN2=B C C Use envelope to generate initial PT values C PTGEN1=PTMIN(1)**B1 PTGEN2=PTMAX(1)**B1-PTGEN1 PTGEN3=1./B1 DO 109 I=1,24 109 PCPY(I)=STOR(I) C C Write envelope parameters on listing C WRITE(ITLIS,200) PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3 200 FORMAT(//10X,'FIT AT Y1=Y2=0 IS D(SIGMA)/D(PT**2)D(Y1)D(Y2)=' C ,E11.5,'*PT**(',E11.5,')'// C 10X,'PT FIRST GENERATED BY PT=(',E11.5,'+',E11.5,'*RANF)**(', C E11.5,')') C RETURN C C Fixed PT C 300 CONTINUE IF(FIXPT(1)) PT(2)=PT(1) IF(FIXPT(2)) PT(1)=PT(2) P(1)=PT(1) P(2)=PT(2) IF(KEYS(1)) THEN CALL SIGQCD ELSEIF(KEYS(5)) THEN CALL SIGSSY ELSEIF(KEYS(6)) THEN CALL SIGWW ELSEIF(KEYS(8)) THEN CALL SIGGAM ELSEIF(KEYS(10)) THEN CALL SIGWH ENDIF SIGMAX=SIGMA DO 301 I=1,24 301 PCPY(I)=STOR(I) C RETURN C C Fit fails if SIGMA=0 in specified range 9999 WRITE(ITLIS,1010) PT(1) 1010 FORMAT(//' ERROR IN PTFUN...SIGMA=0 FOR PT = ',E12.4/ 1' CHECK YOUR LIMITS.') STOP 99 END +EOD +DECK,QCDINI SUBROUTINE QCDINI(JIN1,JIN2) C C GENERATE INITIAL-STATE QCD CASCADE USING BACKWARDS C EVOLUTION OF GOTTSCHALK AND OF SJOSTRAND. C C IF QCDINI FAILS WHEN ATTEMPTING TO FORCE GL-->QK+QB FOR C HEAVY QUARKS, THEN RETURN NJSET=-1. C C VER. 6.40: TRAP W1LIM > 0 TO PREVENT ROUNDING ERRORS. C +CDE,ITAPES +CDE,IDRUN +CDE,PINITS +CDE,JETPAR +CDE,QCDPAR +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,CONST +CDE,PRIMAR +CDE,KEYS C DIMENSION BOOST1(5),BOOST2(5),B2B1(5),DBL1(5),DBL2(5) DIMENSION FXOLD(2),FXNEW(2) DIMENSION PJKEEP(5,12),JINS(2),JLIST(16),PFKEEP(5) +SELF,IF=DOUBLE. DOUBLE PRECISION DBL1,DBL2,DBLM +SELF. C C CONVERT IDENT+7 TO JETTYP DATA JLIST/13,11,9,7,5,3,0,2,4,6,8,10,12,0,0,1/ ALAMF(A,B,C)=SQRT((A-B-C)**2-4.*B*C) C C INITIALIZE C JINS(1)=JIN1 JINS(2)=JIN2 DO 97 K=1,4 97 PFKEEP(K)=PJSET(K,JIN1)+PJSET(K,JIN2) C EXCEPT FOR HIGGS, PFKEEP**2=SHAT IF(KEYS(7).OR.KEYS(9)) THEN S1KEEP=PFKEEP(4)**2-PFKEEP(1)**2-PFKEEP(2)**2-PFKEEP(3)**2 PFKEEP(5)=SQRT(S1KEEP) PPKEEP=PFKEEP(4)+PFKEEP(3) PMKEEP=PFKEEP(4)-PFKEEP(3) ELSE S1KEEP=SHAT PFKEEP(5)=SQRT(S1KEEP) IF(PFKEEP(3).GT.0.) THEN PPKEEP=PFKEEP(4)+PFKEEP(3) PMKEEP=(S1KEEP+PFKEEP(1)**2+PFKEEP(2)**2)/PPKEEP ELSE PMKEEP=PFKEEP(4)-PFKEEP(3) PPKEEP=(S1KEEP+PFKEEP(1)**2+PFKEEP(2)**2)/PMKEEP ENDIF PFKEEP(4)=.5*(PPKEEP+PMKEEP) PFKEEP(3)=.5*(PPKEEP-PMKEEP) ENDIF DO 98 I=1,NJSET DO 98 K=1,5 98 PJKEEP(K,I)=PJSET(K,I) NJKEEP=NJSET NPASS=0 NPASS1=0 C 1 CONTINUE NPASS1=NPASS1+1 IF(NPASS1.GT.100) GO TO 9999 NJSET=NJKEEP DO 99 I=1,NJSET DO 99 K=1,5 99 PJSET(K,I)=PJKEEP(K,I) C DO 100 K=1,5 100 PFINAL(K)=PFKEEP(K) S1=S1KEEP PTOTPL=PPKEEP PTOTMN=PMKEEP TCUT=CUTJET**2 DO 101 I=1,2 JI=JINS(I) XOLD=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM JT=JLIST(JTYPE(JI)+7) FXOLD(I)=STRUC(XOLD,QSQ,JT,IDIN(I)) 101 CONTINUE C C DO FIRST EVOLUTION DO 110 I=1,2 SGN=3-2*I JET=10+I JI=JINS(I) ZMIN=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM ZMAX=1./(1.+TCUT/S1) C DZMAX=1.-ZMAX DZMAX=ZMAX*TCUT/S1 IF(ZMIN.GE.ZMAX) ZMIN=.5*ZMAX CALL QCDINT(JI) JVIR(I)=JI 110 CONTINUE C C SOLVE INITIAL KINEMATICS AM1SQ=PJSET(5,JVIR(1))**2*SIGN(1.,PJSET(5,JVIR(1))) AM2SQ=PJSET(5,JVIR(2))**2*SIGN(1.,PJSET(5,JVIR(2))) P1PL=(S1+AM1SQ-AM2SQ+ALAMF(S1,AM1SQ,AM2SQ))/(2.*PTOTMN) P1MN=AM1SQ/P1PL P2MN=(S1+AM2SQ-AM1SQ+ALAMF(S1,AM1SQ,AM2SQ))/(2.*PTOTPL) P2PL=AM2SQ/P2MN PJSET(3,JVIR(1))=.5*(P1PL-P1MN) PJSET(4,JVIR(1))=.5*(P1PL+P1MN) PJSET(3,JVIR(2))=.5*(P2PL-P2MN) PJSET(4,JVIR(2))=.5*(P2PL+P2MN) C C TEST WHETHER NEW MASS IS PLAUSIBLE DO 111 I=1,2 JI=JINS(I) XNEW=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM IF(XNEW.GE.1.) THEN FXNEW(I)=0. ELSE JT=JLIST(JTYPE(JI)+7) FXNEW(I)=STRUC(XNEW,QSQ,JT,IDIN(I)) ENDIF 111 CONTINUE DO 112 I=1,2 IF(FXNEW(I).LT.FXOLD(I)*RANF()) GO TO 1 112 CONTINUE C C FIND JVIR (SPACE-LIKE PARTON) WITH LARGER (-MASS) FOR NEXT C BRANCHING. 10 IF(JDCAY(JVIR(1)).GE.0.AND.JDCAY(JVIR(2)).GE.0) RETURN NPASS=NPASS+1 IF(NPASS.GT.20*NJSET) GO TO 9999 IF(-PJSET(5,JVIR(1)).GE.-PJSET(5,JVIR(2))) THEN IVIR=JVIR(1) IVIR2=JVIR(2) SGN=+1. JET=11 ELSE IVIR=JVIR(2) IVIR2=JVIR(1) SGN=-1. JET=12 ENDIF C T1=PJSET(5,IVIR)**2 ZMIN=(PJSET(4,IVIR)+SGN*PJSET(3,IVIR))/ECM ZMAX=1./(1.+T1/S1) DZMAX=ZMAX*T1/S1 IF(ZMIN.GE.ZMAX) GO TO 1 C C GENERATE Z AND NEW PARTONS. C NEWV=SPACELIKE, NEWF=TIMELIKE. NEWV=NJSET+1 NEWF=NJSET+2 CALL QCDINZ(IVIR) C C IF Z FAILS (BECAUSE OF STRUCTURE FUNCTION) SET NEWV=IVIR, C NEWF=NULL AND RE-SOLVE KINEMATICS. 15 IF(.NOT.ZGOOD) THEN CALL QCDINT(IVIR) C PP1PL=PJSET(4,IVIR2)+PJSET(3,IVIR2) PP1MN=PJSET(4,IVIR2)-PJSET(3,IVIR2) AMSQ=PJSET(5,IVIR)**2*SIGN(1.,PJSET(5,IVIR)) AMPSQ=PJSET(5,IVIR2)**2*SIGN(1.,PJSET(5,IVIR2)) IF(SGN.GT.0) THEN P2PL=(S1-AMSQ-AMPSQ+ALAMF(S1,AMSQ,AMPSQ))/(2.*PP1MN) P2MN=AMSQ/P2PL ELSE P2MN=(S1-AMSQ-AMPSQ+ALAMF(S1,AMSQ,AMPSQ))/(2.*PP1PL) P2PL=AMSQ/P2MN ENDIF PJSET(3,IVIR)=.5*(P2PL-P2MN) PJSET(4,IVIR)=.5*(P2PL+P2MN) C NEWV=IVIR DO 120 K=1,5 120 PJSET(K,NEWF)=0. GO TO 30 ENDIF C C EVOLVE NEW SPACELIKE PARTON. PJSET(5,NEWV)=PJSET(5,IVIR) S2=S1/ZZC(IVIR) ZMIN=ZMIN/ZZC(IVIR) ZMAX=1./(1.+TCUT/S2) DZMAX=ZMAX*TCUT/S2 IF(ZMIN.GE.ZMAX) GO TO 1 CALL QCDINT(NEWV) C C CALCULATE APPROXIMATE MASS LIMIT AND DO TIMELIKE EVOLUTION. C VER. 6.40: TRAP W1LIM < 0 FROM ROUNDING ERRORS. W1LIM=T1*(1./(ZZC(IVIR)*(1.+T1/S1))-1.) W1LIM=AMIN1(W1LIM,T1) PJSET(5,NEWF)=SQRT(ABS(W1LIM)) JDCAY(NEWF)=-1 20 CALL QCDT(NEWF) C C SOLVE KINEMATICS USING +(PL) AND -(MN) COMPONENTS FOR C PJSET(K,NEWV)+PJSET(K,IVIR2)-->PJSET(K,NEWF)+PFINAL C STEP 1: SOLVE FOR P2=PJSET(K,NEWV) PP1PL=PJSET(4,IVIR2)+PJSET(3,IVIR2) PP1MN=PJSET(4,IVIR2)-PJSET(3,IVIR2) AMSQ=PJSET(5,NEWV)**2*SIGN(1.,PJSET(5,NEWV)) AMPSQ=PJSET(5,IVIR2)**2*SIGN(1.,PJSET(5,IVIR2)) W1=PJSET(5,NEWF)**2 IF(SGN.GT.0) THEN P2PL=(S2-AMSQ-AMPSQ+ALAMF(S2,AMSQ,AMPSQ))/(2.*PP1MN) P2MN=AMSQ/P2PL ELSE P2MN=(S2-AMSQ-AMPSQ+ALAMF(S2,AMSQ,AMPSQ))/(2.*PP1PL) P2PL=AMSQ/P2MN ENDIF C C STEP 2: SOLVE FOR Q1(K)=PJSET(K,IVIR) DEN=P2PL*PP1MN-P2MN*PP1PL Q1PL=(+P2PL*(S1+T1-AMPSQ)+PP1PL*(W1+T1-AMSQ))/DEN Q1MN=(-P2MN*(S1+T1-AMPSQ)-PP1MN*(W1+T1-AMSQ))/DEN WPL=P2PL-Q1PL WMN=P2MN-Q1MN C CALCULATE TRANSVERSE MOMENTUM AND REJECT IF UNPHYSICAL. Q1TR2=T1+Q1PL*Q1MN IF(Q1TR2.LT.0.) THEN IF(JDCAY(NEWF).EQ.-1) GO TO 20 ZGOOD=.FALSE. GO TO 15 ENDIF C C DO ONE TIMELIKE BRANCHING TO INSURE CORRECT MASS. MUST FIRST C SHIFT NJSET TO PUT DECAY PRODUCTS IN CORRECT PLACE. IF(JDCAY(NEWF).EQ.-1) THEN NJSET=NJSET+2 CALL QCDZ(NEWF) NJSET=NJSET-2 Z1=ZZC(NEWF) E0=.5*(WPL+WMN) P0=SQRT(.25*(WPL-WMN)**2+Q1TR2) WM0=PJSET(5,NEWF) ZLIM=AMAX1((WM0/(E0+P0))**2,CUTJET/(E0+P0)) IF(Z1.LE.ZLIM.OR.Z1.GE.1.-ZLIM) GO TO 20 NEWF1=NEWF+1 NEWF2=NEWF+2 JDCAY(NEWF)=NEWF1*JPACK+NEWF2 CALL QCDT(NEWF1) CALL QCDT(NEWF2) JORIG(NEWF1)=JPACK*JET+NEWF JORIG(NEWF2)=JORIG(NEWF1) DO 130 K=1,4 PJSET(K,NEWF1)=0. 130 PJSET(K,NEWF2)=0. ENDIF C C GOOD BRANCHING! PHIQ1=2.*PI*RANF() Q1TR=SQRT(Q1TR2) Q1X=Q1TR*COS(PHIQ1) Q1Y=Q1TR*SIN(PHIQ1) C PJSET(1,IVIR)=Q1X PJSET(2,IVIR)=Q1Y PJSET(3,IVIR)=.5*(Q1PL-Q1MN) PJSET(4,IVIR)=.5*(Q1PL+Q1MN) JDCAY(IVIR)=JPACK*NEWV+NEWF C PJSET(1,NEWV)=0. PJSET(2,NEWV)=0. PJSET(3,NEWV)=.5*(P2PL-P2MN) PJSET(4,NEWV)=.5*(P2PL+P2MN) JORIG(NEWV)=JPACK*JET+IVIR C PJSET(1,NEWF)=-Q1X PJSET(2,NEWF)=-Q1Y PJSET(3,NEWF)=.5*(WPL-WMN) PJSET(4,NEWF)=.5*(WPL+WMN) JORIG(NEWF)=JPACK*JET+IVIR C C BOOST ALL FINAL VECTORS (EXCEPT NEW ONES) AND RECALCULATE C VIRTUAL MOMENTA. BOOST IS DETERMINED BY DIFFERENCE OF C NEW AND OLD TOTAL FINAL MOMENTA, B2B1=BOOST2-BOOST1. C 30 CONTINUE DO 201 K=1,4 201 BOOST1(K)=PFINAL(K) BMASS=PFINAL(5) DO 202 K=1,4 202 BOOST2(K)=PJSET(K,NEWV)+PJSET(K,IVIR2)-PJSET(K,NEWF) C C PARAMETERS FOR COMBINED BOOSTS. +SELF,IF=SINGLE. BDOTB=BOOST1(4)*BOOST2(4)-BOOST1(1)*BOOST2(1)-BOOST1(2)*BOOST2(2) $-BOOST1(3)*BOOST2(3) DO 203 K=1,4 203 B2B1(K)=BOOST2(K)-BOOST1(K) +SELF,IF=DOUBLE. C DOUBLE PRECISION FOR 32-BIT MACHINES USING 3-VECTORS AND MASS C AS EXACT. DO 204 K=1,3 DBL1(K)=BOOST1(K) 204 DBL2(K)=BOOST2(K) DBLM=BMASS DBL1(4)=DSQRT(DBL1(1)**2+DBL1(2)**2+DBL1(3)**2+DBLM**2) DBL2(4)=DSQRT(DBL2(1)**2+DBL2(2)**2+DBL2(3)**2+DBLM**2) BDOTB=DBL1(4)*DBL2(4)-DBL1(1)*DBL2(1)-DBL1(2)*DBL2(2) $-DBL1(3)*DBL2(3) DO 205 K=1,4 205 B2B1(K)=DBL2(K)-DBL1(K) +SELF. B44=BDOTB/BMASS**2 BI41=1./BMASS BI42=(BDOTB-BMASS**2-B2B1(4)*BMASS)/(BMASS**2*(BOOST2(4)+BMASS)) B4K1=BI41 B4K2=(BMASS**2-BDOTB-B2B1(4)*BMASS)/(BMASS**2*(BOOST1(4)+BMASS)) BIK1=-1./(BMASS*(BOOST1(4)+BMASS)) BIK2=1./(BMASS*(BOOST2(4)+BMASS)) BIK3=(BMASS**2-BDOTB)/(BMASS**2*(BOOST1(4)+BMASS) $*(BOOST2(4)+BMASS)) C C BOOST FINAL JETS DO 210 J=1,NJSET IF(J.EQ.IVIR.OR.J.EQ.IVIR2) GO TO 210 IF(PJSET(5,J).LT.0.) GO TO 210 IF(JDCAY(J).EQ.-1) GO TO 210 BP1=0. BP21=0. DO 215 K=1,3 BP1=BP1+BOOST1(K)*PJSET(K,J) 215 BP21=BP21+B2B1(K)*PJSET(K,J) DO 220 K=1,3 220 PJSET(K,J)=PJSET(K,J) $+(B2B1(K)*BI41+BOOST2(K)*BI42)*PJSET(4,J) $+B2B1(K)*BP1*BIK1+BOOST2(K)*BP21*BIK2+BOOST2(K)*BP1*BIK3 PJSET(4,J)=B44*PJSET(4,J)+BP21*B4K1+BP1*B4K2 210 CONTINUE C C SET PFINAL TO BOOST2 DO 230 K=1,4 230 PFINAL(K)=BOOST2(K) PFINAL(5)=BMASS C C RESET REMAINING VECTORS DO 240 J=NJSET,1,-1 IF(J.EQ.IVIR.OR.J.EQ.IVIR2) GO TO 240 IF(PJSET(5,J).GE.0.) GO TO 240 JX1=JDCAY(J)/JPACK JX2=JDCAY(J)-JPACK*JX1 DO 250 K=1,4 PJSET(K,J)=PJSET(K,JX1)-PJSET(K,JX2) 250 DBL1(K)=PJSET(K,J) +SELF,IF=SINGLE. AMJ=SQRT(ABS(DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2)) +SELF,IF=DOUBLE. AMJ=DSQRT(ABS(DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2)) +SELF. PJSET(5,J)=-AMJ 240 CONTINUE C C RESET PFINAL, ETC. +SELF,IF=SINGLE. DO 300 K=1,4 300 PFINAL(K)=PFINAL(K)+PJSET(K,NEWF) S1=PFINAL(4)**2-PFINAL(1)**2-PFINAL(2)**2-PFINAL(3)**2 IF(S1.LT.0.) GO TO 9999 PFINAL(5)=SQRT(S1) PTOTPL=PJSET(4,NEWV)+PJSET(3,NEWV)+PJSET(4,IVIR2)+PJSET(3,IVIR2) PTOTMN=PJSET(4,NEWV)-PJSET(3,NEWV)+PJSET(4,IVIR2)-PJSET(3,IVIR2) +SELF,IF=DOUBLE. C NEED DOUBLE PRECISION ON 32-BIT MACHINES CALL DBLVEC(PFINAL,DBL1) CALL DBLVEC(PJSET(1,NEWF),DBL2) DO 300 K=1,4 DBL1(K)=DBL1(K)+DBL2(K) 300 PFINAL(K)=DBL1(K) S1=DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2 PFINAL(5)=SQRT(S1) IF(S1.LT.0.) GO TO 9999 PFINAL(5)=SQRT(S1) PTOTPL=PJSET(4,NEWV)+PJSET(3,NEWV)+PJSET(4,IVIR2)+PJSET(3,IVIR2) PTOTMN=PJSET(4,NEWV)-PJSET(3,NEWV)+PJSET(4,IVIR2)-PJSET(3,IVIR2) +SELF. C C SET NJSET AND POINTERS IF Z WAS GOOD IF(.NOT.ZGOOD) GO TO 10 NJSET=NJSET+2 IF(JDCAY(NEWF).GT.0) NJSET=NJSET+2 JVIR(JET-10)=NEWV GO TO 10 C ERROR -- DISCARD EVENT. 9999 CONTINUE WRITE(ITLIS,9998) IEVT 9998 FORMAT(/' ***** ERROR IN QCDINI ... EVENT',I8,' DISCARDED *****') NJSET=-1 RETURN END +EOD +DECK,QCDINT SUBROUTINE QCDINT(J0) C C AUXILIARY ROUTINE FOR QCDINI. GENERATE A NEW MASS FOR C SPACELIKE PARTON J0. C +CDE,ITAPES +CDE,JETSET +CDE,JWORK +CDE,JWORK2 +CDE,QCDPAR +CDE,PRIMAR C DIMENSION GAMS(13),FX0S(13) DATA CA/3./,CF/1.333333333/ C C FUNCTIONS -- USE DZMAX FOR PRECISION GQQ(Z,DZ)=CF*(-2.*ALOG(DZ)+Z*(-1.-.5*Z)) GQG(Z)=CF*(+2.*ALOG(Z)+Z*(-2.+.5*Z)) GGQ(Z)=(Z**3-(1.-Z)**3)/6. GGG(Z,DZ)=2.*CA*(ALOG(Z/DZ)+Z*(-2.+Z*(.5-Z/3.))) GBQQ(RZ,DZ)=CF*(2.*ALOG((1.+RZ)**2/DZ)+RZ*(-2.-2./3.*RZ**2)) GBQG(RZ)=CF*(-4./RZ+RZ*(-4.+2./3.*RZ**2)) C GLFORC(JET-10)=.FALSE. IDABS=IABS(JTYPE(J0)) IF(JTYPE(J0).EQ.9) THEN ITYP=1 ELSEIF(JTYPE(J0).GT.0) THEN ITYP=2*IDABS ELSE ITYP=2.*IDABS+1 ENDIF IBEAM=JET-10 AM0=ABS(PJSET(5,J0)) 1 T0=AM0**2 X0=ZMIN ANF=3 DO 110 I=4,6 AMQ2=AMASS(I)**2 110 ANF=ANF+T0/(AMQ2+T0) B0=11.-2.*ANF/3. C C SET UP ANOMALOUS DIMENSIONS. ALSO USE THESE TO DETERMINE TYPE C OF INCOMING PARTON (TO BE USED IN QCDINZ). C C GLUON IF(IDABS.EQ.9) THEN AMQ=0. GAMG=GGG(ZMAX,DZMAX)-GGG(ZMIN,1.-ZMIN) GAMS(1)=GAMG FX0=STRUC(X0,T0,1,IDIN(IBEAM)) FX0S(1)=FX0 GAMFAC=(GBQG(SQRT(ZMAX))-GBQG(SQRT(ZMIN)))/FX0 GAMQ=0. DO 210 IQ=2,13 FX0S(IQ)=STRUC(X0,T0,IQ,IDIN(IBEAM)) GAMS(IQ)=GAMFAC*FX0S(IQ) 210 GAMQ=GAMQ+GAMS(IQ) GAM=GAMG+GAMQ AM1=CUTJET C TRY=RANF() SUM=0. DO 220 IQ=1,13 SUM=SUM+GAMS(IQ)/GAM IF(SUM.LT.TRY) GO TO 220 JIN(J0)=IQ FXTEST(J0)=FX0S(IQ) GO TO 300 220 CONTINUE C C LIGHT QUARK ELSEIF(IDABS.LE.3) THEN AMQ=AMASS(IDABS) GAMQ=GBQQ(SQRT(ZMAX),DZMAX)-GBQQ(SQRT(ZMIN),1.-ZMIN) FX0=STRUC(X0,T0,ITYP,IDIN(IBEAM)) FXG=STRUC(X0,T0,1,IDIN(IBEAM)) GAMFAC=FXG/FX0 GAMG=GAMFAC*(GGQ(ZMAX)-GGQ(ZMIN)) GAM=GAMQ+GAMG AM1=AMQ+CUTJET C IF(GAMQ/GAM.GT.RANF()) THEN JIN(J0)=ITYP FXTEST(J0)=FX0 ELSE JIN(J0)=1 FXTEST(J0)=FXG ENDIF C C HEAVY QUARK -- SPECIAL TREATMENT NEEDED TO ALWAYS FORCE C GL-->QK+QB BEFORE END OF EVOLUTION. C USE SMALLER MASS FOR FORCED DECAYS TO PREVENT INFINITE LOOP. ELSE AMQ=AMASS(IDABS) THRESH=4.*AMQ**2*X0/(1.-X0) THRESH=(SQRT(THRESH)+CUTJET)**2 IF(STRUC(X0,T0,ITYP,IDIN(IBEAM)).LE.0..OR. $ T0.LE.THRESH) THEN PJSET(5,J0)=-AM0*SQRT(RANF())-ALAM GLFORC(JET-10)=.TRUE. JDCAY(J0)=-2 JIN(J0)=1 FXTEST(J0)=1. RETURN ENDIF T1=SQRT(T0*THRESH) 230 AM1=SQRT(T1) FX0=STRUC(X0,T1,ITYP,IDIN(IBEAM)) IF(FX0.LE.0.) THEN T1=SQRT(T1*T0) GO TO 230 ENDIF FXG=STRUC(X0,T1,1,IDIN(IBEAM)) GAMFAC=FXG/FX0 GAMQ=GQQ(ZMAX,DZMAX)-GQQ(ZMIN,1.-ZMIN) GAMG=GAMFAC*(GGQ(ZMAX)-GGQ(ZMIN)) GAM=GAMQ+GAMG C IF(GAMQ/GAM.GT.RANF()) THEN JIN(J0)=ITYP FXTEST(J0)=FX0 ELSE JIN(J0)=1 FXTEST(J0)=FXG ENDIF ENDIF C C LEADING-LOG MASS GENERATION. C 300 GB=2.*GAM/B0 IF(AM1.GT.ALAM.AND.AM0.GT.ALAM) THEN PROBL=GB*ALOG(ALOG(AM1/ALAM)/ALOG(AM0/ALAM)) ELSE PROBL=0. ENDIF IF(PROBL.GT.0.) THEN PROB=1. ELSEIF(PROBL.GT.-50.) THEN PROB=EXP(PROBL) ELSE PROB=0. ENDIF IF(PROB.GT.RANF()) THEN IF(IDABS.LE.3.OR.IDABS.EQ.9) THEN PJSET(5,J0)=AMQ JDCAY(J0)=JPACK*J0+J0 RETURN ELSEIF(AM0.LT.AM1+CUTJET) THEN PJSET(5,J0)=-SQRT(T0) GLFORC(JET-10)=.TRUE. JDCAY(J0)=-2 JIN(J0)=1 FXTEST(J0)=1 RETURN ELSE AM0=AM1 GO TO 1 ENDIF ELSE POW=(1.-(1.-PROB)*RANF())**(1./GB) AMNEW=ALAM*(AM0/ALAM)**POW IF(AMNEW.GE.AM1) THEN PJSET(5,J0)=-AMNEW JDCAY(J0)=-2 RETURN ELSEIF(IDABS.LE.3.OR.IDABS.EQ.9) THEN PJSET(5,J0)=AMQ JDCAY(J0)=JPACK*J0+J0 RETURN ELSEIF(AM0.LT.AM1+CUTJET) THEN PJSET(5,J0)=-AM0*SQRT(RANF())-ALAM GLFORC(JET-10)=.TRUE. JDCAY(J0)=-2 JIN(J0)=1 FXTEST(J0)=1 RETURN ELSE AM0=AM1 GO TO 1 ENDIF ENDIF END +EOD +DECK,QCDINZ. SUBROUTINE QCDINZ(J0) C C AUXILIARY ROUTINE FOR QCDINI. GENERATE A Z AND TWO DAUGHTER C PARTONS FOR SPACELIKE PARTON J0. C +CDE,ITAPES +CDE,JETSET. +CDE,JWORK. +CDE,JWORK2. +CDE,QCDPAR. +CDE,PRIMAR C DATA CA/3./,CF/1.333333333/ C FUNCTIONS. PQQ(Z)=CF*(1.+Z**2)/(1.-Z) PQG(Z)=CF*(1.+(1.-Z)**2)/Z PGQ(Z)=.5*(Z**2+(1.-Z)**2) PGG(Z)=2.*CA*(1.-Z*(1.-Z))**2/(Z*(1.-Z)) C C INITIALIZE IDABS=IABS(JTYPE(J0)) AM0=ABS(PJSET(5,J0)) T0=AM0**2 JIN0=JIN(J0) X0=(PJSET(4,J0)+SGN*PJSET(3,J0))/ECM ZGOOD=.FALSE. IF(ZMIN.GE.ZMAX) RETURN C C SELECT BRANCHING AND GENERATE Z ACCORDING TO ALTARELLI-PARISI C FUNCTIONS. THEN CHECK WITH STRUCTURE FUNCTIONS C C GLUON C IF(IDABS.EQ.9) THEN C C GL->GL+GL IF(JIN0.EQ.1) THEN 110 ZGEN=DZMAX/ZMAX*(ZMAX*(1.-ZMIN)/(ZMIN*DZMAX))**RANF() Z=1./(1.+ZGEN) DZ=ZGEN/(1.+ZGEN) GZ=2.*CA/(Z*DZ) PGGZ=2.*CA*(1.-Z*(1.-Z))**2/(Z*DZ) IF(PGGZ.LT.GZ*RANF()) GO TO 110 JTYPE(NJSET+1)=9 JTYPE(NJSET+2)=9 ZZC(J0)=Z C X1=X0/Z FX1=STRUC(X1,T0,1,IDIN(JET-10)) FX0=FXTEST(J0) IF(FX1/FX0.GT.RANF()) ZGOOD=.TRUE. C C QK->GL+QK ELSE 120 RZMAX=SQRT(ZMAX) RZMIN=SQRT(ZMIN) ZGEN=1./RZMAX-RANF()*(1./RZMAX-1./RZMIN) Z=1./ZGEN**2 RZ=SQRT(Z) GZ=2.*CF/RZ**3 IF(PQG(Z)/RZ.LT.GZ*RANF()) GO TO 120 IFL=JIN0/2 IF(JIN0.NE.2*IFL) IFL=-IFL JTYPE(NJSET+1)=IFL JTYPE(NJSET+2)=IFL ZZC(J0)=Z C X1=X0/Z FX1=STRUC(X1,T0,JIN0,IDIN(JET-10)) FX0=FXTEST(J0) IF(RZ*FX1/FX0.GT.RANF()) ZGOOD=.TRUE. ENDIF C C QUARK C ELSE C C GL->QK+QB IF(JIN0.EQ.1) THEN 130 Z=ZMIN+(ZMAX-ZMIN)*RANF() IF(PGQ(Z).LT..5*RANF()) GO TO 130 JTYPE(NJSET+1)=9 JTYPE(NJSET+2)=-JTYPE(J0) ZZC(J0)=Z C X1=X0/Z FX1=STRUC(X1,T0,1,IDIN(JET-10)) FX0=FXTEST(J0) IF(FX1/FX0.GT.RANF().OR.GLFORC(JET-10)) ZGOOD=.TRUE. C C QK->QK+GL ELSE 140 DZ=DZMAX*((1.-ZMIN)/DZMAX)**RANF() Z=1.-DZ GZ=2.*CF/DZ RZ=1. IF(IDABS.LE.3) RZ=SQRT(Z) PQQZ=CF*(1.+Z**2)/DZ IF(PQQZ/RZ.LT.GZ*RANF()) GO TO 140 JTYPE(NJSET+1)=JTYPE(J0) JTYPE(NJSET+2)=9 ZZC(J0)=Z C X1=X0/Z FX1=STRUC(X1,T0,JIN0,IDIN(JET-10)) FX0=FXTEST(J0) IF(RZ*FX1/FX0.GT.RANF()) ZGOOD=.TRUE. ENDIF ENDIF JMATCH(NJSET+1)=0 JMATCH(NJSET+2)=0 RETURN END +EOD +DECK,QCDJET. SUBROUTINE QCDJET(NJMIN) C C Carry out final state QCD jet evolution using the algorithm C of Fox and Wolfram. Evolve each parton in T with fixed ZC C and iterate as follows-- C C (0) Evolve initial partons. C (1) Pick I and find matching J>I. C (2) Solve kinematics. C (3) For K=I,J, generate Z(K) and evolve T(K1), T(K2). If no C good, evolve T(K). Otherwise, add K1 and K2 to /JETSET/. C (4) If I or J no good, then (2). C (5) Then (1). C C Use Z=(E+P)/(E0+P0) and a large TCUT. C JMATCH(J1)=J2 if J1 and J2 match. C JMATCH(J)=JPACK*J1+J2 if J1,...,J2 match. Used for multiple C initial partons. C JMATCH(J)=0 for initial jet partons C C Include W+- and Z0 radiation. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,PARTCL +CDE,QCDPAR +CDE,JETSET +CDE,JWORK +CDE,CONST C INTEGER J,NJMIN,JPRNT,JI1,JI2,NJI,JI,NJ1,NJ2,L,K,NPTLV1,IFAIL,J0 REAL AM0,AM1,AM2,RANF,AMSUM,PCM2,POLD2,RATIO,PSUM,P12CM,E0,P0,Z1, $E1MAX,P1MAX,ZMAX,E1MIN,P1MIN,ZMIN,ZEP,E1,P1,CTHCMZ,Z2,E2MAX,P2MAX, $E2MIN,P2MIN,P2,E2,CTHCM,STHCM,PHICM,CPHICM,SPHICM,PT0,CTH0,STH0, $CPHI0,SPHI0,SGN,BP,ZLIM,ZLIM1 DIMENSION PSUM(5) DATA PSUM/5*0./ C C (0) Evolve initial parton masses. C DO 100 J=NJMIN,NJSET J1=J J2=JMATCH(J) IF(J2.GT.JPACK) GO TO 150 IF(J2.LE.J1) GO TO 100 C Two partons IF(JDCAY(J1).EQ.-1) CALL QCDT(J1) IF(JDCAY(J2).EQ.-1) CALL QCDT(J2) JPRNT=MOD(JORIG(J),JPACK) IF(JPRNT.EQ.0) THEN AM0=PJSET(4,J1)+PJSET(4,J2) ELSE AM0=PJSET(5,JPRNT) ENDIF 110 AM1=PJSET(5,J1) AM2=PJSET(5,J2) IF(AM0.LE.AM1+AM2) THEN J3=J1 IF(RANF().GT..5) J3=J2 IF(JDCAY(J3).EQ.-1) CALL QCDT(J3) GO TO 110 ENDIF GO TO 100 C More than two partons 150 JI1=JMATCH(J)/JPACK IF(J.NE.JI1) GO TO 100 JI2=JMATCH(J)-JPACK*JI1 NJI=JI2-JI1+1 AM0=0. AMSUM=0. DO 160 JI=JI1,JI2 IF(JDCAY(JI).EQ.-1) CALL QCDT(JI) AM0=AM0+PJSET(4,JI) AMSUM=AMSUM+PJSET(5,JI) 160 CONTINUE 170 IF(AM0.LT.AMSUM) THEN J3=NJI*RANF()+JI1 AMSUM=AMSUM-PJSET(5,J3) IF(JDCAY(J3).EQ.-1) CALL QCDT(J3) AMSUM=AMSUM+PJSET(5,J3) GO TO 170 ENDIF 100 CONTINUE C C (1) Loop over active partons C NJ1=NJMIN 1 NJ2=NJSET DO 200 J=NJ1,NJ2 J1=J J2=JMATCH(J1) NJI=2 IF(J2.LE.J1) GO TO 200 C C (2) Solve kinematics. C C Initial partons--keep directions fixed. 210 IF(MOD(JORIG(J),JPACK).NE.0) GO TO 230 IF(JMATCH(J).GT.JPACK) GO TO 400 AM0=PJSET(4,J1)+PJSET(4,J2) AM1=PJSET(5,J1) AM2=PJSET(5,J2) PJSET(4,J1)=(AM0**2+AM1**2-AM2**2)/(2*AM0) PJSET(4,J2)=(AM0**2+AM2**2-AM1**2)/(2*AM0) PCM2=((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(4*AM0**2) DO 220 L=1,2 POLD2=PJSET(1,JJ(L))**2+PJSET(2,JJ(L))**2+PJSET(3,JJ(L))**2 RATIO=SQRT(PCM2/POLD2) DO 225 K=1,3 225 PJSET(K,JJ(L))=RATIO*PJSET(K,JJ(L)) 220 CONTINUE GO TO 300 C C NJI.LE.5 initial partons 400 CONTINUE JI1=JMATCH(J)/JPACK IF(J.NE.JI1) GO TO 200 JI2=JMATCH(J)-JPACK*JI1 NJI=JI2-JI1+1 AM0=0. DO 410 JI=JI1,JI2 AM0=AM0+PJSET(4,JI) JJ(JI-JI1+1)=JI PJSET(4,JI)=SQRT(PJSET(1,JI)**2+PJSET(2,JI)**2+PJSET(3,JI)**2 1 +PJSET(5,JI)**2) DO 420 K=1,5 420 PPTCL(K,NPTCL+JI-JI1+1)=PJSET(K,JI) 410 CONTINUE PSUM(4)=AM0 PSUM(5)=PSUM(4) NPTLV1=NPTCL CALL RESCAL(NPTLV1+1,NPTLV1+NJI,PSUM,IFAIL) DO 430 JI=JI1,JI2 DO 430 K=1,5 PJSET(K,JI)=PPTCL(K,NPTCL+JI-JI1+1) 430 CONTINUE GO TO 300 C C Solve kinematics for general partons. C 230 J0=MOD(JORIG(J),JPACK) AM0=PJSET(5,J0) AM1=PJSET(5,J1) AM2=PJSET(5,J2) E1CM=(AM0**2+AM1**2-AM2**2)/(2*AM0) E2CM=(AM0**2+AM2**2-AM1**2)/(2*AM0) P12CM=SQRT((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(2*AM0) NJI=2 C Determine E1, P1, and COS(THCM) from Z(J0). C Occasionally COS(TH)>1. If so then reset Z. E0=PJSET(4,J0) P0=SQRT(PJSET(1,J0)**2+PJSET(2,J0)**2+PJSET(3,J0)**2) Z1=ZZC(J0) IF(Z1.GT.0.5) THEN E1MAX=(E0*E1CM+P0*P12CM)/AM0 P1MAX=(P0*E1CM+E0*P12CM)/AM0 ZMAX=(E1MAX+P1MAX)/(E0+P0) E1MIN=(E0*E1CM-P0*P12CM)/AM0 P1MIN=(P0*E1CM-E0*P12CM)/AM0 P1MIN=ABS(P1MIN) ZMIN=(E1MIN+P1MIN)/(E0+P0) IF(Z1.LT.ZMIN.OR.Z1.GT.ZMAX) Z1=ZMIN+Z1*(ZMAX-ZMIN) ZZC(J0)=Z1 ZEP=Z1*(E0+P0) P1=(ZEP**2-AM1**2)/(2.*ZEP) E1=(ZEP**2+AM1**2)/(2.*ZEP) CTHCM=(E1*AM0-E0*E1CM)/(P0*P12CM) ELSE Z2=1.-Z1 E2MAX=(E0*E2CM+P0*P12CM)/AM0 P2MAX=(P0*E2CM+E0*P12CM)/AM0 ZMAX=(E2MAX+P2MAX)/(E0+P0) E2MIN=(E0*E2CM-P0*P12CM)/AM0 P2MIN=(P0*E2CM-E0*P12CM)/AM0 P2MIN=ABS(P2MIN) ZMIN=(E2MIN+P2MIN)/(E0+P0) IF(Z2.LT.ZMIN.OR.Z2.GT.ZMAX) Z2=ZMIN+Z2*(ZMAX-ZMIN) ZZC(J0)=Z2 ZEP=Z2*(E0+P0) P2=(ZEP**2-AM2**2)/(2.*ZEP) E2=(ZEP**2+AM2**2)/(2.*ZEP) CTHCM=-(E2*AM0-E0*E2CM)/(P0*P12CM) ENDIF C Avoid disaster IF(ABS(CTHCM).GT.1.) CTHCM=SIGN(RANF(),CTHCM) STHCM=SQRT(1.-CTHCM**2) PHICM=2*PI*RANF() CPHICM=COS(PHICM) SPHICM=SIN(PHICM) C C Construct cm momenta. PT0=SQRT(PJSET(1,J0)**2+PJSET(2,J0)**2) CTH0=PJSET(3,J0)/P0 STH0=PT0/P0 CPHI0=PJSET(1,J0)/PT0 SPHI0=PJSET(2,J0)/PT0 P1CM(1)=P12CM*(CPHI0*(CTH0*CPHICM*STHCM+STH0*CTHCM) 1 -SPHI0*SPHICM*STHCM) P1CM(2)=P12CM*(SPHI0*(CTH0*CPHICM*STHCM+STH0*CTHCM) 1 +CPHI0*SPHICM*STHCM) P1CM(3)=P12CM*(-STH0*CPHICM*STHCM+CTH0*CTHCM) C Boost with P0 to get lab momenta DO 240 L=1,2 SGN=3-2*L BP=0 DO 241 K=1,3 241 BP=BP+PJSET(K,J0)*SGN*P1CM(K) BP=BP/AM0 PJSET(4,JJ(L))=PJSET(4,J0)*EE(L)/PJSET(5,J0)+BP DO 242 K=1,3 242 PJSET(K,JJ(L))=SGN*P1CM(K)+PJSET(K,J0)*EE(L)/PJSET(5,J0) 1 +PJSET(K,J0)*BP/(PJSET(4,J0)+PJSET(5,J0)) 240 CONTINUE C C (3) Pick Z and decay partons. Check. C 300 CONTINUE TNEW=.FALSE. DO 310 L=1,NJI IF(JDCAY(JJ(L)).GE.0) GO TO 310 IF(NJSET+2.GT.MXJSET) GO TO 9999 CALL QCDZ(JJ(L)) CALL QCDT(NJSET+1) CALL QCDT(NJSET+2) C C Check whether masses allowed. AM0=PJSET(5,JJ(L)) AM1=PJSET(5,NJSET+1) AM2=PJSET(5,NJSET+2) IF(AM1+AM2.GE.AM0) GO TO 320 C C Check whether Z allowed. E1CM=(AM0**2+AM1**2-AM2**2)/(2*AM0) E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0) P12CM=SQRT((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(2*AM0) E0=PJSET(4,JJ(L)) P0=SQRT(PJSET(1,JJ(L))**2+PJSET(2,JJ(L))**2+PJSET(3,JJ(L))**2) IF(ZZC(JJ(L)).GT.0.5) THEN ZEP=ZZC(JJ(L))*(E0+P0) P1=(ZEP**2-AM1**2)/(2.*ZEP) E1=(ZEP**2+AM1**2)/(2.*ZEP) CTHCM=(E1*AM0-E0*E1CM)/(P0*P12CM) IF((ABS(CTHCM).GE.1..OR.P1.LE.0.).AND.IABS(JTYPE(JJ(L))) $ .LT.80) GO TO 320 ELSE ZEP=(1.-ZZC(JJ(L)))*(E0+P0) P2=(ZEP**2-AM2**2)/(2.*ZEP) E2=(ZEP**2+AM2**2)/(2.*ZEP) CTHCM=-(E2*AM0-E0*E2CM)/(P0*P12CM) IF((ABS(CTHCM).GE.1..OR.P2.LE.0.).AND.IABS(JTYPE(JJ(L))) $ .LT.80) GO TO 320 ENDIF C C Require Z and 1-Z within kinematic limits. C ZLIM=(AM0/(E0+P0))**2 ZLIM1=CUTJET/(E0+P0) ZLIM=AMAX1(ZLIM,ZLIM1) IF((ZZC(JJ(L)).GT.ZLIM.AND.ZZC(JJ(L)).LT.(1.-ZLIM)).OR. $ IABS(JTYPE(JJ(L))).GE.80) THEN C Add new partons to /JETSET/. JDCAY(JJ(L))=JPACK*(NJSET+1)+(NJSET+2) NJSET=NJSET+2 GO TO 310 ENDIF C Discard partons and evolve JJ(L) again. 320 TNEW=.TRUE. CALL QCDT(JJ(L)) 310 CONTINUE C C (4) Resolve kinematics if any parton mass is changed. C IF(TNEW) GO TO 210 200 CONTINUE C C (5) Iterate entire proceedure. C NJ1=NJ2+1 IF(NJ1.LE.NJSET) GO TO 1 RETURN C C Error message C 9999 CALL PRTEVT(0) WRITE(ITLIS,10) NJSET 10 FORMAT(//' ERROR IN QCDJET...NJSET > ',I4) RETURN END +EOD +DECK,QCDT. SUBROUTINE QCDT(J) C C Auxiliary routine for QCDJET. Calculate ZC and store in C ZZC(J). Generate new mass with ZC and store in PJSET(5,J). C C Must include 1/2 symmetry factor in GAMGG. No fix is needed C in QCDZ since GAMGG+2*GAMQQ is used as the normalization. C C Include GM, W+, W-, and Z0 radiation. C C Ver 7.20: Anomalous dimensions were coded incorrectly! C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSET +CDE,JWORK +CDE,QCDPAR +CDE,CONST +CDE,WCON +CDE,PRIMAR C REAL AM0,AM1,AM2,AMASS,T0,T1,T2,ZC,B0,GAMEW,GAMQQ,GAMGG,GAM,GAMZC REAL AM1W,AM2W,T1W,T2W,TERM,GB,PROB,RANF,RND,POW,AMNEW,AMOLD REAL POWEW INTEGER J,JTLV1,NF,IQ,JTABS,IW,JT0,JT1,IFL1,I INTEGER JWTYPE(4) DATA JWTYPE/10,80,-80,90/ C C Set ZC = 0 and return for W+- or Z0 C JTABS=IABS(JTYPE(J)) IF(JTABS.GE.80.AND.JTABS.LE.90) THEN ZZC(J)=0. RETURN ENDIF C C Calculate ZC C AM0=PJSET(5,J) JTLV1=JTYPE(J) AM1=AMASS(JTLV1)+CUTJET AM2=CUTJET IF(AM1+AM2.GE.AM0) GO TO 300 T0=AM0**2 T1=AM1**2 T2=AM2**2 C Fix floating point problem C ZC=(T0-T1+T2-SQRT((T0-T1-T2)**2-4*T1*T2))/(2*T0) ZC=2*T2/(T0-T1+T2+SQRT((T0-T1-T2)**2-4*T1*T2)) ZZC(J)=ZC C Count light fermions NF=3 DO 110 IQ=4,6 IF(AM0.LT.2*AMASS(IQ)) GO TO 120 NF=NF+1 110 CONTINUE 120 B0=11.-2.*NF/3. C C Calculate GAMMA(ZC) and GAMEW for quarks C GAMEW=0. C C Initial gluon IF(JTABS.EQ.9) THEN GAMQQ=(1.-2.*ZC)*(1.-ZC*(1.-ZC))/3. GAMGG=12.*ALOG((1.-ZC)/ZC)-9.*(1.-2.*ZC)-6.*GAMQQ GAMGG=0.5*GAMGG GAM=GAMGG+NF*GAMQQ C C Initial quark ELSEIF(JTABS.LT.9) THEN GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC) GAM=4./3.*GAMZC GAMEW=ALFA/(2.*PI)*AQ(JTABS,1)**2*GAMZC IF(AM0.GT.WMASS(4)) THEN DO 130 IW=2,4 JT0=2*IABS(JTYPE(J)) IF(JTYPE(J).LT.0) JT0=JT0+1 JT1=MATCH(JT0,IW) IF(JT1.EQ.0) GO TO 130 JT1=MATCH(JT1,4) IFL1=JT1/2 AM1W=AMASS(IFL1) AM2W=AMASS(JWTYPE(IW)) IF(AM1W+AM2W.GE.AM0) GO TO 130 T1W=AM1W**2 T2W=AM2W**2 C Fix floating underflow C ZC=(T0-T1W+T2W-SQRT((T0-T1W-T2W)**2-4*T1W*T2W))/(2*T0) ZC=2*T2W/(T0-T1W+T2W+SQRT((T0-T1W-T2W)**2-4*T1W*T2W)) GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC) TERM=(AQ(JTABS,IW)**2+BQ(JTABS,IW)**2)*GAMZC GAMEW=GAMEW+ALFA/(2.*PI)*TERM 130 CONTINUE ENDIF C C Initial diquark ELSEIF(MOD(JTABS,100).EQ.0) THEN GAM=8./3.*ALOG((1-ZC)/ZC)-2.*(1.-2.*ZC) C C Initial gluino ELSEIF(JTABS.EQ.29) THEN GAM=6.*ALOG((1.-ZC)/ZC)-9./2.*(1.-2.*ZC) C C Initial squark ELSEIF(JTABS.GT.20.AND.JTABS.LT.29) THEN GAM = 8./3.*(ALOG((1.-ZC)/ZC)-(1.-2.*ZC)) ENDIF C C Generate new mass C GB=2*GAM/B0 PROB=(ALOG(AM1/ALAM)/ALOG(AM0/ALAM))**GB PROB=PROB*(AM1/AM0)**(2.*GAMEW) IF(PROB.GT.RANF()) GO TO 300 RND=RANF() POW=(1.-(1.-PROB)*RND)**(1./GB) AMNEW=ALAM*(AM0/ALAM)**POW C For quark, add effect of GM, W+-, Z0 radiation IF(IABS(JTYPE(J)).LT.9) THEN DO 200 I=1,NTRIES AMOLD=AMNEW POWEW=POW/((AMOLD/AM0)**(2.*GAMEW))**(1./GB) AMNEW=ALAM*(AM0/ALAM)**POWEW IF(ABS(AMNEW-AMOLD).LT.0.001*AMOLD) GO TO 210 200 CONTINUE ENDIF 210 IF(AMNEW.LE.AM1) GO TO 300 PJSET(5,J)=AMNEW RETURN C C Final parton -- set mass to physical value C 300 PJSET(5,J)=AM1-CUTJET JDCAY(J)=0 RETURN END +EOD +DECK,QCDZ. SUBROUTINE QCDZ(J) C C Auxiliary routine for QCDJET. Generate Z for parton J and C store in ZZC(J). Add possible new partons to /JETSET/. C C Include GM, W+, W-, and Z0 radiation. C C Ver 7.20: Anomalous dimensions were coded incorrectly! C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSET +CDE,JWORK +CDE,QCDPAR +CDE,WCON +CDE,CONST +CDE,Q1Q2 C REAL PQQ,PGQ,PQG,PGG,Z,PGSGS,PQSQS,ALFAS,QQ,AM0,ZC,AMASS REAL GAMQQ,GAMGG,PROBG,PROBQ,RND,RANF,ZGEN,GZ REAL GAMZC,GAMSUM,AM1W,AM2W,T1W,T2W,ZCW,T0,GAMZCW,TERM,SUM REAL SUMBR,BRMODE,TRY,HELPL,HELMN,HEL,PZ INTEGER NF,J,JTABS,IQ,IFL,IW,JT0,JT1,IFL1,IFL2 INTEGER IWTYPE,JET,JW,IQ1,IQ2,JPAR,IFLPAR,NJ1,NJ2,IDABS1,IDABS2 REAL GAMSAV(5),ZCSAV(5),BRANCH(25) INTEGER JSAV(5),LISTW(5),LISTJ(25) DATA LISTW/9,10,80,-80,90/ DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ C C Altarelli-Parisi functions. PQQ(Z)=4*(1+Z**2)/(3*(1-Z)) PGQ(Z)=.5*(Z**2+(1-Z)**2) PGG(Z)=6*(1-Z*(1-Z))**2/(Z*(1-Z)) PGSGS(Z)=3.*(1.+Z**2)/(1.-Z) PQSQS(Z)=8./3.*Z/(1.-Z) ALFAS(QQ)=12.*PI/((33.-2.*NF)*ALOG(QQ/ALAM2)) C C Initialize. C AM0=PJSET(5,J) ZC=ZZC(J) JTABS=IABS(JTYPE(J)) NF=3 DO 110 IQ=4,6 IF(AM0.LT.2*AMASS(IQ)) GO TO 120 NF=NF+1 110 CONTINUE 120 CONTINUE NJ1=NJSET+1 NJ2=NJSET+2 C C Initial gluon C IF (JTABS.EQ.9) THEN GAMQQ=(1-2*ZC)*(1-ZC*(1-ZC))/3. GAMGG=12*ALOG((1-ZC)/ZC)-9*(1-2*ZC)-6*GAMQQ PROBG=GAMGG/(GAMGG+2*NF*GAMQQ) PROBQ=GAMQQ/(GAMGG+2*NF*GAMQQ) RND=RANF() C GL--->GL+GL IF(PROBG.GT.RND) THEN 130 ZGEN=(ZC/(1-ZC))**(1-2*RANF()) Z=ZGEN/(1.+ZGEN) GZ=6./(Z*(1.-Z)) IF(PGG(Z).LT.GZ*RANF()) GO TO 130 JTYPE(NJ1)=9 JTYPE(NJ2)=9 ZZC(J)=Z C GL--->QK+QB ELSE 140 Z=RANF() IF(PGQ(Z).LT.0.5*RANF()) GO TO 140 IFL=(RND-PROBG)/PROBQ+1. IF(IFL.GT.NF) IFL=NF-IFL JTYPE(NJ1)=IFL JTYPE(NJ2)=-IFL ZZC(J)=Z ENDIF C C Initial quark - may radiate GL, GM, W+-, Z0 C ELSEIF(JTABS.LT.9) THEN C Gluon GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC) GAMSAV(1)=4./3.*ALFAS(AM0**2)*GAMZC ZCSAV(1)=ZC JSAV(1)=JTYPE(J) C Photon GAMSAV(2)=ALFA*AQ(JTABS,1)**2*GAMZC ZCSAV(2)=ZC GAMSUM=GAMSAV(1)+GAMSAV(2) JSAV(2)=JTYPE(J) C W+- and Z0 IF(AM0.GT.WMASS(4)) THEN DO 200 IW=2,4 GAMSAV(IW+1)=0. ZCSAV(IW+1)=.5 JSAV(IW+1)=0 JT0=2*IABS(JTYPE(J)) IF(JTYPE(J).LT.0) JT0=JT0+1 JT1=MATCH(JT0,IW) IF(JT1.EQ.0) GO TO 200 JT1=MATCH(JT1,4) IFL1=JT1/2 AM1W=AMASS(IFL1) AM2W=AMASS(LISTW(IW+1)) IF(AM1W+AM2W.GE.AM0) GO TO 200 T0=AM0**2 T1W=AM1W**2 T2W=AM2W**2 ZCW=(T0-T1W+T2W-SQRT((T0-T1W-T2W)**2-4*T1W*T2W))/(2*T0) GAMZCW=2.*ALOG((1-ZCW)/ZCW)-2.*(1.-2.*ZCW) TERM=(AQ(JTABS,IW)**2+BQ(JTABS,IW)**2)*ALFA*GAMZCW GAMSAV(IW+1)=TERM ZCSAV(IW+1)=ZCW JSAV(IW+1)=IFL1*ISIGN(1,JTYPE(J)) GAMSUM=GAMSUM+TERM 200 CONTINUE ELSE DO 210 IW=2,4 GAMSAV(IW+1)=0. ZCSAV(IW+1)=.5 JSAV(IW+1)=0 210 CONTINUE ENDIF C Select decay mode RND=RANF() SUM=0. DO 220 IW=1,5 IWTYPE=IW SUM=SUM+GAMSAV(IW)/GAMSUM IF(RND.LE.SUM) GO TO 230 220 CONTINUE C Generate Z 230 CONTINUE Z=1-(ZC/(1-ZC))**RANF()*(1-ZC) GZ=8./(3.*(1-Z)) IF(PQQ(Z).LT.GZ*RANF()) GO TO 230 IF(Z.LT.ZCSAV(IWTYPE).OR.Z.GT.1.-ZCSAV(IWTYPE)) GO TO 230 JTYPE(NJ1)=JSAV(IWTYPE) JTYPE(NJ2)=LISTW(IWTYPE) ZZC(J)=Z C C Initial diquark C ELSEIF(MOD(JTABS,100).EQ.0) THEN 300 CONTINUE Z=1-(ZC/(1-ZC))**RANF()*(1-ZC) GZ=8./(3.*(1-Z)) IF(PQQ(Z).LT.GZ*RANF()) GO TO 300 JTYPE(NJ1)=JTYPE(J) JTYPE(NJ2)=9 ZZC(J)=Z C C Initial gluino C ELSEIF (JTABS.EQ.29) THEN 400 Z=1.-(ZC/(1.-ZC))**RANF()*(1.-ZC) GZ=6./(1.-Z) IF(PGSGS(Z) .LT. GZ*RANF()) GOTO 400 JTYPE(NJ1)=JTYPE(J) JTYPE(NJ2)=9 ZZC(J)=Z C C Initial squark C ELSEIF(JTABS.GT.20.AND.JTABS.LT.29) THEN 500 CONTINUE Z=1-(ZC/(1-ZC))**RANF()*(1-ZC) GZ=8./(3.*(1-Z)) IF(PQSQS(Z).LT.GZ*RANF()) GO TO 500 JTYPE(NJ1)=JTYPE(J) JTYPE(NJ2)=9 ZZC(J)=Z C C Initial W+, W-, or Z0 C ELSEIF(JTABS.EQ.80.OR.JTABS.EQ.90) THEN C Select decay mode IF(JTYPE(J).EQ.+80) JW=2 IF(JTYPE(J).EQ.-80) JW=3 IF(JTYPE(J).EQ.+90) JW=4 TRY=RANF() DO 610 IQ=2,25 IF(TRY.LT.CUMWBR(IQ,JW-1)) THEN IQ1=IQ IQ2=MATCH(IQ,JW) GO TO 620 ENDIF 610 CONTINUE 620 JTYPE(NJ1)=LISTJ(IQ1) JTYPE(NJ2)=LISTJ(IQ2) C Select W helicity JPAR=MOD(JORIG(J),JPACK) IFLPAR=IABS(JTYPE(JPAR)) HELPL=(AQ(IFLPAR,JW)-BQ(IFLPAR,JW))**2 HELMN=(AQ(IFLPAR,JW)+BQ(IFLPAR,JW))**2 IF(RANF()*(HELPL+HELMN).LT.HELMN) THEN HEL=-ISIGN(1,JTYPE(NJ1)) ELSE HEL=+ISIGN(1,JTYPE(NJ1)) ENDIF 630 Z=RANF() PZ=(1.+HEL*(2.*Z-1.))**2 IF(PZ.LT.4.*RANF()) GO TO 630 ZZC(J)=Z ENDIF C C Set masses and flags. C JET=IABS(JORIG(J))/JPACK JORIG(NJ1)=JPACK*JET+J JORIG(NJ2)=JPACK*JET+J IDABS1=IABS(JTYPE(NJ1)) IDABS2=IABS(JTYPE(NJ2)) JMATCH(NJ1)=NJ2 JMATCH(NJ2)=NJ1 C JDCAY=-1 implies further decay IF(IDABS1.LE.9.OR.(IDABS1.GT.20.AND.IDABS1.LT.30.).OR. $MOD(IDABS1,100).EQ.0) THEN PJSET(5,NJ1)=Z*AM0 JDCAY(NJ1)=-1 ELSEIF(IDABS1.GE.80.OR.IDABS1.LE.90) THEN PJSET(5,NJ1)=AMASS(IDABS1) JDCAY(NJ1)=-1 ELSE PJSET(5,NJ1)=AMASS(IDABS1) JDCAY(NJ1)=0 ENDIF IF(IDABS2.LE.9.OR.(IDABS2.GT.20.AND.IDABS2.LT.30.).OR. $MOD(IDABS2,100).EQ.0) THEN PJSET(5,NJ2)=(1.-Z)*AM0 JDCAY(NJ2)=-1 ELSEIF(IDABS2.EQ.80.OR.IDABS2.EQ.90) THEN PJSET(5,NJ2)=AMASS(IDABS2) JDCAY(NJ2)=-1 ELSE PJSET(5,NJ2)=AMASS(IDABS2) JDCAY(NJ2)=0 ENDIF RETURN END +EOD +DECK,QFUNC. SUBROUTINE QFUNC C C Find approximate QMW and QTW dependence for DRELLYAN. C Set up /WGEN/ to generate QMW and QTW. Fit is C Non-resonant: C SIGMA=ANORM/(Q2/QMAX**2)**QPOW/(PT**2+RNU2)**PTPOW C Resonant: C SIGMA=ANORM/((Q**2-M**2)**2+M**2*GAM**2) C with appropriate M and GAM. C C Ver. 6.23: Remove extension of region 1 under region 2 C to avoid discontinuity in d(sigma)/d(M) C Ver. 6.40: Scale Q**2 fit by QMAX**2 to avoid underflow C problems. Must also change DRLLYN C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,DYPAR +CDE,DYLIM +CDE,JETPAR +CDE,JETLIM +CDE,Q1Q2 +CDE,WCON +CDE,WGEN +CDE,JETSIG +CDE,KEYS +CDE,HCON +CDE,TCPAR +CDE,XMSSM C REAL QT2CUT,DPT,QMN,QMX,EM,GAM,DELM,QSTOR,SUMS,DQ,ETAX,ETA, $Q2,XI,ALI,SIGSAV,T1,T2,T3,T4,T5,DET,DEVMAX,PTNU,ALPTNU,ALQ2,FIT, $DEV,DY3,DYW,SIG00,FACTOR,FAC1,C1,B1,SUM,AL1,QMAX2 INTEGER NDIV1,NDIV2,K,I,NQS,J,N,NDIV3,NDIV4,IW,I3,II DIMENSION SUMS(9) DIMENSION QMN(3),QMX(3) DIMENSION SIGSAV(20,20) C C QT cutoff function QT2CUT(QMW)=CUTOFF*QMW**CUTPOW C C Entry C IF(FIXQM) THEN NDIV1=1 ELSE NDIV1=20 ENDIF IF(FIXQT) THEN NDIV2=1 ELSE NDIV2=20 ENDIF C DPT=(PTMAX(3)-PTMIN(3))/NDIV2 YJ(3)=0 YW=0. CTH(3)=0. STH(3)=1. IF(GODY(4)) JWTYP=4 NKL=1 NKH=1 QMN(1)=QMIN QMX(1)=QMAX QMAX2=QMAX**2 C C Define resonance region C IF(KEYS(3)) THEN IF(JWTYP.EQ.1) GO TO 99 EM=WMASS(JWTYP) GAM=WGAM(JWTYP) DELM=20. ELSEIF(KEYS(7)) THEN EM=HMASS GAM=HGAM DELM=.201357*EM DELM=AMIN1(DELM,1.5*HGAM) DELM=AMAX1(DELM,.1*EM) ELSEIF(KEYS(9)) THEN EM=TCMRHO GAM=TCGRHO DELM=.201357*EM DELM=AMIN1(DELM,1.5*TCGRHO) DELM=AMAX1(DELM,.1*EM) C No resonance region for KKG ELSEIF(KEYS(11)) THEN EM=QMAX GAM=0. DELM=0. ENDIF EMGAM=EM*GAM EMSQ=EM**2 C Region limits QMN(2)=EM-DELM QMN(3)=EM+DELM QMX(1)=QMN(2) QMX(2)=QMN(3) NKL=1 NKH=3 IF(QMAX.LE.QMN(3)) NKH=2 IF(QMAX.LE.QMN(2)) NKH=1 IF(QMIN.GE.QMN(2)) NKL=2 IF(QMIN.GE.QMN(3)) NKL=3 QMX(NKH)=QMAX QMN(NKL)=QMIN 99 CONTINUE C C Fit over regions NKL to NKH C Region 1 is below resonance C Region 2 is inside resonance C Region 3 is above resonance C FIT=ANORM/(Q2/QMAX**2)**QPOW/(PT**2+RNU2)**PTPOW C DO 100 K=1,3 ANORM(K)=0. PTPOW(K)=0. QPOW(K)=0. RNU2(K)=QT2CUT(QMIN) 100 CONTINUE C C Loop over regions C DO 200 K=NKL,NKH DO 210 I=1,9 210 SUMS(I)=0 DQ=(QMX(K)-QMN(K))/NDIV1 NQS=NDIV1 DO 220 I=1,NDIV2 PT(3)=PTMIN(3)+(I-1)*DPT QTW=PT(3) P(3)=PT(3) RNU2(K)=QT2CUT(QMN(K)) ETAX=PT(3)**2+RNU2(K) ETA=ALOG(ETAX) DO 230 J=1,NQS QMW=QMN(K)+(J-1)*DQ Q2=QMW*QMW XI=ALOG(Q2/QMAX2) SUMS(1)=SUMS(1)+XI SUMS(2)=SUMS(2)+ETA SUMS(5)=SUMS(5)+ETA*ETA SUMS(4)=SUMS(4)+XI**2 SUMS(7)=SUMS(7)+XI*ETA C Cross section IF(KEYS(3)) THEN CALL SIGDY ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN CALL SIGH ELSEIF(KEYS(7).AND.GOMSSM) THEN CALL SIGHSS ELSEIF(KEYS(9)) THEN CALL SIGTC ELSEIF(KEYS(11)) THEN CALL SIGKKG ENDIF IF(SIGMA.EQ.0.) GO TO 999 AL1=ALOG(SIGMA) SIGSAV(I,J)=AL1 IF(K.EQ.2) AL1=AL1+ALOG((Q2-EM**2)**2+EMGAM**2) SUMS(3)=SUMS(3)+AL1 SUMS(8)=SUMS(8)+AL1*XI SUMS(9)=SUMS(9)+AL1*ETA 230 CONTINUE 220 CONTINUE C C Find coefficients minimizing chisq C N=NQS*NDIV2 T1=N*SUMS(7)-SUMS(1)*SUMS(2) T2=N*SUMS(5)-SUMS(2)**2 T3=N*SUMS(4)-SUMS(1)**2 T4=N*SUMS(8)-SUMS(1)*SUMS(3) T5=N*SUMS(9)-SUMS(2)*SUMS(3) IF((FIXQM.OR.K.EQ.2).AND.FIXQT) THEN PTPOW(K)=0. QPOW(K)=0. ELSEIF(FIXQT) THEN PTPOW(K)=0. QPOW(K)=-T4/T3 ELSEIF(FIXQM.OR.K.EQ.2) THEN PTPOW(K)=-T5/T2 QPOW(K)=0. ELSE DET=T1**2-T2*T3 PTPOW(K)=(T5*T3-T4*T1)/DET QPOW(K)=(T4*T2-T1*T5)/DET ENDIF ANORM(K)=(QPOW(K)*SUMS(1)+PTPOW(K)*SUMS(2)+SUMS(3))/N C C Shift fit to obtain envelope for SIGDY C DEVMAX=0. DO 240 I=1,NDIV2 PT(3)=PTMIN(3)+(I-1)*DPT PTNU=PT(3)**2+RNU2(K) DO 250 J=1,NDIV1 QMW=QMN(K)+(J-1)*DQ Q2=QMW**2 ALPTNU=ALOG(PTNU) ALQ2=ALOG(Q2/QMAX2) IF(K.EQ.2) THEN FIT=EXP(ANORM(K)-PTPOW(K)*ALPTNU $ -ALOG((Q2-EM**2)**2+EMGAM**2)) ELSE FIT=EXP(ANORM(K)-PTPOW(K)*ALPTNU-QPOW(K)*ALQ2) ENDIF DEV=SIGSAV(I,J)-ALOG(FIT) IF(DEV.GT.DEVMAX) DEVMAX=DEV 250 CONTINUE 240 CONTINUE ANORM(K)=ANORM(K)+DEVMAX 200 CONTINUE C C Shift fit to obtain envelope in YW NDIV3=20 IF(STDDY) THEN NDIV4=1 DY3=0. ELSE NDIV4=20 DY3=(YJMAX(3)-YJMIN(3))/(NDIV4-1) ENDIF DYW=(YWMAX-YWMIN)/(NDIV3-1) C DO 300 K=NKL,NKH QMW=QMN(K) Q2=QMW**2 QTW=QTMIN PT(3)=QTW P(3)=PT(3) YW=0. YJ(3)=0. CTH(3)=0. STH(3)=1. IF(KEYS(3)) THEN CALL SIGDY ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN CALL SIGH ELSEIF(KEYS(7).AND.GOMSSM) THEN CALL SIGHSS ELSEIF(KEYS(9)) THEN CALL SIGTC ELSEIF(KEYS(11)) THEN CALL SIGKKG ENDIF SIG00=SIGMA FACTOR=1. DO 310 IW=1,NDIV3 YW=YWMIN+(IW-1)*DYW DO 320 I3=1,NDIV4 IF(.NOT.STDDY) THEN YJ(3)=YJMIN(3)+(I3-1)*DY3 CTH(3)=TANH(YJ(3)) STH(3)=SQRT(1.-CTH(3)**2) IF(STH(3).EQ.0.) GO TO 320 TH(3)=ACOS(CTH(3)) P(3)=PT(3)/STH(3) ENDIF IF(KEYS(3)) THEN CALL SIGDY ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN CALL SIGH ELSEIF(KEYS(7).AND.GOMSSM) THEN CALL SIGHSS ELSEIF(KEYS(9)) THEN CALL SIGTC ELSEIF(KEYS(11)) THEN CALL SIGKKG ENDIF FAC1=SIGMA/SIG00 FACTOR=AMAX1(FACTOR,FAC1) 320 CONTINUE 310 CONTINUE ANORM(K)=ALOG(FACTOR)+ANORM(K) 300 CONTINUE C C Set up generating constants for PT**2 and QMW**2 C DO 400 K=NKL,NKH C1=1.-PTPOW(K) PTGN(1,K)=(PTMIN(3)**2+RNU2(K))**C1 PTGN(2,K)=(PTMAX(3)**2+RNU2(K))**C1-PTGN(1,K) PTGN(3,K)=1./C1 IF(K.EQ.2) THEN QGEN(1,2)=ATAN((QMN(2)**2-EMSQ)/EMGAM) QGEN(2,2)=ATAN((QMX(2)**2-EMSQ)/EMGAM)-QGEN(1,2) QGEN(3,2)=EMGAM ELSE B1=1.-QPOW(K) QGEN(1,K)=(QMN(K)/QMAX)**(2.*B1) QGEN(2,K)=(QMX(K)/QMAX)**(2.*B1)-QGEN(1,K) QGEN(3,K)=1./B1 ENDIF 400 CONTINUE C DO 410 K=1,3 410 QSELWT(K)=0. SUM=0. C DO 420 K=NKL,NKH QSELWT(K)=1. IF(.NOT.FIXQT) QSELWT(K)=QSELWT(K)*PTGN(2,K)*PTGN(3,K) IF(.NOT.FIXQM) THEN IF(K.EQ.2) THEN QSELWT(K)=QSELWT(K)*QGEN(2,K)/EMGAM ELSE QSELWT(K)=QMAX**2*QSELWT(K)*QGEN(2,K)*QGEN(3,K) ENDIF ENDIF QSELWT(K)=EXP(ALOG(QSELWT(K))+ANORM(K)) SUM=SUM+QSELWT(K) 420 CONTINUE C DO 430 K=1,3 QSELWT(K)=QSELWT(K)/SUM 430 CONTINUE C C Write fit to output C WRITE(ITLIS,4301) 4301 FORMAT(//10X,' QT AND Q FIRST GENERATED BY--'/) DO 440 K=NKL,NKH WRITE(ITLIS,4402) K,QMN(K),QMX(K) 4402 FORMAT(//5X,' REGION',I2,5X,E11.4,' < Q < ',E11.5) WRITE(ITLIS,4403) (PTGN(II,K),II=1,3),RNU2(K) 4403 FORMAT(/' QT**2 = (',E11.4,' + ',E11.4,' * RANF) ** ',E11.4, $ ' - ',E11.4) IF(K.NE.2) THEN WRITE(ITLIS,4404) QMAX2,(QGEN(II,K),II=1,3) 4404 FORMAT(/' Q**2 = ',E11.4,' * (',E11.4,' + ',E11.4, $ ' * RANF) ** ',E11.4) ELSE WRITE(ITLIS,4505) QGEN(3,K),QGEN(1,K),QGEN(2,K),EMSQ 4505 FORMAT(/' Q**2 = ',E11.4,' * TAN(',E11.4,' + ',E11.4, $ ' * RANF) + ',E11.4) ENDIF WRITE(ITLIS,4506) QSELWT(K) 4506 FORMAT(/' WEIGHT = ',E11.4) 440 CONTINUE C C Set fixed limits if any C IF(FIXQT) THEN PTMAX(3)=PTMIN(3) PT(3)=PTMIN(3) QTW=PT(3) ENDIF IF(FIXQM) THEN QMAX=QMIN QMW=QMIN ENDIF RETURN C C Fit fails if SIGMA=0 in allowed range C 999 WRITE(ITLIS,9990) QMW,QTW 9990 FORMAT(//' ERROR IN QFUNC...SIGMA=0 FOR QMW = ',E12.4,' , QTW = ', 1E12.4/' CHECK YOUR LIMITS') STOP 99 END +EOD +DECK,RANF,IF=RANFFTN,IF=NORANLUX. REAL FUNCTION RANF() C C Kernlib routine G900 in CERN Program Library C 7.70: Check ranf<1 C DOUBLE PRECISION DRANF, G900GT, G900ST DOUBLE PRECISION DS(2), DM(2), DSEED DOUBLE PRECISION DX24, DX48 DOUBLE PRECISION DL, DC, DU, DR LOGICAL SINGLE DATA DS / 1665 1885.D0, 286 8876.D0 / DATA DM / 1518 4245.D0, 265 1554.D0 / DATA DX24 / 1677 7216.D0 / DATA DX48 / 281 4749 7671 0656.D0 / SINGLE = .TRUE. GOTO 10 ENTRY DRANF() SINGLE = .FALSE. 10 DL = DS(1) * DM(1) DC = DINT(DL/DX24) DL = DL - DC*DX24 DU = DS(1)*DM(2) + DS(2)*DM(1) + DC DS(2) = DU - DINT(DU/DX24)*DX24 DS(1) = DL DR = (DS(2)*DX24 + DS(1)) / DX48 IF(SINGLE) THEN RANF = SNGL(DR) IF(RANF.GE.1) GO TO 10 ELSE DRANF = DR ENDIF RETURN ENTRY G900GT() G900GT = DS(2)*DX24 + DS(1) RETURN ENTRY G900ST(DSEED) DS(2) = DINT(DSEED/DX24) DS(1) = DSEED - DS(2)*DX24 G900ST = DS(1) RETURN END SUBROUTINE RANGET(SEED) DOUBLE PRECISION SEED, G900GT, G900ST, DUMMY SEED = G900GT() RETURN ENTRY RANSET(SEED) DUMMY = G900ST(SEED) RETURN END +EOD. +DECK,RANFGT,IF=NORANLUX. SUBROUTINE RANFGT(SEED) C C Get seed for RANF() in real or double precision SEED. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +SELF,IF=SINGLE REAL SEED +SELF,IF=DOUBLE DOUBLE PRECISION SEED +SELF +SELF,IF=RANFCALL CALL RANGET(SEED) +SELF,IF=CRAY INTEGER ISEED,RANGET,IDUMMY ISEED=RANGET(IDUMMY) SEED=ISEED +SELF RETURN END +EOD +DECK,RANFLUX,IF=RANLUX. REAL FUNCTION RANF() C C Call RANLUX instead of 48-bit congruental generator RANF C Dummy RANFGT/RANFST/RANFMT C DIMENSION X(1) CALL RANLUX(X,1) RANF=X(1) RETURN END C SUBROUTINE RANFGT(SEED) RETURN END SUBROUTINE RANFST(SEED) DOUBLE PRECISION SEED RETURN END SUBROUTINE RANFMT RETURN END +EOD +DECK,RANFMT,IF=NORANLUX. SUBROUTINE RANFMT C C Get RANF seed and translate it to a character variable C to ensure exactly the same seed with a formatted read. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,SEED. +SELF,IF=SINGLE REAL SEED +SELF,IF=DOUBLE. DOUBLE PRECISION SEED +SELF. CALL RANFGT(SEED) WRITE(XSEED,'(E24.15)') SEED READ(XSEED,'(E24.15)') SEED CALL RANFST(SEED) RETURN END +EOD +DECK,RANFST,IF=NORANLUX. SUBROUTINE RANFST(SEED) C C Set seed for RANF() from real or double precision SEED C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +SELF,IF=SINGLE REAL SEED +SELF,IF=DOUBLE DOUBLE PRECISION SEED +SELF +SELF,IF=RANFCALL CALL RANSET(SEED) +SELF,IF=CRAY INTEGER ISEED ISEED=SEED CALL RANSET(ISEED) +SELF RETURN END +EOD +DECK,RANLUX,IF=RANLUX SUBROUTINE RANLUX(RVEC,LENV) C Subtract-and-borrow random number generator proposed by C Marsaglia and Zaman, implemented by F. James with the name C RCARRY in 1991, and later improved by Martin Luescher C in 1993 to produce "Luxury Pseudorandom Numbers". C Fortran 77 coded by F. James, 1993 C C Modified from 1999 CERN Program Library by F. Paige: C CPP call removed (unused) C Use ITLIS for output C C LUXURY LEVELS. C ------ ------ The available luxury levels are: C C level 0 (p=24): equivalent to the original RCARRY of Marsaglia C and Zaman, very long period, but fails many tests. C level 1 (p=48): considerable improvement in quality over level 0, C now passes the gap test, but still fails spectral test. C level 2 (p=97): passes all known tests, but theoretically still C defective. C level 3 (p=223): DEFAULT VALUE. Any theoretically possible C correlations have very small chance of being observed. C level 4 (p=389): highest possible luxury, all 24 bits chaotic. C C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C!!! Calling sequences for RANLUX: ++ C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ C!!! 32-bit random floating point numbers between ++ C!!! zero (not included) and one (also not incl.). ++ C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ C!!! one 32-bit integer INT and sets Luxury Level LUX ++ C!!! which is integer between zero and MAXLEV, or if ++ C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ C!!! should be set to zero unless restarting at a break++ C!!! point given by output of RLUXAT (see RLUXAT). ++ C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ C!!! which can be used to restart the RANLUX generator ++ C!!! at the current point by calling RLUXGO. K1 and K2++ C!!! specify how many numbers were generated since the ++ C!!! initialization with LUX and INT. The restarting ++ C!!! skips over K1+K2*E9 numbers, so it can be long.++ C!!! A more efficient but less convenient way of restarting is by: ++ C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ C!!! 32-bit integer seeds, to be used for restarting ++ C!!! ISVEC must be dimensioned 25 in the calling program ++ C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +CDE,ITAPES C DIMENSION RVEC(LENV) DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) PARAMETER (MAXLEV=4, LXDFLT=3) DIMENSION NDSKIP(0:MAXLEV) DIMENSION NEXT(24) PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) PARAMETER (ITWO24=2**24, ICONS=2147483563) SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED INTEGER LUXLEV LOGICAL NOTYET DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ DATA I24,J24,CARRY/24,10,0./ C default C Luxury Level 0 1 2 *3* 4 DATA NDSKIP/0, 24, 73, 199, 365 / Corresponds to p=24 48 97 223 389 C time factor 1 2 3 6 10 on slow workstation C 1 1.5 2 3 5 on fast mainframe C C NOTYET is .TRUE. if no initialization has been performed yet. C Default Initialization by Multiplicative Congruential IF (NOTYET) THEN NOTYET = .FALSE. JSEED = JSDFLT INSEED = JSEED WRITE(ITLIS,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED LUXLEV = LXDFLT NSKIP = NDSKIP(LUXLEV) LP = NSKIP + 24 IN24 = 0 KOUNT = 0 MKOUNT = 0 WRITE(ITLIS,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', + LUXLEV,' p =',LP TWOM24 = 1. DO 25 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 25 CONTINUE TWOM12 = TWOM24 * 4096. DO 50 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 50 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ENDIF C C The Generator proper: "Subtract-with-borrow", C as proposed by Marsaglia and Zaman, C Florida State University, March, 1989 C DO 100 IVEC= 1, LENV UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) RVEC(IVEC) = UNI C small numbers (with less than 12 "significant" bits) are "padded". IF (UNI .LT. TWOM12) THEN RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) C and zero is forbidden in case someone takes a logarithm IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 ENDIF C Skipping to luxury. As proposed by Martin Luscher. IN24 = IN24 + 1 IF (IN24 .EQ. 24) THEN IN24 = 0 KOUNT = KOUNT + NSKIP DO 90 ISK= 1, NSKIP UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 90 CONTINUE ENDIF 100 CONTINUE KOUNT = KOUNT + LENV IF (KOUNT .GE. IGIGA) THEN MKOUNT = MKOUNT + 1 KOUNT = KOUNT - IGIGA ENDIF RETURN C C Entry to input and float integer seeds from previous run ENTRY RLUXIN(ISDEXT) NOTYET = .FALSE. TWOM24 = 1. DO 195 I= 1, 24 NEXT(I) = I-1 195 TWOM24 = TWOM24 * 0.5 NEXT(1) = 24 TWOM12 = TWOM24 * 4096. WRITE(ITLIS,'(A)') $' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' WRITE(ITLIS,'(5X,5I12)') ISDEXT DO 200 I= 1, 24 SEEDS(I) = REAL(ISDEXT(I))*TWOM24 200 CONTINUE CARRY = 0. IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 ISD = IABS(ISDEXT(25)) I24 = MOD(ISD,100) ISD = ISD/100 J24 = MOD(ISD,100) ISD = ISD/100 IN24 = MOD(ISD,100) ISD = ISD/100 LUXLEV = ISD IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) WRITE (ITLIS,'(A,I2)') $ ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', + LUXLEV ELSE IF (LUXLEV .GE. 24) THEN NSKIP = LUXLEV - 24 WRITE (ITLIS,'(A,I5)') $ ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV ELSE NSKIP = NDSKIP(MAXLEV) WRITE (ITLIS,'(A,I5)') $ ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV LUXLEV = MAXLEV ENDIF INSEED = -1 RETURN C C Entry to ouput seeds as integers ENTRY RLUXUT(ISDEXT) DO 300 I= 1, 24 ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) 300 CONTINUE ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) RETURN C C Entry to output the "convenient" restart point ENTRY RLUXAT(LOUT,INOUT,K1,K2) LOUT = LUXLEV INOUT = INSEED K1 = KOUNT K2 = MKOUNT RETURN C C Entry to initialize from one or three integers ENTRY RLUXGO(LUX,INS,K1,K2) IF (LUX .LT. 0) THEN LUXLEV = LXDFLT ELSE IF (LUX .LE. MAXLEV) THEN LUXLEV = LUX ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN LUXLEV = MAXLEV WRITE (ITLIS,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX ELSE LUXLEV = LUX DO 310 ILX= 0, MAXLEV IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX 310 CONTINUE ENDIF IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) WRITE(ITLIS,'(A,I2,A,I4)') $ ' RANLUX LUXURY LEVEL SET BY RLUXGO :', + LUXLEV,' P=', NSKIP+24 ELSE NSKIP = LUXLEV - 24 WRITE (ITLIS,'(A,I5)') $ ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV ENDIF IN24 = 0 IF (INS .LT. 0) WRITE (ITLIS,'(A)') + ' Illegal initialization by RLUXGO, negative input seed' IF (INS .GT. 0) THEN JSEED = INS WRITE(ITLIS,'(A,3I12)') $ ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', + JSEED, K1,K2 ELSE JSEED = JSDFLT WRITE(ITLIS,'(A)') $ ' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' ENDIF INSEED = JSEED NOTYET = .FALSE. TWOM24 = 1. DO 325 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 325 CONTINUE TWOM12 = TWOM24 * 4096. DO 350 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 350 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 C If restarting at a break point, skip K1 + IGIGA*K2 C Note that this is the number of numbers delivered to C the user PLUS the number skipped (if luxury .GT. 0). KOUNT = K1 MKOUNT = K2 IF (K1+K2 .NE. 0) THEN DO 500 IOUTER= 1, K2+1 INNER = IGIGA IF (IOUTER .EQ. K2+1) INNER = K1 DO 450 ISK= 1, INNER UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 450 CONTINUE 500 CONTINUE C Get the right value of IN24 by direct calculation IN24 = MOD(KOUNT, NSKIP+24) IF (MKOUNT .GT. 0) THEN IZIP = MOD(IGIGA, NSKIP+24) IZIP2 = MKOUNT*IZIP + IN24 IN24 = MOD(IZIP2, NSKIP+24) ENDIF C Now IN24 had better be between zero and 23 inclusive IF (IN24 .GT. 23) THEN WRITE (ITLIS,'(A/A,3I11,A,I5)') + ' Error in RESTARTING with RLUXGO:',' The values', INS, + K1, K2, ' cannot occur at luxury level', LUXLEV IN24 = 0 ENDIF ENDIF RETURN END +EOD +DECK,READIN. SUBROUTINE READIN(IFL) C C Read in user data and execute SETTYP if appropriate values C are set. IFL return values: C IFL = 0 Good parameter set C IFL = 1001 Stop C IFL > 0 Error. Program will continue reading data but C will exit when END or unrecognizable keyword C is found. C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,MBGEN +CDE,FORCE +CDE,DKYTAB +CDE,QCDPAR +CDE,EEPAR +CDE,IDRUN +CDE,FRGPAR +CDE,KEYS +CDE,KKGRAV +CDE,PRTOUT +CDE,SEED +CDE,TYPES +CDE,PRIMAR +CDE,JETLIM +CDE,NODCAY +CDE,WCON +CDE,DYLIM +CDE,QLMASS +CDE,Q1Q2 +CDE,JETPAR +CDE,ISLOOP +CDE,TCPAR +CDE,XMSSM +CDE,SUGNU +CDE,W50510,T=PASS,IF=PDFLIB +CDE,W50517,T=PASS,IF=PDFLIB +CDE,HCON +CDE,MGLIMS +CDE,LUXPAR C LOGICAL SETTYP,DUMY CHARACTER*8 TTL(10),WORD,LSTRUC,BLANK CHARACTER*8 WTYP(4),RDID(2) CHARACTER*40 V,VISAJE INTEGER NLAP(3,17) INTEGER IDANTI,ID,IDB INTEGER IFL,I1,I2,I3,J1,I,IKEY,IJ,J,KK,IDABS INTEGER IDXQKL,IDXQKR INTEGER NSEL,K,KFORCE(5),INDEX,IDG1,IDG2,IDG3,IDG4,IDXLEP REAL AMW,AMZ CHARACTER*8 HTYPE INTEGER JLIM1,JLIM2 REAL AMLIM1,AMLIM2 +SELF,IF=SINGLE. REAL SEED +SELF,IF=DOUBLE. DOUBLE PRECISION SEED +SELF. +SELF,IF=PDFLIB CHARACTER*20 PDFPAR(20) +SELF,IF=PDFLIB,IF=SINGLE REAL PDFVAL(20) REAL DX,DSCALE,DXPDF(-6:6) +SELF,IF=PDFLIB,IF=DOUBLE DOUBLE PRECISION PDFVAL(20) DOUBLE PRECISION DX,DSCALE,DXPDF(-6:6) +SELF C C Overlapping variable flags. DATA NLAP/1,2,3, 1,2,7 ,1,2,8, 1,3,5, 1,3,6, 1,3,7, 1,3,8, 1,5,7, X 1,5,8, 1,6,7, 1,6,8, 2,3,7, 2,3,8, 3,5,7, 3,6,7, 3,5,8, X 3,6,8/ DATA BLANK/' '/ C C Entry IFL=0 V=VISAJE() WRITE(ITLIS,10) V 10 FORMAT('1',//5X,'***** ',A40,' *****') WRITE(ITLIS,11) 11 FORMAT(////30X,' COMMANDS READ BY READIN') C C Read title C READ(ITCOM,1) TTL 1 FORMAT(10A8) WRITE(ITLIS,2) TTL 2 FORMAT(' ',10A8) IF(TTL(1).EQ.'STOP ') THEN IFL=1001 RETURN ENDIF C C Read energy and no. of events C READ(ITCOM,*) ECM,NEVENT,NEVPRT,NJUMP WRITE(ITLIS,*) ECM,NEVENT,NEVPRT,NJUMP C C Reset all variables and set process if title is not 'SAME' C IF(TTL(1).NE.'SAME ') THEN DO 20 I=1,10 20 TITLE(I)=TTL(I) CALL RESET KEYON=.FALSE. C Read reaction READ(ITCOM,3) REAC 3 FORMAT(A8) WRITE(ITLIS,4) REAC 4 FORMAT(1X,A8) DO 18 I=1,MXKEYS 18 KEYS(I)=.FALSE. KEYON=.FALSE. C Set KEYS and NJET IF(REAC.EQ.'TWOJET ') THEN KEYS(1)=.TRUE. IKEY=1 NJET=2 ELSEIF(REAC.EQ.'E+E- ') THEN KEYS(2)=.TRUE. IKEY=2 NJET=2 IDIN(1)=12 IDIN(2)=-12 ELSEIF(REAC.EQ.'DRELLYAN') THEN KEYS(3)=.TRUE. IKEY=3 NJET=3 ELSEIF(REAC.EQ.'MINBIAS ') THEN KEYS(4)=.TRUE. IKEY=4 NJET=0 ELSEIF(REAC.EQ.'SUPERSYM'.OR.REAC.EQ.'SUSY ') THEN KEYS(5)=.TRUE. IKEY=5 NJET=2 ELSEIF(REAC.EQ.'WPAIR ') THEN KEYS(6)=.TRUE. IKEY=6 NJET=2 ELSEIF(REAC.EQ.'HIGGS ') THEN KEYS(7)=.TRUE. IKEY=7 NJET=2 ELSEIF(REAC.EQ.'PHOTON ') THEN KEYS(8)=.TRUE. IKEY=8 NJET=2 ELSEIF(REAC.EQ.'TCOLOR ') THEN KEYS(9)=.TRUE. IKEYS=9 NJET=2 ELSEIF(REAC.EQ.'WHIGGS ') THEN KEYS(10)=.TRUE. IKEY=10 NJET=2 ELSEIF(REAC.EQ.'EXTRADIM') THEN KEYS(11)=.TRUE. IKEY=11 NJET=3 ELSEIF(REAC.EQ.'ZJJ ') THEN KEYS(12)=.TRUE. IKEY=12 NJET=3 ELSE KEYON=.FALSE. 890 WRITE(ITLIS,1999) IFL=9 RETURN ENDIF ENDIF C SCM=ECM**2 HALFE=ECM/2 NSEL=0 C C Read keyword. For each recognized keyword read corresponding C variables and set LOC flag. C NSEL=0 100 CONTINUE READ(ITCOM,3) WORD WRITE(ITLIS,4) WORD NSEL=NSEL+1 C C Keyword END IF(WORD.EQ.'END ') THEN C Check for previous error IF(IFL.NE.0) RETURN C Check inconsistent limits IF(LOC(2)*LOC(5).NE.0.OR.LOC(2)*LOC(6).NE.0) THEN WRITE(ITLIS,2001) IFL=11 ENDIF C Set and check jet types IF(LOC(15).NE.0.OR.LOC(37).NE.0.OR.LOC(46).NE.0) THEN IF(SETTYP(0)) THEN WRITE(ITLIS,2006) IFL=12 ENDIF ENDIF C Check MSSM/SUGRA conflict IF((LOC(51).NE.0.OR.LOC(52).NE.0.OR.LOC(53).NE.0).AND. $ LOC(55).NE.0) THEN WRITE(ITLIS,2007) IFL=29 ENDIF C Check overlapping limits DO 120 I=1,17 I1=NLAP(1,I) I2=NLAP(2,I) I3=NLAP(3,I) IF(LOC(I1)*LOC(I2)*LOC(I3).NE.0) WRITE(ITLIS,1001) 120 CONTINUE C Setup PDFLIB +SELF,IF=PDFLIB IF(ISTRUC.EQ.-999) THEN WRITE(ITLIS,1200) 1200 FORMAT(// $ '1********************************'/ $ ' * *'/ $ ' * INITIALIZE PDFLIB FOR ISAJET *'/ $ ' * *'/ $ ' ********************************'/) N6=ITLIS IFLPRT=2 CALL PDFSET(PDFPAR,PDFVAL) CALL PFTOPDG(0.5D0,1.0D2,DXPDF) IFLPRT=0 ENDIF +SELF C Check EXTRADIM parameters are set IF(KEYS(11).AND.LOC(72).EQ.0) THEN WRITE(ITLIS,*) 'YOU FORGOT TO SET EXTRAD PARAMETERS' IFL=72 ENDIF C RETURN ENDIF C C Keyword P IF(WORD.EQ.'P ') THEN READ(ITCOM,*) (PMIN(K),PMAX(K),K=1,NJET) WRITE(ITLIS,*) (PMIN(K),PMAX(K),K=1,NJET) LOC(1)=NSEL GO TO 100 ENDIF C C Keyword Y IF(WORD.EQ.'Y ') THEN READ(ITCOM,*) (YJMIN(K),YJMAX(K),K=1,NJET) WRITE(ITLIS,*) (YJMIN(K),YJMAX(K),K=1,NJET) LOC(2)=NSEL GO TO 100 ENDIF C C Keyword X IF(WORD.EQ.'X ') THEN READ(ITCOM,*) (XJMIN(K),XJMAX(K),K=1,NJET) WRITE(ITLIS,*) (XJMIN(K),XJMAX(K),K=1,NJET) LOC(3)=NSEL GO TO 100 ENDIF C C Keyword PHI IF(WORD.EQ.'PHI ') THEN READ(ITCOM,*) (PHIMIN(K),PHIMAX(K),K=1,NJET) WRITE(ITLIS,*) (PHIMIN(K),PHIMAX(K),K=1,NJET) LOC(4)=NSEL GO TO 100 ENDIF C C Keyword TH IF(WORD.EQ.'TH '.OR.WORD.EQ.'THETA ') THEN READ(ITCOM,*) (THMIN(K),THMAX(K),K=1,NJET) WRITE(ITLIS,*) (THMIN(K),THMAX(K),K=1,NJET) LOC(5)=NSEL LOC(6)=NSEL GO TO 100 ENDIF C C Keyword PT IF(WORD.EQ.'PT '.OR.WORD.EQ.'PPERP ') THEN READ(ITCOM,*) (PTMIN(K),PTMAX(K),K=1,NJET) WRITE(ITLIS,*) (PTMIN(K),PTMAX(K),K=1,NJET) LOC(7)=NSEL LOC(8)=NSEL GO TO 100 ENDIF C C Keyword NODECAY IF(WORD.EQ.'NODECAY ') THEN READ(ITCOM,571) NODCAY 571 FORMAT(L1) WRITE(ITLIS,572) NODCAY 572 FORMAT(' ',L1) LOC(9)=NSEL GO TO 100 ENDIF C C Keyword NOETA IF(WORD.EQ.'NOETA ') THEN READ(ITCOM,571) NOETA WRITE(ITLIS,572) NOETA LOC(10)=NSEL GO TO 100 ENDIF C C Keyword NOPI0 IF(WORD.EQ.'NOPI0 ') THEN READ(ITCOM,571) NOPI0 WRITE(ITLIS,572) NOPI0 LOC(11)=NSEL GO TO 100 ENDIF C C Keyword BEAMS IF(WORD.EQ.'BEAMS ') THEN READ(ITCOM,*) RDID(1),RDID(2) WRITE(ITLIS,*) RDID(1),RDID(2) IDIN(1)=0 IDIN(2)=0 DO 123 K=1,2 IF(RDID(K).EQ.'P ') IDIN(K)=+1120 IF(RDID(K).EQ.'AP ') IDIN(K)=-1120 IF(RDID(K).EQ.'N ') IDIN(K)=+1220 IF(RDID(K).EQ.'AN ') IDIN(K)=-1220 123 CONTINUE IF(IDIN(1)*IDIN(2).EQ.0) THEN WRITE(ITLIS,2002) IFL=13 ENDIF LOC(12)=NSEL GO TO 100 ENDIF C C Keyword FRAGMENT IF(WORD.EQ.'FRAGMENT') THEN READ(ITCOM,*) FRPAR WRITE(ITLIS,*) FRPAR LOC(13)=NSEL GO TO 100 ENDIF C C Keyword SEED IF(WORD.EQ.'SEED ') THEN +SELF,IF=-RANLUX READ(ITCOM,*) SEED WRITE(ITLIS,*) SEED CALL RANFST(SEED) WRITE(XSEED,'(E24.15)') SEED LOC(14)=NSEL GO TO 100 +SELF,IF=RANLUX LUXK1=0 LUXK2=0 READ(ITCOM,*) LUXINT,LUXK1,LUXK2 WRITE(ITLIS,*) LUXINT,LUXK1,LUXK2 LOC(14)=NSEL GO TO 100 +SELF ENDIF C C Keywords JETTYPE1, JETTYPE2, JETTYPE3, ... C (Yes, this is ugly) IF(WORD.EQ.'JETTYPE1'.OR.WORD.EQ.'JETTYPE2'.OR. $WORD.EQ.'JETTYPE3'.OR.WORD.EQ.'JETTYPE4'.OR. $WORD.EQ.'JETTYPE5'.OR.WORD.EQ.'JETTYPE6'.OR. $WORD.EQ.'JETTYPE7'.OR.WORD.EQ.'JETTYPE8') THEN IF(WORD.EQ.'JETTYPE1') IJ=1 IF(WORD.EQ.'JETTYPE2') IJ=2 IF(WORD.EQ.'JETTYPE3') IJ=3 IF(WORD.EQ.'JETTYPE4') IJ=4 IF(WORD.EQ.'JETTYPE5') IJ=5 IF(WORD.EQ.'JETTYPE6') IJ=6 IF(WORD.EQ.'JETTYPE7') IJ=7 IF(WORD.EQ.'JETTYPE8') IJ=8 DO 151 K=1,30 JETYP(K,IJ)=BLANK 151 CONTINUE READ(ITCOM,*) (JETYP(K,IJ),K=1,30) DO 152 K=1,25 152 IF(JETYP(K,IJ).NE.BLANK) NJTTYP(IJ)=NJTTYP(IJ)+1 WRITE(ITLIS,*) (JETYP(K,IJ),K=1,NJTTYP(IJ)) LOC(15)=NSEL GO TO 100 ENDIF C C Keyword SIN2W IF(WORD.EQ.'SIN2W ') THEN READ(ITCOM,*) SIN2W WRITE(ITLIS,*) SIN2W LOC(17)=NSEL GO TO 100 ENDIF C C Keyword TMASS IF(WORD.EQ.'TMASS ') THEN READ(ITCOM,*) AMLEP(6),AMLEP(7),AMLEP(8) WRITE(ITLIS,*) AMLEP(6),AMLEP(7),AMLEP(8) LOC(18)=NSEL GO TO 100 ENDIF C C Keyword QMH IF(WORD.EQ.'QMH ') THEN READ(ITCOM,*) QMIN,QMAX WRITE(ITLIS,*) QMIN,QMAX LOC(19)=NSEL GO TO 100 ENDIF C C Keyword QMW IF(WORD.EQ.'QMW ') THEN READ(ITCOM,*) QMIN,QMAX WRITE(ITLIS,*) QMIN,QMAX LOC(19)=NSEL GO TO 100 ENDIF C C Keyword QTW IF(WORD.EQ.'QTW ') THEN READ(ITCOM,*) QTMIN,QTMAX WRITE(ITLIS,*) QTMIN,QTMAX LOC(20)=NSEL GO TO 100 ENDIF C C Keyword YW IF(WORD.EQ.'YW ') THEN READ(ITCOM,*) YWMIN,YWMAX WRITE(ITLIS,*) YWMIN,YWMAX LOC(21)=NSEL GO TO 100 ENDIF C C Keyword XW IF(WORD.EQ.'XW ') THEN READ(ITCOM,*) XWMIN,XWMAX WRITE(ITLIS,*) XWMIN,XWMAX LOC(22)=NSEL GO TO 100 ENDIF C C Keyword THW IF(WORD.EQ.'THW ') THEN READ(ITCOM,*) THWMIN,THWMAX WRITE(ITLIS,*) THWMIN,THWMAX LOC(23)=NSEL GO TO 100 ENDIF C C Keyword PHIW IF(WORD.EQ.'PHIW ') THEN READ(ITCOM,*) PHWMIN,PHWMAX WRITE(ITLIS,*) PHWMIN,PHWMAX LOC(24)=NSEL GO TO 100 ENDIF C C Keyword NONUNU IF(WORD.EQ.'NONUNU ') THEN READ(ITCOM,571) NONUNU WRITE(ITLIS,572) NONUNU LOC(25)=NSEL GO TO 100 ENDIF C C Keyword WTYPE IF(WORD.EQ.'WTYPE ') THEN DO 261 J=1,4 WTYP(J)=BLANK GODY(J)=.FALSE. 261 CONTINUE READ(ITCOM,*) WTYP WRITE(ITLIS,*) WTYP DO 262 K=1,4 IF(WTYP(K).EQ.'GM ') GODY(1)=.TRUE. IF(WTYP(K).EQ.'W+ ') GODY(2)=.TRUE. IF(WTYP(K).EQ.'W- ') GODY(3)=.TRUE. IF(WTYP(K).EQ.'Z0 ') GODY(4)=.TRUE. 262 CONTINUE IF(GODY(1)) JWTYP=1 IF(GODY(2).OR.GODY(3)) JWTYP=3 IF(GODY(4)) JWTYP=4 IF((GODY(2).OR.GODY(3)).AND.(GODY(1).OR.GODY(4))) THEN WRITE(ITLIS,2003) IFL=13 ENDIF LOC(26)=NSEL GO TO 100 ENDIF C C Keyword LAMBDA IF(WORD.EQ.'LAMBDA ') THEN READ(ITCOM,*) ALAM WRITE(ITLIS,*) ALAM ALAM2=ALAM**2 LOC(27)=NSEL GO TO 100 ENDIF C C Keyword NTRIES IF(WORD.EQ.'NTRIES ') THEN READ(ITCOM,*) NTRIES WRITE(ITLIS,*) NTRIES LOC(28)=NSEL GO TO 100 ENDIF C C Keyword CUTOFF IF(WORD.EQ.'CUTOFF ') THEN READ(ITCOM,*) CUTOFF,CUTPOW WRITE(ITLIS,*) CUTOFF,CUTPOW LOC(29)=NSEL GO TO 100 ENDIF C C Keyword XGEN IF(WORD.EQ.'XGEN ') THEN READ(ITCOM,*) XGEN WRITE(ITLIS,*) XGEN LOC(30)=NSEL GO TO 100 ENDIF C C Keyword SIGQT IF(WORD.EQ.'SIGQT ') THEN READ(ITCOM,*) SIGQT WRITE(ITLIS,*) SIGQT LOC(31)=NSEL GO TO 100 ENDIF C C Keyword CUTJET IF(WORD.EQ.'CUTJET ') THEN READ(ITCOM,*) CUTJET WRITE(ITLIS,*) CUTJET LOC(32)=NSEL GO TO 100 ENDIF C C Keyword WFUDGE IF(WORD.EQ.'WFUDGE ') THEN READ(ITCOM,*) WFUDGE WRITE(ITLIS,*) WFUDGE LOC(50)=NSEL GO TO 100 ENDIF C C Keyword STRUC IF(WORD.EQ.'STRUC ') THEN ISTRUC=0 READ(ITCOM,*) LSTRUC WRITE(ITLIS,4) LSTRUC IF(LSTRUC.EQ.'OWENS ') ISTRUC=1 IF(LSTRUC.EQ.'BAIER ') ISTRUC=2 IF(LSTRUC.EQ.'EICHTEN '.OR.LSTRUC.EQ.'EHLQ ') ISTRUC=3 IF(LSTRUC.EQ.'DUKE '.OR.LSTRUC.EQ.'DO ') ISTRUC=4 IF(LSTRUC.EQ.'CTEQ2L ') ISTRUC=5 IF(LSTRUC.EQ.'CTEQ3L ') ISTRUC=6 IF(LSTRUC.EQ.'CTEQ '.OR.LSTRUC.EQ.'CTEQ5L ') ISTRUC=7 IF(ISTRUC.EQ.0) THEN WRITE(ITLIS,2002) IFL=13 ENDIF LOC(33)=NSEL GO TO 100 ENDIF C C Keyword NPOMERON IF(WORD.EQ.'NPOMERON') THEN READ(ITCOM,*) MNPOM,MXPOM WRITE(ITLIS,*) MNPOM,MXPOM IF(MNPOM.LT.1.OR.MNPOM.GT.MXPOM.OR.MXPOM.GT.LIMPOM) THEN WRITE(ITLIS,2004) IFL=14 ENDIF LOC(34)=NSEL GO TO 100 ENDIF C C Keyword FORCE IF(WORD.EQ.'FORCE ') THEN NFORCE=NFORCE+1 IF(NFORCE.GT.MXFORC-1) THEN WRITE(ITLIS,2004) IFL=14 ENDIF DO 351 K=1,5 351 KFORCE(K)=0 READ(ITCOM,*) IFORCE(NFORCE),(KFORCE(K),K=1,5) CALL ORDER(IFORCE(NFORCE),KFORCE,MFORCE(1,NFORCE), $ MEFORC(NFORCE),.TRUE.) WRITE(ITLIS,*) IFORCE(NFORCE),(MFORCE(K,NFORCE),K=1,5) ID=IFORCE(NFORCE) IDABS=IABS(ID) IF(IDABS.LT.6) THEN WRITE(ITLIS,2005) IFL=15 ENDIF IDB=IDANTI(ID) IF(IDB.NE.ID) THEN IFORCE(NFORCE+1)=IDB DO 352 K=1,5 352 MFORCE(K,NFORCE+1)=IDANTI(MFORCE(K,NFORCE)) NFORCE=NFORCE+1 ENDIF LOC(35)=NSEL GO TO 100 ENDIF C C Keyword FORCE1 IF(WORD.EQ.'FORCE1 ') THEN NFORCE=NFORCE+1 IF(NFORCE.GT.MXFORC) THEN WRITE(ITLIS,2004) IFL=14 ENDIF DO 353 K=1,5 353 KFORCE(K)=0 READ(ITCOM,*) IFORCE(NFORCE),(KFORCE(K),K=1,5) CALL ORDER(IFORCE(NFORCE),KFORCE,MFORCE(1,NFORCE), $ MEFORC(NFORCE),.TRUE.) WRITE(ITLIS,*) IFORCE(NFORCE),(MFORCE(K,NFORCE),K=1,5) IF(IABS(IFORCE(NFORCE)).LT.6) THEN WRITE(ITLIS,2005) IFL=15 ENDIF LOC(35)=NSEL GO TO 100 ENDIF C C Keyword HMASSES - also see HMASS IF(WORD.EQ.'HMASSES ') THEN CALL FLAVOR(80,I1,I2,I3,J1,INDEX) READ(ITCOM,*) (AMLEP(INDEX+K),K=1,9) WRITE(ITLIS,*) (AMLEP(INDEX+K),K=1,9) LOC(36)=NSEL GO TO 100 ENDIF C C Keywords WMODE1,WMODE2 IF(WORD.EQ.'WMODE1 '.OR.WORD.EQ.'WMODE2 ') THEN IF(WORD.EQ.'WMODE1 ') IJ=1 IF(WORD.EQ.'WMODE2 ') IJ=2 READ(ITCOM,*) (WWTYP(K,IJ),K=1,25) DO 372 K=1,25 372 IF(WWTYP(K,IJ).NE.BLANK) NWWTYP(IJ)=NWWTYP(IJ)+1 WRITE(ITLIS,*) (WWTYP(K,IJ),K=1,NWWTYP(IJ)) LOC(37)=NSEL GO TO 100 ENDIF C C Keyword NOEVOLVE IF(WORD.EQ.'NOEVOLVE') THEN READ (ITCOM,571) NOEVOL WRITE(ITLIS,572) NOEVOL LOC(38)=NSEL GO TO 100 ENDIF C C Keyword NOHADRON IF(WORD.EQ.'NOHADRON') THEN READ (ITCOM,571) NOHADR WRITE(ITLIS,572) NOHADR LOC(39)=NSEL GO TO 100 ENDIF C C Keyword GAUGINO IF(WORD.EQ.'GAUGINO ') THEN CALL FLAVOR(29,I1,I2,I3,J1,IDG1) CALL FLAVOR(30,I1,I2,I3,J1,IDG2) CALL FLAVOR(39,I1,I2,I3,J1,IDG3) CALL FLAVOR(40,I1,I2,I3,J1,IDG4) READ(ITCOM,*) AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4) WRITE(ITLIS,*) AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4) LOC(40)=NSEL GO TO 100 ENDIF C C Keyword SQUARK IF(WORD.EQ.'SQUARK ') THEN CALL FLAVOR(21,I1,I2,I3,J1,IDXQKL) READ(ITCOM,*) (AMLEP(IDXQKL+K-1),K=1,6) WRITE(ITLIS,*) (AMLEP(IDXQKL+K-1),K=1,6) CALL FLAVOR(41,I1,I2,I3,J1,IDXQKR) DO 411 K=1,6 AMLEP(IDXQKR+K-1)=AMLEP(IDXQKL+K-1) 411 CONTINUE LOC(41)=NSEL GO TO 100 ENDIF C C Keyword SLEPTON IF(WORD.EQ.'SLEPTON ') THEN CALL FLAVOR(31,I1,I2,I3,J1,IDXLEP) READ(ITCOM,*) (AMLEP(IDXLEP+K-1),K=1,6) WRITE(ITLIS,*) (AMLEP(IDXLEP+K-1),K=1,6) LOC(42)=NSEL GO TO 100 ENDIF C C Keyword NSIGMA IF(WORD.EQ.'NSIGMA ') THEN READ(ITCOM,*) NSIGMA WRITE(ITLIS,*) NSIGMA LOC(43)=NSEL GO TO 100 ENDIF C C Keyword XGENSS IF(WORD.EQ.'XGENSS ') THEN READ(ITCOM,*) XGENSS(9),(XGENSS(KK),KK=1,8) WRITE(ITLIS,*) XGENSS(9),(XGENSS(KK),KK=1,8) LOC(44)=NSEL GO TO 100 ENDIF C C Keyword HMASS - just standard Higgs IF(WORD.EQ.'HMASS ') THEN CALL FLAVOR(81,I1,I2,I3,J1,INDEX) READ(ITCOM,*) AMLEP(INDEX) WRITE(ITLIS,*) AMLEP(INDEX) LOC(45)=NSEL GO TO 100 ENDIF C C Keywords WPMODE, WMMODE, Z0MODE IF(WORD.EQ.'WPMODE '.OR.WORD.EQ.'WMMODE ' $.OR.WORD.EQ.'Z0MODE ') THEN IF(WORD.EQ.'WPMODE ') IJ=1 IF(WORD.EQ.'WMMODE ') IJ=2 IF(WORD.EQ.'Z0MODE ') IJ=3 READ(ITCOM,*) (WMODES(K,IJ),K=1,25) DO 463 K=1,25 463 IF(WMODES(K,IJ).NE.BLANK) NWMODE(IJ)=NWMODE(IJ)+1 WRITE(ITLIS,*) (WMODES(K,IJ),K=1,NWMODE(IJ)) LOC(46)=NSEL GO TO 100 ENDIF C C Keyword WMASS IF(WORD.EQ.'WMASS ') THEN READ(ITCOM,*) AMW,AMZ WRITE(ITLIS,*) AMW,AMZ WMASS(1)=0. WMASS(2)=AMW WMASS(3)=AMW WMASS(4)=AMZ CALL FLAVOR(80,I1,I2,I3,J,INDEX) AMLEP(INDEX)=AMW CALL FLAVOR(90,I1,I2,I3,J,INDEX) AMLEP(INDEX)=AMZ LOC(47)=NSEL GO TO 100 ENDIF C C Keyword NEVOLVE IF(WORD.EQ.'NEVOLVE ') THEN READ(ITCOM,*) NEVOLV WRITE(ITLIS,*) NEVOLV LOC(48)=NSEL GO TO 100 ENDIF C C Keyword NHADRON IF(WORD.EQ.'NHADRON ') THEN READ(ITCOM,*) NFRGMN WRITE(ITLIS,*) NFRGMN LOC(49)=NSEL GO TO 100 ENDIF C C Keyword TCMASS IF(WORD.EQ.'TCMASS ') THEN READ(ITCOM,*) TCMRHO,TCGRHO WRITE(ITLIS,*) TCMRHO,TCGRHO LOC(50)=NSEL GO TO 100 ENDIF C C Keyword MSSMA: gluino, mu, mha, tanb IF(WORD.EQ.'MSSMA ') THEN READ(ITCOM,*) XGLSS,XMUSS,XHASS,XTBSS WRITE(ITLIS,*) XGLSS,XMUSS,XHASS,XTBSS GOMSSM=.TRUE. LOC(51)=NSEL GO TO 100 ENDIF C C Keyword MSSMB: 1st generation soft terms IF(WORD.EQ.'MSSMB ') THEN READ(ITCOM,*) XQ1SS,XDRSS,XURSS,XL1SS,XERSS WRITE(ITLIS,*) XQ1SS,XDRSS,XURSS,XL1SS,XERSS LOC(52)=NSEL GOMSSM=.TRUE. GO TO 100 ENDIF C C Keyword MSSMC: 3rd generation soft terms IF(WORD.EQ.'MSSMC ') THEN READ(ITCOM,*)XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS WRITE(ITLIS,*)XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS LOC(53)=NSEL GOMSSM=.TRUE. GO TO 100 ENDIF C C Keyword PDFLIB: parameters for PDFLIB +SELF,IF=PDFLIB IF(WORD.EQ.'PDFLIB ') THEN DO 541 I=1,20 PDFPAR(I)=' ' PDFVAL(I)=0 541 CONTINUE READ(ITCOM,*) (PDFPAR(I),PDFVAL(I),I=1,20) DO 542 I=1,20 IF(PDFPAR(I).NE.' ') THEN WRITE(ITLIS,*) PDFPAR(I),PDFVAL(I) ENDIF 542 CONTINUE ISTRUC=-999 LOC(54)=NSEL GO TO 100 ENDIF +SELF C C Keyword SUGRA IF(WORD.EQ.'SUGRA ') THEN READ(ITCOM,*) XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU WRITE(ITLIS,*) XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU LOC(55)=NSEL GOMSSM=.TRUE. GOSUG=.TRUE. GO TO 100 ENDIF C C Keyword HTYPE IF(WORD.EQ.'HTYPE ') THEN READ(ITCOM,*) HTYPE WRITE(ITLIS,*) HTYPE LOC(56)=NSEL IHTYPE=0 IF(HTYPE.EQ.'HL0 ') IHTYPE=82 IF(HTYPE.EQ.'HH0 ') IHTYPE=83 IF(HTYPE.EQ.'HA0 ') IHTYPE=84 IF(IHTYPE.EQ.0) THEN WRITE(ITLIS,2000) HTYPE IFL=16 ENDIF GO TO 100 ENDIF C C Keyword EPOL IF(WORD.EQ.'EPOL ') THEN READ(ITCOM,*) PLEM,PLEP WRITE(ITLIS,*) PLEM,PLEP LOC(57)=NSEL GO TO 100 ENDIF C C Keyword MSSMD: optional 2nd geenration soft terms IF(WORD.EQ.'MSSMD ') THEN READ(ITCOM,*) XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS WRITE(ITLIS,*) XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS LOC(58)=NSEL GO TO 100 ENDIF C C Keyword MSSME: optional U(1) and SU(2) gaugino masses IF(WORD.EQ.'MSSME ') THEN READ(ITCOM,*) XM1SS,XM2SS WRITE(ITLIS,*) XM1SS,XM2SS LOC(59)=NSEL GO TO 100 ENDIF C C Keyword GMSB: gauge-mediated SUSY breaking model IF(WORD.EQ.'GMSB ') THEN READ(ITCOM,*) XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV WRITE(ITLIS,*) XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV GOMSSM=.TRUE. GOGMSB=.TRUE. LOC(60)=NSEL GO TO 100 ENDIF C C Keyword NUSUG1: optional GUT scale gaugino masses IF(WORD.EQ.'NUSUG1 ') THEN READ(ITCOM,*) XNUSUG(1),XNUSUG(2),XNUSUG(3) WRITE(ITLIS,*) XNUSUG(1),XNUSUG(2),XNUSUG(3) LOC(61)=NSEL GO TO 100 ENDIF C C Keyword NUSUG2: optional GUT scale A terms IF(WORD.EQ.'NUSUG2 ') THEN READ(ITCOM,*) XNUSUG(6),XNUSUG(5),XNUSUG(4) WRITE(ITLIS,*) XNUSUG(6),XNUSUG(5),XNUSUG(4) LOC(62)=NSEL GO TO 100 ENDIF C C Keyword NUSUG3: optional GUT scale Higgs masses IF(WORD.EQ.'NUSUG3 ') THEN READ(ITCOM,*) XNUSUG(7),XNUSUG(8) WRITE(ITLIS,*) XNUSUG(7),XNUSUG(8) LOC(63)=NSEL GO TO 100 ENDIF C C Keyword NUSUG4: optional GUT scale 1st/2nd gen. masses IF(WORD.EQ.'NUSUG4 ') THEN READ(ITCOM,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10) $,XNUSUG(9) WRITE(ITLIS,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10) $,XNUSUG(9) LOC(64)=NSEL GO TO 100 ENDIF C C Keyword NUSUG5: optional GUT scale 3rd gen. masses IF(WORD.EQ.'NUSUG5 ') THEN READ(ITCOM,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15) $,XNUSUG(14) WRITE(ITLIS,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15) $,XNUSUG(14) LOC(65)=NSEL GO TO 100 ENDIF C C Keyword NOGRAV: No gravitino decays IF(WORD.EQ.'NOGRAV ') THEN READ(ITCOM,571) NOGRAV WRITE(ITLIS,572) NOGRAV LOC(66)=NSEL GO TO 100 ENDIF C C Keyword MGVTNO: Sets the gravitino mass IF(WORD.EQ.'MGVTNO ') THEN READ(ITCOM,*) XMGVTO WRITE(ITLIS,*) XMGVTO LOC(67)=NSEL GO TO 100 ENDIF C C Keyword AL3UNI: Impose alpha_s unification at M_GUT IF(WORD.EQ.'AL3UNI ') THEN READ(ITCOM,571) AL3UNI WRITE(ITLIS,572) AL3UNI LOC(68)=NSEL GO TO 100 ENDIF C C Keyword GMSB2: additional GMSB parameters IF(WORD.EQ.'GMSB2 ') THEN READ(ITCOM,*) XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM WRITE(ITLIS,*) XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM LOC(69)=NSEL GO TO 100 ENDIF C C Keyword EEBREM: invoke bremsstrahlung in e+e- reactions IF(WORD.EQ.'EEBREM ') THEN READ(ITCOM,*) RSHMIN,RSHMAX WRITE(ITLIS,*) RSHMIN,RSHMAX IBREM=.TRUE. LOC(70)=NSEL GO TO 100 ENDIF C C Keyword EEBEAM: invoke beamstrahlung in e+e- reactions IF(WORD.EQ.'EEBEAM ') THEN READ(ITCOM,*) RSHMIN,RSHMAX,UPSLON,SIGZ WRITE(ITLIS,*) RSHMIN,RSHMAX,UPSLON,SIGZ IBREM=.TRUE. IBEAM=.TRUE. LOC(71)=NSEL GO TO 100 ENDIF C C Keyword QMKKG (QMW for EXTRADIM) IF(WORD.EQ.'QMKKG ') THEN READ(ITCOM,*) QMIN,QMAX WRITE(ITLIS,*) QMIN,QMAX LOC(19)=NSEL GO TO 100 ENDIF C C Keyword QTKKG (QTW for EXTRADIM) IF(WORD.EQ.'QTKKG ') THEN READ(ITCOM,*) QTMIN,QTMAX WRITE(ITLIS,*) QTMIN,QTMAX LOC(20)=NSEL GO TO 100 ENDIF C C Keyword EXTRAD for EXTRADIM IF(WORD.EQ.'EXTRAD ') THEN READ(ITCOM,*) NEXTRAD,MASSD,UVCUT WRITE(ITLIS,*) NEXTRAD,MASSD,UVCUT LOC(72)=NSEL GO TO 100 ENDIF C C Keyword MIJLIM IF(WORD.EQ.'MIJLIM ') THEN READ(ITCOM,*) JLIM1,JLIM2,AMLIM1,AMLIM2 WRITE(ITLIS,*) JLIM1,JLIM2,AMLIM1,AMLIM2 IF(JLIM1.EQ.0.AND.JLIM2.EQ.0) THEN DO 720 I=1,NJET DO 721 J=1,NJET AMIJMN(I,J)=AMLIM1 AMIJMX(I,J)=AMLIM2 721 CONTINUE 720 CONTINUE ELSEIF(JLIM1.GT.0.AND.JLIM1.LE.NJET.AND.JLIM2.GT.0.AND. $ JLIM2.LE.NJET) THEN AMIJMN(JLIM1,JLIM2)=AMLIM1 AMIJMN(JLIM2,JLIM1)=AMLIM1 AMIJMX(JLIM1,JLIM2)=AMLIM2 AMIJMX(JLIM2,JLIM1)=AMLIM2 ELSE WRITE(ITLIS,2008) IFL=73 ENDIF LOC(73)=NSEL GO TO 100 ENDIF C C Keyword MTOT IF(WORD.EQ.'MTOT ') THEN READ(ITCOM,*) EHMGMN,EHMGMX WRITE(ITLIS,*) EHMGMN,EHMGMX LOC(74)=NSEL GO TO 100 ENDIF C C Keyword SUGRHN IF(WORD.EQ.'SUGRHN ') THEN READ(ITCOM,*) XMN3NR,XMAJNR,XANSS,XNRSS WRITE(ITLIS,*) XMN3NR,XMAJNR,XANSS,XNRSS LOC(75)=NSEL GO TO 100 ENDIF C C Keyword AMSB IF(WORD.EQ.'AMSB ') THEN READ(ITCOM,*) XM0SU,XMHSU,XTGBSU,XSMUSU WRITE(ITLIS,*) XM0SU,XMHSU,XTGBSU,XSMUSU LOC(76)=NSEL GOMSSM=.TRUE. GOSUG=.TRUE. GOAMSB=.TRUE. GO TO 100 ENDIF C C Keyword SSBCSC IF(WORD.EQ.'SSBCSC ') THEN READ(ITCOM,*) XSBCS WRITE(ITLIS,*) XSBCS LOC(77)=NSEL GO TO 100 ENDIF C C Keyword NOB IF(WORD.EQ.'NOB ') THEN READ(ITCOM,*) NOB WRITE(ITLIS,*) NOB LOC(78)=NSEL GO TO 100 ENDIF C C Keyword NOTAU IF(WORD.EQ.'NOTAU ') THEN READ(ITCOM,*) NOTAU WRITE(ITLIS,*) NOTAU LOC(79)=NSEL GO TO 100 ENDIF C C Keyword GAMGAM IF(WORD.EQ.'GAMGAM ') THEN READ(ITCOM,*) GAMGAM WRITE(ITLIS,*) GAMGAM LOC(80)=NSEL GO TO 100 ENDIF C C Keyword AMSB2: additional AMSB parameters IF(WORD.EQ.'AMSB2 ') THEN READ(ITCOM,*) XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM WRITE(ITLIS,*) XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM LOC(81)=NSEL GO TO 100 ENDIF C C Keyword NUHM: input mu(Q), mA(Q) in lieu of mHd, mHu IF(WORD.EQ.'NUHM ') THEN READ(ITCOM,*) XNUSUG(19),XNUSUG(20) WRITE(ITLIS,*) XNUSUG(19),XNUSUG(20) LOC(82)=NSEL INUHM=1 GO TO 100 ENDIF C C Keyword MMAMSB IF(WORD.EQ.'MMAMSB ') THEN READ(ITCOM,*) XM0SU,XMHSU,XTGBSU,XSMUSU,XCQAM,XCDAM,XCUAM, $XCLAM,XCEAM,XCHDAM,XCHUAM,XL1AM,XL2AM,XL3AM WRITE(ITLIS,*) XM0SU,XMHSU,XTGBSU,XSMUSU,XCQAM,XCDAM,XCUAM, $XCLAM,XCEAM,XCHDAM,XCHUAM,XL1AM,XL2AM,XL3AM LOC(83)=NSEL GOMSSM=.TRUE. GOSUG=.TRUE. GOMMAM=.TRUE. GO TO 100 ENDIF C C Keyword WRTLHE IF(WORD.EQ.'WRTLHE') THEN READ (ITCOM,571) WRTLHE WRITE(ITLIS,572) WRTLHE LOC(84)=NSEL GO TO 100 ENDIF C C Keyword HCAMSB IF(WORD.EQ.'HCAMSB ') THEN READ(ITCOM,*) XM0SU,XMHSU,XTGBSU,XSMUSU WRITE(ITLIS,*) XM0SU,XMHSU,XTGBSU,XSMUSU LOC(85)=NSEL GOMSSM=.TRUE. GOSUG=.TRUE. GOHCAM=.TRUE. GO TO 100 ENDIF C C None of the above C WRITE(ITLIS,2000) WORD IFL=10 RETURN C C Error message or warnings C 1001 FORMAT(//2X,'YOU HAVE GIVEN LIMITS FOR AN OVERLAPPING SET', $ ' OF VARIABLES. SET MINIMIZING PPERP INTERVAL WILL BE USED.') 1999 FORMAT(//' YOU FORGOT TO SELECT A PROCESS FOR GENERATION.' $ /' AVAILABLE AT PRESENT ARE ', $ /' TWOJET E+E- DRELLYAN MINBIAS WPAIR SUPERSYM,' $ /' HIGGS PHOTON TCOLOR') 2000 FORMAT(//2X,A8,' IS NOT A RECOGNIZABLE PARAMETER. JOB TERMINATED') 2001 FORMAT(//2X,' YOU CANNOT GIVE LIMITS FOR BOTH THETA AND Y.', $ ' MAKE UP YOUR MIND. JOB TERMINATED.') 2002 FORMAT(/' WHAT IS THAT SUPPOSED TO BE') 2003 FORMAT(/' YOU CANNOT RUN WS AND Z0 OR GAMMAS AT THE', $ ' SAME TIME. JOB TERMINATED') 2004 FORMAT(//' PARAMETER OUT OF RANGE. JOB TERMINATED.') 2005 FORMAT(//' YOU CANNOT FORCE DECAY OF A QUARK, YOU MUST CHOSE ' $,' A PARTICLE') 2006 FORMAT(//2X,' INVALID JETTYPE VALUES. JOB TERMINATED.') 2007 FORMAT(//2X,'YOU CANNOT USE MSSM AND SUGRA SIMULTANEOUSLY') 2008 FORMAT(//2X,'INVALID JET-JET MASS LIMITS. JOB TERMINATED.') C END +EOD +DECK,REJFRG. LOGICAL FUNCTION REJFRG() C----------------------------------------------------------------------- C- C- This is called after FRGMNT for TWOJET and DRELLYAN events C- to test the fragmentation. REJFRG=.FALSE. keeps the event. C- C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,PARTCL INTEGER I,ID REAL PTL,CUTLEP,CUTNU DATA CUTLEP/50./,CUTNU/100./ REJFRG=.FALSE. C*************************************** C Sample REJFRG function which keeps the event if it contains C any lepton satisfying C PT > CUTLEP (charged lepton) C PT > CUTNU (neutrino) C Appropriate values of the cuts must be set by the user. C REJFRG=.TRUE. C DO 1 I=1,NPTCL C IF(IDCAY(I).NE.0) GO TO 1 C ID=IABS(IDENT(I)) C IF(ID.LE.10.OR.ID.GE.20) GO TO 1 C PTL=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2) C IF((ID.EQ.11.OR.ID.EQ.13.OR.ID.EQ.15).AND.PTL.GT.CUTNU) THEN C REJFRG=.FALSE. C RETURN C ELSEIF((ID.EQ.12..OR.ID.EQ.14).AND.PTL.GT.CUTLEP) THEN C REJFRG=.FALSE. C RETURN C ENDIF C 1 CONTINUE C*************************************** RETURN END +EOD +DECK,REJJET. LOGICAL FUNCTION REJJET() C----------------------------------------------------------------------- C- C- This is called after EVOLVE for TWOJET and DRELLYAN events C- to test the partons (jets). REJJET=.FALSE. keeps the event. C- C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,JETSET INTEGER I,IFLAV REJJET=.FALSE. C*************************************** C Sample REJJET function which keeps the event if one of the C outgoing partons is a heavy quark. C REJJET=.TRUE. C DO 1 I=1,NJSET C IF(JDCAY(I).NE.0) GO TO 1 C IFLAV=IABS(JTYPE(I)) C IF(IFLAV.GE.4.AND.IFLAV.LT.9) THEN C REJJET=.FALSE. C RETURN C ENDIF C 1 CONTINUE C*************************************** RETURN END +EOD +DECK,RESCAL. SUBROUTINE RESCAL(N1,N2,PSUM,IFAIL) C RESCALE MOMENTA OF PARTICLES N1...N2 TO GIVE TOTAL C FOUR-MOMENTUM PSUM. C RETURN IFAIL=0 IF OK, IFAIL=1 IF NO GOOD. +CDE,ITAPES +CDE,PARTCL DIMENSION PSUM(5),PADD(5),BETA(3) DATA ERRLIM/.0001/ C ORIGIONAL MOMENTUM IS PADD. IFAIL=1 IF(N1.GE.N2) RETURN DO 100 K=1,5 100 PADD(K)=0. DO 110 IP=N1,N2 DO 110 K=1,5 PADD(K)=PADD(K)+PPTCL(K,IP) 110 CONTINUE IF(PADD(5).GE.PSUM(5)) RETURN PADD(5)=PADD(4)**2-PADD(1)**2-PADD(2)**2-PADD(3)**2 IF(PADD(5).LE.0) RETURN PADD(5)=SQRT(PADD(5)) DO 120 K=1,3 120 BETA(K)=-PADD(K)/PADD(5) GAMMA=PADD(4)/PADD(5) C BOOST PARTICLES TO REST. 200 CONTINUE DO 210 IP=N1,N2 BP=0. DO 220 K=1,3 220 BP=BP+PPTCL(K,IP)*BETA(K) DO 230 K=1,3 230 PPTCL(K,IP)=PPTCL(K,IP)+BETA(K)*PPTCL(4,IP) $+BETA(K)*BP/(GAMMA+1.) PPTCL(4,IP)=GAMMA*PPTCL(4,IP)+BP 210 CONTINUE IF(IFAIL.EQ.0) RETURN C RESCALE MOMENTA IN REST FRAME. SCAL=1. DO 301 IPASS=1,200 SUM=0. DO 310 IP=N1,N2 DO 320 K=1,3 320 PPTCL(K,IP)=SCAL*PPTCL(K,IP) PPTCL(4,IP)=SQRT(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(3,IP)**2 $+PPTCL(5,IP)**2) SUM=SUM+PPTCL(4,IP) 310 CONTINUE SCAL=PSUM(5)/SUM 301 IF(ABS(SCAL-1.).LE.ERRLIM) GO TO 300 300 CONTINUE C BOOST BACK WITH PSUM. BMAG=0. DO 400 K=1,3 BETA(K)=PSUM(K)/PSUM(5) BMAG=BMAG+ABS(BETA(K)) 400 CONTINUE GAMMA=PSUM(4)/PSUM(5) IFAIL=0 IF(BMAG.EQ.0.) RETURN GO TO 200 END +EOD +DECK,RESET. SUBROUTINE RESET C RESET ALL USER DEFINED VARIABLES +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,DYLIM +CDE,FRGPAR +CDE,HCON +CDE,JETLIM +CDE,JETPAR +CDE,NODCAY +CDE,PRIMAR +CDE,QLMASS +CDE,Q1Q2 +CDE,SEED +CDE,SSPAR +CDE,TCPAR +CDE,TYPES +CDE,WCON +CDE,FORCE +CDE,MBGEN +CDE,ISLOOP +CDE,LIMEVL +CDE,XMSSM +CDE,EEPAR +CDE,MGLIMS +CDE,SUGXIN +CDE,SSMODE C INTEGER I,I1,I2,I3,J1,INDEX,J,K REAL UNDEF,AMASS CHARACTER*8 BLANK DATA BLANK/' '/ DATA UNDEF/-1.E9/ C RESET DYLIM DO 110 I=1,12 BLIM1(I)=UNDEF SETLMQ(I)=.TRUE. 110 CONTINUE C RESET FRGPAR PUD=.43 PBARY=.10 SIGQT=.35 PEND=.14 XGEN(1)=.96 XGEN(2)=3. XGEN(3)=0. XGEN(4)=.8 XGEN(5)=.5 XGEN(6)=.5 XGEN(7)=.5 XGEN(8)=.5 DO 111 K=1,9 111 XGENSS(K)=.5 PSPIN1(1)=.5 PSPIN1(2)=.5 PSPIN1(3)=.5 PSPIN1(4)=.75 PSPIN1(5)=.75 PSPIN1(6)=.75 PSPIN1(7)=.75 PSPIN1(8)=.75 PMIXX1(1)=.25 PMIXX1(2)=.25 PMIXX1(3)=.5 PMIXX1(4)=0. PMIXX1(5)=.5 PMIXX1(6)=1. PMIXX2(1)=.5 PMIXX2(2)=.5 PMIXX2(3)=1. PMIXX2(4)=0. PMIXX2(5)=0. PMIXX2(6)=1. C RESET ISLOOP NEVOLV=1 NFRGMN=1 C RESET JETLIM DO 120 I=1,12*MXLIM BLIMS(I)=UNDEF SETLMJ(I)=.TRUE. 120 CONTINUE C RESET NODCAY NODCAY=.FALSE. NOETA=.FALSE. NOPI0=.FALSE. NONUNU=.FALSE. NOEVOL=.FALSE. NOHADR=.FALSE. NOGRAV=.FALSE. C RESET PRIMAR IDIN(1)=1120 IDIN(2)=1120 NTRIES=1000 NSIGMA=20 C RESET QCDPAR ALAM=.2 ALAM2=ALAM**2 CUTJET=6. ISTRUC=7 C RESET QLMASS AMLEP(6)=175. AMLEP(7)=-1. AMLEP(8)=-1. DO 125 I=1,9 CALL FLAVOR(80+I,I1,I2,I3,J1,INDEX) 125 AMLEP(INDEX)=0. CALL FLAVOR(29,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=100. CALL FLAVOR(30,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=0. CALL FLAVOR(39,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=100. CALL FLAVOR(40,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=100. DO 126 I=1,6 CALL FLAVOR(20+I,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=100.+AMASS(I) CALL FLAVOR(30+I,I1,I2,I3,J1,INDEX) AMLEP(INDEX)=100.+AMASS(I+10) 126 CONTINUE CALL FLAVOR(81,I1,I2,I3,J1,INDEX) IF(INDEX.GT.0) AMLEP(INDEX)=-1. C RESET Q1Q2 DO 130 I=1,MXGOQ DO 130 J=1,MXGOJ 130 GOQ(I,J)=.TRUE. DO 131 I=1,MXGOJ 131 GOALL(I)=.TRUE. GODY(1)=.TRUE. GODY(2)=.FALSE. GODY(3)=.FALSE. GODY(4)=.TRUE. DO 132 I=1,2 ALLWW(I)=.TRUE. DO 132 J=1,25 132 GOWW(J,I)=.TRUE. DO 133 I=1,3 DO 133 J=1,25 133 GOWMOD(J,I)=.TRUE. C RESET TCPAR TCMRHO=1000. TCGRHO=100. C RESET TYPES DO 140 I=1,NTYP 140 LOC(I)=0 DO 141 I=1,MXTYPE NJTTYP(I)=0 JETYP(1,I)='ALL ' DO 141 K=2,30 141 JETYP(K,I)=BLANK JWTYP=4 DO 142 I=1,2 NWWTYP(I)=0 WWTYP(1,I)='ALL ' DO 142 K=2,4 142 WWTYP(K,I)=BLANK DO 143 I=1,3 NWMODE(I)=0 WMODES(1,I)='ALL ' DO 143 K=2,30 143 WMODES(K,I)=BLANK C RESET WCON SIN2W=.232 WMASS(2)=80.2 WMASS(3)=WMASS(2) WMASS(4)=91.19 CALL FLAVOR(80,I1,I2,I3,J,INDEX) AMLEP(INDEX)=WMASS(2) CALL FLAVOR(90,I1,I2,I3,J,INDEX) AMLEP(INDEX)=WMASS(4) CUTOFF=.200 CUTPOW=1.0 WFUDGE=1.75 C RESET MBGEN MNPOM=1 MXPOM=LIMPOM C RESET FORCE NFORCE=0 C C RESET QCD EVOLUTION CUTS USELIM=.FALSE. CONCUT=1.0 C C RESET SSPAR AMGVSS=1.E20 C C RESET XMSSM GOMSSM=.FALSE. GOSUG=.FALSE. GOAMSB=.FALSE. XM1SS=1.E20 XM2SS=1.E20 XMAJNR=1.E20 XMGVTO=1.E20 C C RESET HCON IHTYPE=0 C C RESET EEPAR PLEP=0. PLEM=0. C C RESET MGLIMS EHMGMN=-1.E9 EHMGMX=-1.E9 YHMGMN=-1.E9 YHMGMX=-1.E9 DO 150 I=1,MXLIM DO 151 J=1,MXLIM AMIJMN(I,J)=-1.E9 AMIJMX(I,J)=-1.E9 151 CONTINUE 150 CONTINUE C C RESET SUGXIN DO 160 I=1,7 XSUGIN(I)=0 160 CONTINUE XNRIN(1)=0 XNRIN(2)=1.E20 XNRIN(3)=0 XNRIN(4)=0 C C RESET SSMODE NSSMOD=0 DO 170 I=1,MXSS ISSMOD(I)=0 DO 171 J=1,5 JSSMOD(J,I)=0 171 CONTINUE GSSMOD(I)=0. BSSMOD(I)=0. MSSMOD(I)=0 170 CONTINUE C RETURN END +EOD +DECK,SETCON. SUBROUTINE SETCON C THIS SUBROUTINE SETS THE CONSTANTS IN /CONST/. +CDE,ITAPES +CDE,CONST PI=4.*ATAN(1.) SQRT2=SQRT(2.) ALFA=1./137.036 GF=1.16570E-5 UNITS=1./2.56815 RETURN END +EOD +DECK,SETDKY. SUBROUTINE SETDKY(LPRINT) C C Read in decay table from tape ITDKY and set up /DKYTAB/. C Then append forced decay modes and set LOOK to negative C number pointing to LOOK2, which points to table. C Forced decays for antiparticles are stored in conjugated C form so that DECAY can always conjugate them. C C Logical flag LPRINT controls printing of table. C C Ver 7.41: Check version of decay table. Also read matrix C element flags and save in MELEM: C MELEM=0: Phase space C MELEM=1: Dalitz decay C MELEM=2: omega/phi decay C MELEM=3: V-A C MELEM=4: V-A plus W propagator (for top) C MELEM=5: tau -> ell nu nu C MELEM=6: tau -> nu pi/K C MELEM=7: tau -> nu rho/a1 C MELEM=8: tau -> tau (for NOTAU) C MELEM=9: H -> W f fbar C C Ver 7.52: add NOB and NOTAU flags C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,FORCE +CDE,DKYTAB +CDE,NODCAY +CDE,SSMODE +CDE,SSTYPE +CDE,XMSSM +CDE,KEYS C INTEGER IMODE(6),LOOP,IOLD,I,IRES,ITYPE,K,J,IPOINT INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,ID1,IDANTI,KTYPE,IRES2 REAL BR CHARACTER*8 LABEL,LMODE(6),LRES CHARACTER*8 IBLANK,LREAD(10),IQUIT LOGICAL LPRINT INTEGER NOUT,NTHAD PARAMETER (NOUT=33) PARAMETER (NTHAD=12) INTEGER IDOUT(NOUT),ITHAD(NTHAD),IDUMMY(5),MEOUT REAL SUMBR,SUMBR2,SUMGAM CHARACTER*40,V,VOLD,VISAJE C DATA IDOUT/ $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR, $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL, $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2, $ISHL,ISHH,ISHA,ISHC/ DATA IQUIT/'////'/,IBLANK/' '/ DATA ITHAD/-160,-260,-360, $ 1160,1260,2260,2160,1360,2360,3160,3260,3360/ C C Print header for table. C IF(LPRINT) WRITE(ITLIS,10) 10 FORMAT('1',30('*')/' *',28X,'*'/ 1' *',5X,'ISAJET DECAY TABLE',5X,'*'/ 2' *',28X,'*'/' ',30('*')// 33X,'PART',16X,'DECAY MODE',16X,'CUM BR',10X,'IDENT',18X, 4'DECAY IDENT'/) C C Initialize. LOOP is the decay mode counter. C LOOP=0 IOLD=0 DO 100 I=1,MXLOOK LOOK(I)=0 100 CONTINUE DO 110 I=1,MXFORC LOOK2(1,I)=0 LOOK2(2,I)=0 110 CONTINUE C C Read in table, checking for valid version. C IF(NODCAY.OR.ITDKY.EQ.0) RETURN REWIND ITDKY C VOLD=VISAJE() READ(ITDKY,*) V IF(V.NE.VOLD) THEN WRITE(ITLIS,2000) V,VOLD 2000 FORMAT(// $ ' ***WARNING: DECAY TABLE DOES NOT MATCH ISAJET VERSION'/ $ ' ***DECAY VERSION : ',A40/ $ ' ***PROGRAM VERSION: ',A40) ENDIF C 200 LOOP=LOOP+1 IF(LOOP.GT.MXDKY) GO TO 9999 220 DO 210 I=1,5 IMODE(I)=0 LMODE(I)=IBLANK 210 CONTINUE READ(ITDKY,*) IRES,ITYPE,BR,IMODE C IF(IRES.NE.0) THEN IF(NOPI0.AND.IRES.EQ.110) GO TO 220 IF(NOETA.AND.IRES.EQ.220) GO TO 220 IF(NOB.AND.IRES.GT.100.AND.IRES.LT.1000.AND. $ MOD(IRES/10,10).EQ.5) GO TO 220 IF(NOTAU.AND.IRES.EQ.16) GO TO 220 IF(IRES.NE.IOLD) THEN CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX) LOOK(INDEX)=LOOP ENDIF IOLD=IRES CBR(LOOP)=BR MELEM(LOOP)=ITYPE DO 240 I=1,5 MODE(I,LOOP)=IMODE(I) IF(IMODE(I).NE.0) LMODE(I)=LABEL(IMODE(I)) 240 CONTINUE LRES=LABEL(IRES) IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), 1 BR,IRES,(IMODE(K),K=1,5) 20 FORMAT(3X,A5,4X,5(A5,2X),F8.5,10X,I5,4X,5(I7,2X)) GO TO 200 ENDIF C C Add TAU -> TAUL,TAUR if NOTAU C IF(NOTAU) THEN IRES=16 LRES=LABEL(IRES) LOOP=LOOP+1 CALL FLAVOR(16,IFL1,IFL2,IFL3,JSPIN,INDEX) LOOK(INDEX)=LOOP BR=.5 CBR(LOOP)=BR MELEM(LOOP)=8 MODE(1,LOOP)=IDTAUL LMODE(1)=LABEL(IDTAUL) DO 241 I=2,5 MODE(I,LOOP)=0 LMODE(I)=LABEL(0) 241 CONTINUE IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), 1 BR,IRES,(IMODE(K),K=1,5) LOOP=LOOP+1 BR=1.0 CBR(LOOP)=BR MELEM(LOOP)=8 MODE(1,LOOP)=IDTAUR LMODE(1)=LABEL(IDTAUR) DO 242 I=2,5 MODE(I,LOOP)=0 242 CONTINUE IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), 1 BR,IRES,(IMODE(K),K=1,5) ENDIF C C Add HIGGS for E+E- or WHIGGS C IF((KEYS(2).OR.KEYS(10)).AND..NOT.GOMSSM) THEN SUMGAM=0 SUMBR=0 DO 244 J=1,NSSMOD IF(ISSMOD(J).EQ.81.AND.GSSMOD(J).GT.0) THEN SUMGAM=SUMGAM+GSSMOD(J) ENDIF 244 CONTINUE DO 245 J=1,NSSMOD IF(ISSMOD(J).EQ.81.AND.GSSMOD(J).GT.0) THEN BSSMOD(J)=GSSMOD(J)/SUMGAM ENDIF 245 CONTINUE DO 246 J=1,NSSMOD IF(ISSMOD(J).EQ.81.AND.BSSMOD(J).GT.0) THEN SUMBR=SUMBR+BSSMOD(J) ENDIF 246 CONTINUE C If modes exist, add them IF(SUMBR.LE.0) GO TO 249 IRES=81 LRES=LABEL(IRES) CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX) LOOK(INDEX)=LOOP+1 SUMBR2=0 DO 247 J=1,NSSMOD IF(ISSMOD(J).EQ.81.AND.BSSMOD(J).GT.0) THEN LOOP=LOOP+1 SUMBR2=SUMBR2+BSSMOD(J) BR=SUMBR2/SUMBR CBR(LOOP)=BR MELEM(LOOP)=MSSMOD(J) DO 248 K=1,5 MODE(K,LOOP)=JSSMOD(K,J) LMODE(K)=LABEL(MODE(K,LOOP)) 248 CONTINUE IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), $ BR,IRES,(MODE(K,LOOP),K=1,5) ENDIF 247 CONTINUE 249 CONTINUE END IF C C Add MSSM decay modes if applicable, OR H_SM FOR WHIGGS C IF(GOMSSM) THEN DO 250 I=1,NOUT C Check for modes SUMBR=0 DO 251 J=1,NSSMOD IF(ISSMOD(J).EQ.IDOUT(I).AND.BSSMOD(J).GT.0) THEN SUMBR=SUMBR+BSSMOD(J) ENDIF 251 CONTINUE C If modes exist, add them IF(SUMBR.LE.0) GO TO 250 IRES=IDOUT(I) LRES=LABEL(IRES) CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX) LOOK(INDEX)=LOOP+1 SUMBR2=0 DO 252 J=1,NSSMOD IF(ISSMOD(J).EQ.IDOUT(I).AND.BSSMOD(J).GT.0) THEN LOOP=LOOP+1 SUMBR2=SUMBR2+BSSMOD(J) BR=SUMBR2/SUMBR CBR(LOOP)=BR MELEM(LOOP)=MSSMOD(J) DO 253 K=1,5 MODE(K,LOOP)=JSSMOD(K,J) LMODE(K)=LABEL(MODE(K,LOOP)) 253 CONTINUE IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), $ BR,IRES,(MODE(K,LOOP),K=1,5) ENDIF 252 CONTINUE 250 CONTINUE C C Top hadron decays C DO 260 I=1,NTHAD C Check for modes SUMBR=0 DO 261 J=1,NSSMOD IF(ISSMOD(J).EQ.6.AND.BSSMOD(J).GT.0) THEN SUMBR=SUMBR+BSSMOD(J) ENDIF 261 CONTINUE C If modes exist, add them -- conjugate for antimesons IF(SUMBR.LE.0) GO TO 260 IRES=IABS(ITHAD(I)) LRES=LABEL(IRES) CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX) LOOK(INDEX)=LOOP+1 SUMBR2=0 DO 262 J=1,NSSMOD IF(ISSMOD(J).EQ.6.AND.BSSMOD(J).GT.0) THEN LOOP=LOOP+1 SUMBR2=SUMBR2+BSSMOD(J) BR=SUMBR2/SUMBR CBR(LOOP)=BR IF(IABS(JSSMOD(1,J)).LT.20.AND.IABS(JSSMOD(2,J)).LT.20 $ .AND.IABS(JSSMOD(3,J)).LT.20.AND.IABS(JSSMOD(4,J)).LT.20 $ .AND.IABS(JSSMOD(5,J)).LT.20) THEN MELEM(LOOP)=4 ELSE MELEM(LOOP)=0 ENDIF DO 263 K=1,5 IF(ITHAD(I).GT.0) THEN MODE(K,LOOP)=JSSMOD(K,J) ELSE MODE(K,LOOP)=IDANTI(JSSMOD(K,J)) ENDIF LMODE(K)=LABEL(MODE(K,LOOP)) 263 CONTINUE IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5), $ BR,IRES,(MODE(K,LOOP),K=1,5) ENDIF 262 CONTINUE 260 CONTINUE ENDIF C C Set forced decay modes. C LOOK(INDEX) = -IRES, where LOOK2(K,IRES) points to entries in C decay table for IDENT>0 and IDENT<0. C LOOKST(IRES) = standard LOOK value. C IF(NFORCE.EQ.0) GO TO 400 C Append each forced decay to table IRES=0 DO 310 I=1,NFORCE IF(IFORCE(I).EQ.0) GO TO 310 LOOP=LOOP+1 IF(LOOP.GT.MXDKY) GO TO 9999 CALL FLAVOR(IFORCE(I),IFL1,IFL2,IFL3,JSPIN,INDEX) IF(IFORCE(I).GT.0) THEN KTYPE=1 ELSE KTYPE=2 ENDIF C IF(LOOK(INDEX).GE.0) THEN IRES=IRES+1 IF(IRES.GT.MXFORC) GO TO 9998 LOOKST(IRES)=LOOK(INDEX) LOOK2(KTYPE,IRES)=LOOP LOOK2(3-KTYPE,IRES)=LOOKST(IRES) LOOK(INDEX)=-IRES ELSE IRES2=-LOOK(INDEX) IF(IRES2.GT.MXFORC) GO TO 9998 LOOK2(KTYPE,IRES2)=LOOP ENDIF C Set forced decay mode - conjugate if necessary IF(KTYPE.EQ.1) THEN DO 320 K=1,5 320 MODE(K,LOOP)=MFORCE(K,I) ELSE DO 330 K=1,5 330 MODE(K,LOOP)=IDANTI(MFORCE(K,I)) ENDIF CBR(LOOP)=1. C Set matrix element flag CALL ORDER(IFORCE(I),MFORCE(1,I),IDUMMY,MEOUT,.FALSE.) MELEM(LOOP)=MEOUT MEFORC(I)=MEOUT 310 CONTINUE C 400 RETURN C C Errors C 9999 WRITE(ITLIS,3001) LOOP 3001 FORMAT(//' ***** ERROR IN SETDKY ... DECAY COUNTER LOOP = ', $I6,' *****') STOP 99 9998 WRITE(ITLIS,3002) IRES 3002 FORMAT(//' ***** ERROR IN SETDKY ... FORCE COUNTER IRES = ', $I6,' *****') STOP 99 END +EOD +DECK,SETH. SUBROUTINE SETH C C Set the standard Weinberg-Salam Higgs parameters in /HCON/. C HMASS = Higgs mass C HGAM = Higgs width C HGAMS = Higgs partial width C ZSTARS = minimum allowed mass for Z* C C IQ = 1 2 3 4 5 6 7 8 9 10 11 12 13 C GL UP UB DN DB ST SB CH CB BT BB TP TB C IQ = 14 15 16 17 18 19 20 21 22 23 24 25 C NUE ANUE E- E+ NUMU ANUM MU- MU+ NUT ANUT TAU- TAU+ C IQ = 26 27 28 29 C GM W+ W- Z0 C C Ver 6.25: Added H -> GM GM. C Ver 6.26: Added H -> Z0 Z* from Keung and Marciano, Phys. C Rev. D30, 248 (1984). C Ver 6.30: Fixed sign of FFR in H -> GM GM for TAU<1. Added C H -> W W* to total width but not to partial widths C to get right branching ratios. C Ver 7.38: Add H_SM decay modes to SSSAVE for use in WHIGGS C Ver 7.54: Flag matrix element for H -> WW* C Require sufficient phase space for all W* decays C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES. +CDE,KEYS. +CDE,WCON. +CDE,QLMASS. +CDE,Q1Q2. +CDE,NODCAY. +CDE,CONST. +CDE,HCON. C REAL GAMFCN,X,AMASS,AMQ,GAMQ,AML,WM,GAMWW,TAU,FFR,FFI,FR,FI, $ROOT,ROOTLN,TM,SUMBR,TERM,ETAR,ETAI,RQ,RQLOG,PHIR,PHII REAL EPS,FEPS,AM12 INTEGER IQ,IQ1,IQ2,I,IW INTEGER LISTJ(25),LISTW(4) DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ DATA LISTW/10,80,-80,90/ C GAMFCN(X)=SQRT(1.-4*X**2)*(1.-4.*X**2+12.*X**4) C C Calculate Higgs mass and width C HMASS=AMASS(81) HGAM=0. DO 100 IQ=1,29 100 HGAMS(IQ)=0. IF(HMASS.LE.0) RETURN C C Quarks and leptons DO 110 IQ=1,6 AMQ=AMASS(IQ) IF(AMQ.GT.0..AND.AMQ.LT..5*HMASS) THEN GAMQ=3.*GF*AMQ**2*HMASS/(4.*PI*SQRT2) $ *(SQRT(1.-4.*AMQ**2/HMASS**2))**3 HGAM=HGAM+GAMQ HGAMS(2*IQ)=.5*GAMQ HGAMS(2*IQ+1)=.5*GAMQ CALL SSSAVE(81,GAMQ,IQ,-IQ,0,0,0) ENDIF AML=AMASS(IQ+10) IF(AML.GT.0..AND.AML.LT..5*HMASS) THEN GAMQ=GF*AML**2*HMASS/(4.*PI*SQRT2) $ *(SQRT(1.-4.*AML**2/HMASS**2))**3 HGAM=HGAM+GAMQ HGAMS(2*IQ+12)=.5*GAMQ HGAMS(2*IQ+13)=.5*GAMQ CALL SSSAVE(81,GAMQ,IQ+10,-(IQ+10),0,0,0) ENDIF 110 CONTINUE C C W+ W- and Z0 Z0, including W W* and Z Z*. WM=WMASS(2) IF(HMASS.GT.2.*WM) THEN GAMWW=GF*HMASS**3*GAMFCN(WM/HMASS)/(8.*PI*SQRT2) HGAM=HGAM+GAMWW HGAMS(27)=.5*GAMWW HGAMS(28)=.5*GAMWW CALL SSSAVE(81,GAMWW,80,-80,0,0,0) ELSEIF(HMASS.GT.WM+AMASS(4)+2.) THEN EPS=WM/HMASS FEPS=3.*(1.-8.*EPS**2+20.*EPS**4)/SQRT(4.*EPS**2-1.) $ *ACOS((3.*EPS**2-1.)/(2.*EPS**3)) $ -(1.-EPS**2)*(47./2.*EPS**2-13./2.+1./EPS**2) $ -3.*(1.-6.*EPS**2+4.*EPS**4)*ALOG(EPS) GAMWW=3.*ALFA**2*HMASS/(32.*PI*SIN2W**2)*FEPS HGAM=HGAM+GAMWW HGAMS(27)=.5*GAMWW HGAMS(28)=.5*GAMWW CALL SSSAVE(81,GAMWW/18.,80,12,-11,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/18.,-80,-12,11,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/18.,80,14,-13,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/18.,-80,-14,13,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/18.,80,16,-15,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/18.,-80,-16,15,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/6.,80,-1,2,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/6.,-80,1,-2,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/6.,80,-4,3,0,0) CALL SSSVME(9) CALL SSSAVE(81,GAMWW/6.,-80,4,-3,0,0) CALL SSSVME(9) ENDIF WM=WMASS(4) IF(HMASS.GT.2.*WM) THEN GAMWW=GF*HMASS**3*GAMFCN(WM/HMASS)/(16.*PI*SQRT2) HGAM=HGAM+GAMWW HGAMS(29)=GAMWW CALL SSSAVE(81,GAMWW,90,90,0,0,0) ELSEIF(HMASS.GT.WM+2*AMASS(5)+2.) THEN EPS=WM/HMASS FEPS=3.*(1.-8.*EPS**2+20.*EPS**4)/SQRT(4.*EPS**2-1.) $ *ACOS((3.*EPS**2-1.)/(2.*EPS**3)) $ -(1.-EPS**2)*(47./2.*EPS**2-13./2.+1./EPS**2) $ -3.*(1.-6.*EPS**2+4.*EPS**4)*ALOG(EPS) GAMWW=ALFA**2*HMASS/(128.*PI*SIN2W**2*(1.-SIN2W)**2) $ *(7.-40./3.*SIN2W+160./9.*SIN2W**2)*FEPS HGAM=HGAM+GAMWW HGAMS(29)=GAMWW CALL SSSAVE(81,.11922*GAMWW,90,-1,1,0,0) CALL SSSVME(9) CALL SSSAVE(81,.15375*GAMWW,90,-2,2,0,0) CALL SSSVME(9) CALL SSSAVE(81,.15375*GAMWW,90,-3,3,0,0) CALL SSSVME(9) CALL SSSAVE(81,.11922*GAMWW,90,-4,4,0,0) CALL SSSVME(9) CALL SSSAVE(81,.15375*GAMWW,90,-5,5,0,0) CALL SSSVME(9) CALL SSSAVE(81,.06668*GAMWW,90,-11,11,0,0) CALL SSSVME(9) CALL SSSAVE(81,.03343*GAMWW,90,-12,12,0,0) CALL SSSVME(9) CALL SSSAVE(81,.06668*GAMWW,90,-13,13,0,0) CALL SSSVME(9) CALL SSSAVE(81,.03343*GAMWW,90,-14,14,0,0) CALL SSSVME(9) CALL SSSAVE(81,.06668*GAMWW,90,-15,15,0,0) CALL SSSVME(9) CALL SSSAVE(81,.03343*GAMWW,90,-16,16,0,0) CALL SSSVME(9) ENDIF C W* and Z* mass limits DO 120 I=1,2 ZSTARS(1,I)=0. DO 130 IW=2,4 ZSTARS(IW,I)=AMASS(LISTW(IW)) DO 140 IQ1=2,25 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 140 IF(GOWW(IQ1,1).AND.GOWW(IQ2,2)) THEN AM12=AMASS(LISTJ(IQ1))+AMASS(LISTJ(IQ2)) ZSTARS(IW,I)=MIN(ZSTARS(IW,I),AM12) ENDIF 140 CONTINUE 130 CONTINUE 120 CONTINUE C C GM GM -- W loop term WM=WMASS(2) TAU=4.*WM**2/HMASS**2 IF(TAU.GE.1.0) THEN FFR=(ASIN(1./SQRT(TAU)))**2 FFI=0. ELSE ROOT=SQRT(1.-TAU) ROOTLN=ALOG((1.+ROOT)/(1.-ROOT)) FFR=-0.25*(ROOTLN**2-PI**2) FFI=0.5*PI*ROOTLN ENDIF FR=2.+3.*TAU+3.*TAU*(2.-TAU)*FFR FI=3.*TAU*(2.-TAU)*FFI C Top loop term TM=AMASS(6) TAU=4.*TM**2/HMASS**2 IF(TAU.GE.1.0) THEN FFR=(ASIN(1./SQRT(TAU)))**2 FFI=0. ELSE ROOT=SQRT(1.-TAU) ROOTLN=ALOG((1.+ROOT)/(1.-ROOT)) FFR=-0.25*(ROOTLN**2-PI**2) FFI=0.5*PI*ROOTLN ENDIF FR=FR-8./3.*TAU*(1.+(1.-TAU)*FFR) FI=FI-8./3.*TAU*(1.-TAU)*FFI C Total GM GM HGAMS(26)=ALFA**3/(256.*PI**2*SIN2W)*HMASS**3/WM**2*(FR**2+FI**2) HGAM=HGAM+HGAMS(26) CALL SSSAVE(81,HGAMS(26),10,10,0,0,0) C C Calculate Higgs-gluon-gluon coupling C ETAR=0. ETAI=0. DO 300 IQ=1,8 AMQ=AMASS(IQ) IF(AMQ.LE.0.) GO TO 300 RQ=(2.*AMQ/HMASS)**2 IF(RQ.GE.1.) THEN ETAR=ETAR+.5*RQ*(1.+(1.-RQ)*ASIN(1./SQRT(RQ))**2) ELSE RQLOG=ALOG((1.+SQRT(1.-RQ))/(1.-SQRT(1.-RQ))) PHIR=.25*(RQLOG**2-PI**2) ETAR=ETAR+.5*RQ*(1.+(RQ-1.)*PHIR) PHII=.5*PI*RQLOG ETAI=ETAI+.5*RQ*(1.+(RQ-1.)*PHII) ENDIF 300 CONTINUE ETAHGG=ETAR**2+ETAI**2 C RETURN END +EOD +DECK,SETHSS SUBROUTINE SETHSS C C Set the MSSM Higgs parameters in /HCON/. C HMASS = Higgs mass for HTYPE C HGAM = Higgs width C HGAMSS = Higgs partial widths. Note HGAMSS is not C necessarily diagonal for SUSY decays. C ZSTARS = minimum allowed mass for Z* C C Note LISTSS(78) => W+, LISTSS(79) => W-, LISTSS(80) => Z0 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,HCON +CDE,LISTSS +CDE,Q1Q2 +CDE,SSMODE +CDE,SSTYPE +CDE,WCON C REAL AMASS REAL AM12 INTEGER I,J,N,IQ1,IQ2,IW,K INTEGER LISTJ(25),LISTW(4) C DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ DATA LISTW/10,80,-80,90/ C C Initialize C IF(IHTYPE.EQ.0) THEN WRITE(ITLIS,*) ' YOU MUST SELECT AN HTYPE FOR SUSY HIGGS' WRITE(ITLIS,*) ' JOB TERMINATED' STOP99 ENDIF HMASS=AMASS(IHTYPE) HGAM=0. DO 100 I=1,85 DO 110 J=1,85 HGAMSS(I,J)=0 110 CONTINUE 100 CONTINUE C C Extract widths from SSMODE common block C Note the only 3-body modes are Zff or Wff C These are added to the ZZ and WW entries in HCONSS, C and the Z* or W* decay is generated later, as for SM Higgs C DO 200 N=1,NSSMOD IF(ISSMOD(N).NE.IHTYPE) GO TO 200 HGAM=HGAM+GSSMOD(N) IF(JSSMOD(3,N).NE.0) THEN C 3-body modes IF(IABS(JSSMOD(1,N)).EQ.80) THEN HGAMSS(78,79)=HGAMSS(78,79)+0.5*GSSMOD(N) HGAMSS(79,78)=HGAMSS(79,78)+0.5*GSSMOD(N) ELSEIF(JSSMOD(1,N).EQ.90) THEN HGAMSS(80,80)=HGAMSS(80,80)+GSSMOD(N) ELSE WRITE(ITLIS,1000) ISSMOD(N),(JSSMOD(K,N),K=1,5) 1000 FORMAT(' SETHSS: UNEXPECTED MODE ',I8,' --> ',5I8) STOP 99 ENDIF GO TO 200 ELSE C 2-body modes DO 210 I=1,85 IF(JSSMOD(1,N).NE.LISTSS(I)) GO TO 210 DO 220 J=1,85 IF(JSSMOD(2,N).NE.LISTSS(J)) GO TO 220 HGAMSS(I,J)=HGAMSS(I,J)+.5*GSSMOD(N) HGAMSS(J,I)=HGAMSS(J,I)+.5*GSSMOD(N) GO TO 200 220 CONTINUE 210 CONTINUE ENDIF WRITE(ITLIS,1000) ISSMOD(N),(JSSMOD(K,N),K=1,5) STOP99 200 CONTINUE C C W* and Z* mass limits C DO 300 I=1,2 ZSTARS(1,I)=0. DO 310 IW=2,4 ZSTARS(IW,I)=AMASS(LISTW(IW)) DO 320 IQ1=2,25 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 320 IF(GOWW(IQ1,I).AND.GOWW(IQ2,I)) THEN AM12=AMASS(LISTJ(IQ1))+AMASS(LISTJ(IQ2))+1.0 ZSTARS(IW,I)=MIN(ZSTARS(IW,I),AM12) ENDIF 320 CONTINUE 310 CONTINUE 300 CONTINUE RETURN END +EOD +DECK,SETKKG. SUBROUTINE SETKKG C C Set the standard KKG parameters in /KKGRAVI/. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,KKGRAV +CDE,CONST C REAL DIM2,GMMA,GAMMA EXTERNAL GAMMA C Calculate D-surface: DIM2 = (NEXTRAD*1.0)/2. GMMA = GAMMA(DIM2) SURFD = (2.*PI**DIM2) / GMMA KKGSD = SURFD / (MASSD**(NEXTRAD+2)) RETURN END +EOD +DECK,SETNXT. SUBROUTINE SETNXT C C RESET LIMITS BEFORE NEXT SET C +CDE,ITAPES +CDE,LSTPRT +CDE,TOTALS +CDE,DYLIM +CDE,JETLIM +CDE,PRIMAR +CDE,JETSET +CDE,PARTCL DATA UNDEF/-1.E9/ DO 1 I=1,36 IF(SETLMJ(I)) BLIMS(I)=UNDEF 1 CONTINUE DO 2 I=1,12 IF(SETLMQ(I)) BLIM1(I)=UNDEF 2 CONTINUE C RESET /TOTALS/ NKINPT=0 NWGEN=0 NKEEP=0 SUMWT=0. C RESET /LSTPRT/ LSTPRT=0 C RESET NJSET AND NPTCL NJSET=0 NPTCL=0 NPAIR=0 RETURN END +EOD +DECK,SETTYP LOGICAL FUNCTION SETTYP(LPRT) C C Set JETTYPE flags and WMODE flags for WPAIR. C Set WMODES and ZMODES flags for secondary W+- and Z0. C Return .FALSE. if no error, .TRUE. otherwise. C C Ver 7.18: Initialize all GOQ to false (limit = MXGOQ) C Use LISTSS for Higgs if GOMSSM C Ver 7.29: SUSY Higgs decays are done in SETHSS and SIGHSS C using LISTSS order, so SUSY list should be used. C I.e., 7.18 fix was wrong. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,KEYS +CDE,TYPES +CDE,Q1Q2 +CDE,XMSSM C INTEGER JET,K,I,IW,LPRT INTEGER NLIST CHARACTER*8 WORD,BLANK,LIST(30),LISTW(4),LISTXY(4),LISTSS(85) DATA BLANK/' '/ DATA LIST/'GL','UP','UB','DN','DB','ST','SB','CH','CB','BT','BB', $'TP','TB','NUE','ANUE','E-','E+','NUM','ANUM','MU-','MU+', $'NUT','ANUT','TAU-','TAU+','GM','W+','W-','Z0','HIGGS'/ DATA LISTW/'GM','W+','W-','Z0'/ DATA LISTXY/'Y','YB','X','XB'/ DATA LISTSS/'GLSS', $'UPSSL','UBSSL','DNSSL','DBSSL','STSSL','SBSSL','CHSSL','CBSSL', $'BTSS1','BBSS1','TPSS1','TBSS1', $'UPSSR','UBSSR','DNSSR','DBSSR','STSSR','SBSSR','CHSSR','CBSSR', $'BTSS2','BBSS2','TPSS2','TBSS2', $'W1SS+','W1SS-','W2SS+','W2SS-','Z1SS','Z2SS','Z3SS','Z4SS', $'NUEL','ANUEL','EL-','EL+','NUML','ANUML','MUL-','MUL+', $'NUTL','ANUTL','TAU1-','TAU1+','ER-','ER+','MUR-','MUR+', $'TAU2-','TAU2+', $'GL','UP','UB','DN','DB','ST','SB','CH','CB','BT','BB', $'TP','TB','NUE','ANUE','E-','E+','NUM','ANUM','MU-','MU+', $'NUT','ANUT','TAU-','TAU+','GM','W+','W-','Z0', $'HL0','HH0','HA0','H+','H-'/ C SETTYP=.FALSE. C IF(KEYS(5)) GO TO 5 IF(KEYS(2).AND.GOMSSM) GO TO 5 IF(KEYS(6).OR.KEYS(9)) GO TO 6 IF(KEYS(7).AND..NOT.GOMSSM) GO TO 7 IF(KEYS(7).AND.GOMSSM) GO TO 5 IF(KEYS(10).AND.GOMSSM) GO TO 5 C C JETTYPE flags all processes except WPAIR and HIGGS. C NJTTYP is set in READIN to number of non-blank values read. C Check for legal jet type names and set appropriate flags. C DO 1000 JET=1,MXGOJ IF(NJTTYP(JET).EQ.0) GO TO 1000 C Initialize everything to .FALSE. GOALL(JET)=.FALSE. DO 1100 K=1,MXGOQ GOQ(K,JET)=.FALSE. 1100 CONTINUE C Loop over non-blank JETTYPE entries DO 1200 I=1,NJTTYP(JET) WORD=JETYP(I,JET) C Blank IF(WORD.EQ.BLANK) THEN GO TO 1200 ENDIF C All IF(WORD.EQ.'ALL ') THEN GOALL(JET)=.TRUE. DO 1210 K=1,MXGOQ 1210 GOQ(K,JET)=.TRUE. GO TO 1000 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 1220 K=2,13 1220 GOQ(K,JET)=.TRUE. GO TO 1200 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 1230 K=16,24,4 GOQ(K,JET)=.TRUE. 1230 GOQ(K+1,JET)=.TRUE. GO TO 1200 ENDIF C Neutrinos IF(WORD.EQ.'NUS ') THEN DO 1240 K=14,22,4 GOQ(K,JET)=.TRUE. 1240 GOQ(K+1,JET)=.TRUE. GO TO 1200 ENDIF C Explicit types C E+E- now also contains W+, W-, Z0 IF(KEYS(2).OR.KEYS(10).OR.KEYS(11).OR.KEYS(12)) THEN NLIST=30 ELSE NLIST=25 ENDIF DO 1250 K=1,NLIST IF(WORD.EQ.LIST(K)) THEN GOQ(K,JET)=.TRUE. GO TO 1200 ENDIF 1250 CONTINUE C Special types for TWOJET DO 1270 K=1,4 IF(KEYS(1).AND.WORD.EQ.LISTXY(K)) THEN GOQ(13+K,JET)=.TRUE. GO TO 1200 ENDIF 1270 CONTINUE C Special type for PHOTON IF(KEYS(8).AND.WORD.EQ.LISTW(1)) THEN GOQ(26,JET)=.TRUE. GO TO 1200 ENDIF C Error WRITE(ITLIS,1300) WORD,JET 1300 FORMAT(1X,A8,' IS NOT RECOGNIZABLE FOR JETTYPE',I1) SETTYP=.TRUE. 1200 CONTINUE 1000 CONTINUE GO TO 4000 C C JETTYPE flags for SUSY C 5 DO 5000 JET=1,2 IF(NJTTYP(JET).EQ.0) GO TO 5000 GOALL(JET)=.FALSE. DO 5100 K=1,MXGOQ 5100 GOQ(K,JET)=.FALSE. DO 5200 I=1,NJTTYP(JET) WORD=JETYP(I,JET) C Blank IF(WORD.EQ.BLANK) THEN GO TO 5200 ENDIF C All IF(WORD.EQ.'ALL ') THEN GOALL(JET)=.TRUE. DO 5210 K=1,85 5210 GOQ(K,JET)=.TRUE. GO TO 5000 ENDIF C Squarks IF(WORD.EQ.'SQUARKS ') THEN DO 5220 K=2,25 5220 GOQ(K,JET)=.TRUE. GO TO 5200 ENDIF C Gauginos IF(WORD.EQ.'GAUGINOS') THEN DO 5230 K=26,33 5230 GOQ(K,JET)=.TRUE. GO TO 5200 ENDIF C Sleptons IF(WORD.EQ.'SLEPTONS') THEN DO 5240 K=34,51 5240 GOQ(K,JET)=.TRUE. GO TO 5200 ENDIF C Explicit susy types DO 5300 K=1,85 IF(WORD.EQ.LISTSS(K)) THEN GOQ(K,JET)=.TRUE. GO TO 5200 ENDIF 5300 CONTINUE 5200 CONTINUE 5000 CONTINUE GO TO 4000 C C JETTYPE and WMODE flags for WPAIR C NJTTYP and NWWTYP are the number of non-blank values. C 6 DO 2000 JET=1,2 IF(NJTTYP(JET).EQ.0) GO TO 2300 C Initialize to FALSE GOALL(JET)=.FALSE. DO 2100 K=1,4 2100 GOQ(K,JET)=.FALSE. C C Loop over non-blank JETTYPE flags C DO 2200 I=1,NJTTYP(JET) WORD=JETYP(I,JET) C Blank IF(WORD.EQ.BLANK) THEN GO TO 2200 ENDIF C All IF(WORD.EQ.'ALL ') THEN GOALL(JET)=.TRUE. DO 2210 K=1,4 2210 GOQ(K,JET)=.TRUE. GO TO 2300 ENDIF C Explicit types DO 2220 K=1,4 IF(WORD.EQ.LISTW(K)) THEN GOQ(K,JET)=.TRUE. GO TO 2200 ENDIF 2220 CONTINUE C Error WRITE(ITLIS,1300) WORD,JET SETTYP=.TRUE. 2200 CONTINUE C C Loop over nonblank WMODE flags C 2300 IF(NWWTYP(JET).EQ.0) GO TO 2000 ALLWW(JET)=.FALSE. C Initialize everything to FALSE DO 2350 K=1,25 2350 GOWW(K,JET)=.FALSE. C DO 2400 I=1,NWWTYP(JET) WORD=WWTYP(I,JET) IF(WORD.NE.BLANK) NWWTYP(JET)=I C Blank IF(WORD.EQ.BLANK) THEN GO TO 2400 ENDIF C All IF(WORD.EQ.'ALL ') THEN ALLWW(JET)=.TRUE. DO 2410 K=1,25 2410 GOWW(K,JET)=.TRUE. GO TO 2000 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 2420 K=2,13 2420 GOWW(K,JET)=.TRUE. GO TO 2400 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 2430 K=16,24,4 GOWW(K,JET)=.TRUE. 2430 GOWW(K+1,JET)=.TRUE. GO TO 2400 ENDIF C Neutrinos IF(WORD.EQ.'NUS ') THEN DO 2440 K=14,22,4 GOWW(K,JET)=.TRUE. 2440 GOWW(K+1,JET)=.TRUE. GO TO 2400 ENDIF C Explicit types DO 2450 K=1,25 IF(WORD.EQ.LIST(K)) THEN GOWW(K,JET)=.TRUE. GO TO 2400 ENDIF 2450 CONTINUE C Error WRITE(ITLIS,2500) WORD,JET 2500 FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1) SETTYP=.TRUE. 2400 CONTINUE 2000 CONTINUE GO TO 4000 C C JETTYPE and WMODE flags for HIGGS C SUSY HIGGS uses LISTSS order and hence SUSY part C 7 DO 3000 JET=1,2 IF(NJTTYP(JET).EQ.0) GO TO 3300 C Initialize to FALSE GOALL(JET)=.FALSE. DO 3100 K=1,MXGOQ 3100 GOQ(K,JET)=.FALSE. C C Loop over non-blank JETTYPE flags C DO 3200 I=1,NJTTYP(JET) WORD=JETYP(I,JET) C Blank IF(WORD.EQ.BLANK) THEN GO TO 3200 ENDIF C All IF(WORD.EQ.'ALL ') THEN GOALL(JET)=.TRUE. DO 3210 K=1,MXGOQ 3210 GOQ(K,JET)=.TRUE. GO TO 3300 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 3220 K=2,13 3220 GOQ(K,JET)=.TRUE. GO TO 3200 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 3240 K=16,24,4 GOQ(K,JET)=.TRUE. 3240 GOQ(K+1,JET)=.TRUE. GO TO 3200 ENDIF DO 3250 K=1,85 IF(WORD.EQ.LIST(K)) THEN GOQ(K,JET)=.TRUE. GO TO 3200 ENDIF 3250 CONTINUE C Error WRITE(ITLIS,1300) WORD,JET SETTYP=.TRUE. 3200 CONTINUE C C Loop over nonblank WMODE flags C 3300 IF(NWWTYP(JET).EQ.0) GO TO 3000 ALLWW(JET)=.FALSE. C Initialize everything to FALSE DO 3350 K=1,25 3350 GOWW(K,JET)=.FALSE. C DO 3400 I=1,NWWTYP(JET) WORD=WWTYP(I,JET) IF(WORD.NE.BLANK) NWWTYP(JET)=I C Blank IF(WORD.EQ.BLANK) THEN GO TO 3400 ENDIF C All IF(WORD.EQ.'ALL ') THEN ALLWW(JET)=.TRUE. DO 3410 K=1,25 3410 GOWW(K,JET)=.TRUE. GO TO 3000 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 3420 K=2,13 3420 GOWW(K,JET)=.TRUE. GO TO 3400 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 3430 K=16,24,4 GOWW(K,JET)=.TRUE. 3430 GOWW(K+1,JET)=.TRUE. GO TO 3400 ENDIF C Neutrinos IF(WORD.EQ.'NUS ') THEN DO 3440 K=14,22,4 GOWW(K,JET)=.TRUE. 3440 GOWW(K+1,JET)=.TRUE. GO TO 3400 ENDIF C Explicit types DO 3450 K=1,25 IF(WORD.EQ.LIST(K)) THEN GOWW(K,JET)=.TRUE. GO TO 3400 ENDIF 3450 CONTINUE C Error WRITE(ITLIS,2500) WORD,JET 3500 FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1) SETTYP=.TRUE. 3400 CONTINUE 3000 CONTINUE C C Set WMODES and ZMODES flags for secondary W+- and Z0 C 4000 DO 4100 IW=1,3 IF(NWMODE(IW).EQ.0) GO TO 4100 C Initialize everything to .FALSE. DO 4200 K=1,25 4200 GOWMOD(K,IW)=.FALSE. C Loop over non-blank WMODE entries DO 4300 I=1,NWMODE(IW) WORD=WMODES(I,IW) C Blank IF(WORD.EQ.BLANK) THEN GO TO 4300 ENDIF C All IF(WORD.EQ.'ALL ') THEN DO 4310 K=1,25 4310 GOWMOD(K,IW)=.TRUE. GO TO 4100 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 4320 K=2,13 4320 GOWMOD(K,IW)=.TRUE. GO TO 4300 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 4330 K=16,24,4 GOWMOD(K,IW)=.TRUE. 4330 GOWMOD(K+1,IW)=.TRUE. GO TO 4300 ENDIF C Neutrinos IF(WORD.EQ.'NUS ') THEN DO 4340 K=14,22,4 GOWMOD(K,IW)=.TRUE. 4340 GOWMOD(K+1,IW)=.TRUE. GO TO 4300 ENDIF C Explicit types DO 4350 K=1,25 IF(WORD.EQ.LIST(K)) THEN GOWMOD(K,IW)=.TRUE. GO TO 4300 ENDIF 4350 CONTINUE C Error WRITE(ITLIS,4380) WORD 4380 FORMAT(1X,A8,' IS NOT RECOGNIZABLE FOR SECONDARY WS') SETTYP=.TRUE. 4300 CONTINUE 4100 CONTINUE C C Loop over nonblank WMODE flags FOR WHIGGS C IF (KEYS(10)) THEN DO 6000 JET=1,2 6300 IF(NWWTYP(JET).EQ.0) GO TO 6000 ALLWW(JET)=.FALSE. C Initialize everything to FALSE DO 6350 K=1,25 6350 GOWW(K,JET)=.FALSE. C DO 6400 I=1,NWWTYP(JET) WORD=WWTYP(I,JET) IF(WORD.NE.BLANK) NWWTYP(JET)=I C Blank IF(WORD.EQ.BLANK) THEN GO TO 6400 ENDIF C All IF(WORD.EQ.'ALL ') THEN ALLWW(JET)=.TRUE. DO 6410 K=1,25 6410 GOWW(K,JET)=.TRUE. GO TO 6000 ENDIF C Quarks IF(WORD.EQ.'QUARKS ') THEN DO 6420 K=2,13 6420 GOWW(K,JET)=.TRUE. GO TO 6400 ENDIF C Charged leptons IF(WORD.EQ.'LEPTONS ') THEN DO 6430 K=16,24,4 GOWW(K,JET)=.TRUE. 6430 GOWW(K+1,JET)=.TRUE. GO TO 6400 ENDIF C Neutrinos IF(WORD.EQ.'NUS ') THEN DO 6440 K=14,22,4 GOWW(K,JET)=.TRUE. 6440 GOWW(K+1,JET)=.TRUE. GO TO 6400 ENDIF C Explicit types DO 6450 K=1,25 IF(WORD.EQ.LIST(K)) THEN GOWW(K,JET)=.TRUE. GO TO 6400 ENDIF 6450 CONTINUE C Error WRITE(ITLIS,6500) WORD,JET 6500 FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1) SETTYP=.TRUE. 6400 CONTINUE 6000 CONTINUE END IF RETURN END +EOD +DECK,SETW. SUBROUTINE SETW C C Set the W parameters in /WCON/. C SIN2W = sin**2(theta-sub-w) C AQ, BQ = vector, axial couplings normalized to ALFA. C MATCH(IQ1,IW) = Cabibbo favored type for W --> QK1 + QK2. C WCBR(IQ,IW) = cumulative branching ratio for JETTYP(1)=IQ C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,KEYS +CDE,WCON +CDE,QLMASS +CDE,Q1Q2 +CDE,NODCAY +CDE,CONST +CDE,XMSSM C REAL SINW,COSW,AMW,AMZ,AW,FACZ,GAMW,GAMZ,TERM,SUM,AM1,AMASS,AM2 INTEGER I1,I2,I3,J,INDEX,IFL,NGAM,NUP,IW,IQ1,IQ2,IFL1,JET,IQ,IFL2 INTEGER IW1 REAL T3(12),EQ3(12) INTEGER NUTYP(25),LISTJ(25) +SELF,IF=SINGLE REAL SIN2WD,SINWD,COSWD,AWD,FACZD +SELF,IF=DOUBLE. DOUBLE PRECISION SIN2WD,SINWD,COSWD,AWD,FACZD +SELF. DATA T3/.5,-.5,-.5,.5,-.5,.5,.5,-.5,.5,-.5,.5,-.5/ DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./ DATA NUTYP/13*0,1,1,0,0,1,1,0,0,1,1,0,0/ DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ C C Masses can be changed with WMASS C SINW=SQRT(SIN2W) COSW=SQRT(1.-SIN2W) AMW=WMASS(2) AMZ=WMASS(4) C C Couplings for Weinberg-Salam model C AW=1./(2.*SQRT2*SINW) FACZ=1./(2.*SINW*COSW) EZ=SQRT((1.-SIN2W)/SIN2W) DO 110 IFL=1,12 AQ(IFL,1)=EQ3(IFL)/3. BQ(IFL,1)=0. AQ(IFL,2)=AW BQ(IFL,2)=AW AQ(IFL,3)=AW BQ(IFL,3)=AW AQ(IFL,4)=FACZ*(T3(IFL)-2.*EQ3(IFL)/3.*SIN2W) BQ(IFL,4)=FACZ*T3(IFL) 110 CONTINUE +SELF,IF=SINGLE. C Double precision couplings not needed. EZDP=EZ DO 120 IW=1,4 DO 120 IFL=1,12 AQDP(IFL,IW)=AQ(IFL,IW) BQDP(IFL,IW)=BQ(IFL,IW) 120 CONTINUE +SELF,IF=DOUBLE. C Double precision couplings for 32-bit machines. SIN2WD=SIN2W SINWD=DSQRT(SIN2WD) COSWD=DSQRT(1.-SIN2WD) AWD=1./(2.*DSQRT(2.D0)*SINWD) FACZD=1./(2.*SINWD*COSWD) EZDP=COSWD/SINWD DO 120 IFL=1,12 AQDP(IFL,1)=EQ3(IFL)/3.D0 BQDP(IFL,1)=0. AQDP(IFL,2)=AWD BQDP(IFL,2)=AWD AQDP(IFL,3)=AWD BQDP(IFL,3)=AWD AQDP(IFL,4)=FACZD*(T3(IFL)-2.D0*EQ3(IFL)/3.D0*SIN2WD) BQDP(IFL,4)=FACZD*T3(IFL) 120 CONTINUE +SELF. C C Widths C NGAM=12 IF(AMLEP(5)+AMLEP(6).GT.AMW) NGAM=9 GAMW=GF*AMW**3/(6.*PI*SQRT2)*NGAM NUP=3 IF(2.*AMLEP(6).GT.AMZ) NUP=2 GAMZ=NUP*3.*(AQ(1,4)**2+BQ(1,4)**2)+3.*3.*(AQ(2,4)**2+BQ(2,4)**2) 1+3.*(AQ(7,4)**2+BQ(7,4)**2+AQ(8,4)**2+BQ(8,4)**2) GAMZ=GAMZ*2./FACZ**2 GAMZ=GAMZ*GF*AMZ**3/(12.*PI*SQRT2) WGAM(1)=0. WGAM(2)=GAMW WGAM(3)=GAMW WGAM(4)=GAMZ C C Branching ratios for secondary W+- and Z0 C DO 210 IW=2,4 IW1=IW-1 SUM=0. CUMWBR(1,IW1)=0. DO 220 IQ1=2,25 CUMWBR(IQ1,IW1)=CUMWBR(IQ1-1,IW1) IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 220 IF(.NOT.(GOWMOD(IQ1,IW-1).AND.GOWMOD(IQ2,IW-1))) GO TO 220 IFL1=LISTJ(IQ1) IFL2=LISTJ(IQ2) AM1=AMASS(IFL1) AM2=AMASS(IFL2) IF(AM1+AM2.GE.WMASS(IW)) GO TO 220 TERM=AQ(IQ1/2,IW)**2+BQ(IQ1/2,IW)**2 IF(IQ1.LE.13) TERM=3.*TERM CUMWBR(IQ1,IW1)=CUMWBR(IQ1-1,IW1)+TERM SUM=SUM+TERM 220 CONTINUE IF(SUM.LE.0.) THEN WRITE(ITLIS,2000) IW 2000 FORMAT(//' ***** NO ALLOWED DECAY MODE FOR SECONDARY W TYPE', $ I2,' *****') STOP 99 ENDIF DO 230 IQ1=2,25 CUMWBR(IQ1,IW1)=CUMWBR(IQ1,IW1)/SUM 230 CONTINUE 210 CONTINUE C C Decay channels for DRELLYAN C IF(KEYS(3)) THEN DO 310 IW=1,4 COUT(IW)=0. IF(.NOT.GODY(IW)) GO TO 310 DO 320 IQ1=2,25 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 320 IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 320 IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 320 IFL1=IQ1/2 TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2) IF(IQ1.LE.13) TERM=3.*TERM COUT(IW)=COUT(IW)+TERM 320 CONTINUE IF(COUT(IW).EQ.0.) THEN WRITE(ITLIS,3000) IW 3000 FORMAT(//' ***** ERROR IN SETW ... NO ALLOWED DECAY MODE ', $ 'FOR W TYPE',I2,' *****') STOP 99 ENDIF 310 CONTINUE C W branching ratios DO 330 IW=1,4 IF(.NOT.GODY(IW)) GO TO 330 SUM=0. DO 340 IQ1=1,25 WCBR(IQ1,IW)=SUM IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 340 IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 340 IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 340 IFL1=IQ1/2 TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2)/COUT(IW) IF(IQ1.LE.13) TERM=3.*TERM SUM=SUM+TERM WCBR(IQ1,IW)=SUM 340 CONTINUE 330 CONTINUE ENDIF C C Calculate branching ratios for WPAIR events summed over C modes allowed by WMODE cards. C TBRWW = total allowed branching ratio. C RBRWW = relative branching ratios. C TBRWW*RBRWW = physical branching ratios. C IF((KEYS(2).AND.(.NOT.GOMSSM)).OR.KEYS(6) ,.OR.KEYS(7).OR.KEYS(9).OR.KEYS(10)) THEN DO 400 JET=1,2 TBRWW(1,JET)=1. DO 410 IW=2,4 TBRWW(IW,JET)=0. IF(KEYS(6).OR.KEYS(9)) THEN IF(.NOT.GOQ(IW,JET)) GO TO 410 ELSEIF((KEYS(2).OR.KEYS(7).OR.KEYS(10)).AND..NOT.GOMSSM)THEN IF(.NOT.GOQ(IW+25,JET)) GO TO 410 ELSEIF((KEYS(7).OR.KEYS(10)).AND.GOMSSM) THEN IF(.NOT.GOQ(IW+76,JET)) GO TO 410 ENDIF SUM=0. DO 420 IQ=1,12 RBRWW(IQ,IW,JET)=0. IQ1=2*IQ IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 420 IFL1=IQ1/2 IF(IQ1.GT.13) IFL1=IFL1+4 IFL2=IQ2/2 IF(IQ2.GT.13) IFL2=IFL2+4 AM1=AMASS(IFL1) AM2=AMASS(IFL2) IF(AM1+AM2.GE.WMASS(IW)) GO TO 420 TERM=AQ(IQ1/2,IW)**2+BQ(IQ1/2,IW)**2 IF(IQ1.LE.13) TERM=3*TERM SUM=SUM+TERM IF(.NOT.(GOWW(IQ1,JET).AND.GOWW(IQ2,JET))) GO TO 420 RBRWW(IQ,IW,JET)=TERM TBRWW(IW,JET)=TBRWW(IW,JET)+TERM 420 CONTINUE TBRWW(IW,JET)=TBRWW(IW,JET)/SUM IF(TBRWW(IW,JET).GT.0.) THEN DO 430 IQ=1,12 430 RBRWW(IQ,IW,JET)=RBRWW(IQ,IW,JET)/(SUM*TBRWW(IW,JET)) ELSE WRITE(ITLIS,445) IW,JET 445 FORMAT(/' ***** NO ALLOWED MODE FOR W TYPE ',I2, $ ' IN JET ',I2,' *****'/) STOP 99 ENDIF 410 CONTINUE 400 CONTINUE ENDIF RETURN END +EOD +DECK,SIGDY. SUBROUTINE SIGDY C C Compute the Drell-Yan and Drell-Yan plus jet cross sections C d(sigma)/d(qmw**2)d(qtw**2)d(yw)d(yj) C C SIGMA = cross section summed over quark types allowed by C JETTYPE3 and WTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C C QT cutoff for W+JET taken from Parisi and Petronzio, C Nucl Phys B154, 427 C qk + gl --> qk + w suppressed at low QTW by extra factor C of qtw**2/(qtw**2+qt2cut(qmw)) C C Ver 7.17: include top mass for gb --> Wt and gt --> Zt C with no extra qt suppression factor. Note we do NOT include C gt --> Wb; while this process makes sense for qt >> m_t, C it has a pole in the physical region at low qt from the C on-shell decay t --> Wb. We let Q**2 --> Q**2 + m_t**2 C in the scale for the parton distributions. C C Ver 7.32: Rewrite AJLWT for gb --> Wt, etc., in terms of C scaled variables, and restore SWT**5 later to avoid C floating errors on VMS. C C Ver 7.41: Recalculate COUT for each mass(!). C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,NODCAY C REAL X(2) REAL Z,S,T,U,QMW2,QZW,EHAT,Q2SAVE,YHAT,EY,P3Z,P1,P2,AMASS,ANEFF, $SIG0,DENOM,QT2CUT,SIGT,SIGU,FAC,PROP,FACTOR,SIG,AMT,AMT2,SWT, $P1WT,P2WT,X1WT,X2WT,TWT,UWT,Q2,QFCN,STRUC,XX,ACOSH,ATANH,P2M,P1M REAL AMI2,AMF2,EFWT REAL AJLWT,AJLZT1,AJLZT2,A2,A2B2,QQ,TM2 INTEGER I,IQ,IH,IQ1,IFL,IQ2,IW INTEGER NZERO(4) REAL AMFAC(13) INTEGER NUTYP(25) INTEGER IFL1,IFL2 REAL TERM EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) C DATA NZERO/11,9,9,11/ DATA AMFAC/11*0.,2*1./ DATA NUTYP/13*0,1,1,0,0,1,1,0,0,1,1,0,0/ C C Functions ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.)) ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z)) PROP(I)=1./((QMW2-WMASS(I)**2)**2+(WMASS(I)*WGAM(I))**2) C Qt cutoff function QT2CUT(QMW)=CUTOFF*QMW**CUTPOW C Parton distributions QFCN(XX,IQ,IH)=STRUC(XX,QSQ+AMT2,IQ,IDIN(IH))/XX C Integrated matrix elements JLint from FORM AJLWT(S,T,QQ,TM2)= $ - 32*QQ**3*S*T + 32*QQ**3*S*TM2 + 32*QQ**2*S**2*T $ + 32*QQ**2*S*T**2 - 16*QQ**2*S*T*TM2 - 16*QQ**2*S*TM2**2 $ - 16*QQ*S**3*T + 16*QQ*S**3*TM2 - 16*QQ*S**2*T*TM2 $ - 16*QQ*S*T**3 + 32*QQ*S*T**2*TM2 - 16*QQ*S*T*TM2**2 $ - 8*S**3*T*TM2 + 8*S**3*TM2**2 - 16*S**2*T**2*TM2 $ + 16*S**2*T*TM2**2 - 16*S**2*TM2**3 - 8*S*T**3*TM2 $ + 8*S*T**2*TM2**2 - 8*S*T*TM2**3 + 8*S*TM2**4 C AJLZT1(S,T,QQ,TM2)= $ + A2 * ( - 96*QQ**2*S*T*TM2 + 96*QQ**2*S*TM2**2 $ + 96*QQ**2*T*TM2**2 - 96*QQ**2*TM2**3 + 96*QQ*S**2*T*TM2 $ + 96*QQ*S*T**2*TM2 - 192*QQ*S*T*TM2**2 - 96*QQ*S*TM2**3 $ - 96*QQ*T*TM2**3 + 192*QQ*TM2**4 + 16*S**3*T*TM2 $ - 16*S**3*TM2**2 + 32*S**2*T**2*TM2 - 112*S**2*T*TM2**2 $ + 80*S**2*TM2**3 + 16*S*T**3*TM2 - 112*S*T**2*TM2**2 $ + 224*S*T*TM2**3 - 128*S*TM2**4 - 16*T**3*TM2**2 $ + 80*T**2*TM2**3 - 128*T*TM2**4 + 64*TM2**5 ) AJLZT2(S,T,QQ,TM2)= $ + A2B2 * ( - 16*QQ**3*S*T + 16*QQ**3*S*TM2 + 16*QQ**3*T*TM2 $ - 16*QQ**3*TM2**2 + 16*QQ**2*S**2*T + 16*QQ**2*S*T**2 $ + 32*QQ**2*S*T*TM2 - 80*QQ**2*S*TM2**2 - 80*QQ**2*T*TM2**2 $ + 96*QQ**2*TM2**3 - 8*QQ*S**3*T + 8*QQ*S**3*TM2 $ - 40*QQ*S**2*T*TM2 - 24*QQ*S**2*TM2**2 - 8*QQ*S*T**3 $ - 40*QQ*S*T**2*TM2 + 80*QQ*S*T*TM2**2 + 96*QQ*S*TM2**3 $ + 8*QQ*T**3*TM2 - 24*QQ*T**2*TM2**2 + 96*QQ*T*TM2**3 $ - 144*QQ*TM2**4 - 16*S**3*T*TM2 + 16*S**3*TM2**2 $ - 32*S**2*T**2*TM2 + 112*S**2*T*TM2**2 - 80*S**2*TM2**3 $ - 16*S*T**3*TM2 + 112*S*T**2*TM2**2 - 224*S*T*TM2**3 $ + 128*S*TM2**4 + 16*T**3*TM2**2 - 80*T**2*TM2**3 $ + 128*T*TM2**4 - 64*TM2**5 ) C C Kinematics C QMW2=QMW**2 QTMW=SQRT(QMW2+QTW**2) Q0W=QTMW*COSH(YW) QZW=QTMW*SINH(YW) QW=SQRT(QZW**2+QTW**2) C Protect against errors IF(QW.NE.0.) THEN CTHW=QZW/QW STHW=QTW/QW IF(ABS(CTHW).LT.1.) THEN THW=ACOS(CTHW) ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF C IF(STDDY) THEN C Kinematics for standard Drell-Yan EHAT=QMW SHAT=QMW**2 QSQ=SHAT Q2SAVE=QSQ YHAT=YW EY=EXP(YHAT) X1=EHAT/ECM*EY X2=EHAT/(ECM*EY) ELSE C Kinematics for Drell-Yan plus jet P3Z=P(3)*CTH(3) SHAT=QMW2+2.*Q0W*P(3)-2.*QZW*P3Z+2.*PT(3)**2 P1=.5*(P(3)+P3Z+Q0W+QZW) P2=.5*(P(3)-P3Z+Q0W-QZW) X1=P1/HALFE X2=P2/HALFE THAT=-2.*P1*(P(3)-P3Z) UHAT=-2.*P2*(P(3)+P3Z) QSQ=QTW**2 QSQ=AMAX1(QSQ,4.) ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2)) Q2SAVE=QSQ QSQ=SHAT ENDIF C C Initialize C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS SIGS(I)=0. 100 CONTINUE IF(X1.GE.1..OR.X2.GE.1.) RETURN C C Compute structure functions C DO 110 IH=1,2 DO 120 IQ=1,11 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) 120 CONTINUE QSAVE(12,IH)=0 QSAVE(13,IH)=0 110 CONTINUE QSQ=Q2SAVE C C Recompute COUT for this mass C DO 130 IW=1,4 COUT(IW)=0. IF(.NOT.GODY(IW)) GO TO 130 DO 140 IQ1=2,25 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 140 IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 140 IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 140 IFL1=IQ1/2 IFL2=IQ2/2 IF(AMASS(IFL1)+AMASS(IFL2).GE.QMW) GO TO 140 TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2) IF(IQ1.LE.13) TERM=3.*TERM COUT(IW)=COUT(IW)+TERM 140 CONTINUE 130 CONTINUE C IF(STDDY) GO TO 400 C C Compute cross section for types allowed by WTYPE and C JETTYPE cards. C C qk + gl --> qk + W C SIG0=ALFA**2*ALFQSQ*QMW2/(9.*SCM*S)*UNITS DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2)) SIGT=SIG0*(S**2+U**2+2.*T*QMW2)*(-T)/DENOM SIGU=SIG0*(S**2+T**2+2.*U*QMW2)*(-U)/DENOM DO 200 IW=1,4 IF(.NOT.GODY(IW)) GO TO 200 FAC=COUT(IW)*PROP(IW) DO 210 IQ=2,NZERO(IW) IF(.NOT.GOQ(IQ,3)) GO TO 210 IQ1=MATCH(IQ,4) IQ1=MATCH(IQ1,IW) IF(IQ1.EQ.0) GO TO 210 IFL=IQ/2 FACTOR=FAC*(AQ(IFL,IW)**2+BQ(IFL,IW)**2) $ *QTW**2/(QTW**2+QT2CUT(QMW)) SIG=FACTOR*SIGT*QSAVE(IQ1,1)*QSAVE(1,2) CALL SIGFIL(SIG,IQ1,1,IW,IQ) SIG=FACTOR*SIGU*QSAVE(IQ1,2)*QSAVE(1,1) CALL SIGFIL(SIG,1,IQ1,IW,IQ) 210 CONTINUE 200 CONTINUE C C bt,tp + gl -> bt,tp + W,Z C AMT=AMASS(6) AMT2=AMT**2 Q2=QMW2 DO 220 IW=2,4 IF(.NOT.GODY(IW)) GO TO 220 DO 230 IQ=NZERO(IW)+1,13 IF(.NOT.GOQ(IQ,3)) GO TO 230 IQ1=MATCH(IQ,4) IQ1=MATCH(IQ1,IW) IF(IQ1.EQ.0) GO TO 230 IF(IQ1.GE.12.AND.IW.NE.4) GO TO 230 C Assign zero or top masses for initial/final quarks AMF2=AMT2*AMFAC(IQ) AMI2=AMT2*AMFAC(IQ1) EFWT=SQRT(P(3)**2+AMF2) SWT=QMW2+AMF2+2.*Q0W*EFWT-2.*QZW*P3Z+2.*PT(3)**2 C C qk + gl initial state C Do kinematics using p(small) = 0 for gluon C P1WT=EFWT+P3Z+Q0W+QZW P1M=AMI2/P1WT P2WT=EFWT-P3Z+Q0W-QZW-P1M X1WT=.5*P1WT/HALFE X2WT=.5*P2WT/HALFE TWT=-P1WT*(EFWT-P3Z)-P1M*(EFWT+P3Z)+AMI2+AMF2 UWT=-P2WT*(EFWT+P3Z)+AMF2 IF(X1WT.LT.0.OR.X1WT.GT.1.OR.X2WT.LT.0.OR.X2WT.GT.1) $ GO TO 240 C Cross sections IF(IW.EQ.2.OR.IW.EQ.3) THEN SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS SIG0=SIG0*(AQ(5,IW)**2+BQ(5,IW)**2)*COUT(IW)*PROP(IW) SIGU=SIG0*AJLWT(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT)*SWT* $ (SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2 SIG=SIGU*QFCN(X1WT,IQ1,1)*QFCN(X2WT,1,2) CALL SIGFIL(SIG,IQ1,1,IW,IQ) ELSEIF(IW.EQ.4) THEN SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS SIG0=SIG0*COUT(IW)*PROP(IW) A2=AQ(6,IW)**2 A2B2=AQ(6,IW)**2+BQ(6,IW)**2 SIGU=SIG0*(AJLZT1(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT)+ $ AJLZT2(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT))*SWT* $ (SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2 SIG=SIGU*QFCN(X1WT,IQ1,1)*QFCN(X2WT,1,2) CALL SIGFIL(SIG,IQ1,1,IW,IQ) ENDIF C C gl + qk initial state C Do kinematics using p(small) = 0 for gluon C 240 P2WT=EFWT-P3Z+Q0W-QZW P2M=AMI2/P2WT P1WT=EFWT+P3Z+Q0W+QZW-P2M X1WT=.5*P1WT/HALFE X2WT=.5*P2WT/HALFE TWT=-P1WT*(EFWT-P3Z)+AMF2 UWT=-P2WT*(EFWT+P3Z)-P2M*(EFWT-P3Z)+AMI2+AMF2 IF(X1WT.LT.0.OR.X1WT.GT.1.OR.X2WT.LT.0.OR.X2WT.GT.1) $ GO TO 230 C Cross sections IF(IW.EQ.2.OR.IW.EQ.3) THEN SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS SIG0=SIG0*(AQ(5,IW)**2+BQ(5,IW)**2)*COUT(IW)*PROP(IW) SIGT=SIG0*AJLWT(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT)*SWT* $ (SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2)**2) SIG=SIGT*QFCN(X1WT,1,1)*QFCN(X2WT,IQ1,2) CALL SIGFIL(SIG,1,IQ1,IW,IQ) ELSEIF(IW.EQ.4) THEN SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS SIG0=SIG0*COUT(IW)*PROP(IW) A2=AQ(6,IW)**2 A2B2=AQ(6,IW)**2+BQ(6,IW)**2 SIGU=SIG0*(AJLZT1(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT)+ $ AJLZT2(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT))*SWT* $ (SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2 SIG=SIGU*QFCN(X1WT,1,1)*QFCN(X2WT,IQ1,2) CALL SIGFIL(SIG,1,IQ1,IW,IQ) ENDIF 230 CONTINUE 220 CONTINUE C C qk + qb --> gl + W C IF(.NOT.GOQ(1,3)) RETURN SIG0=8.*ALFA**2*ALFQSQ*QMW2/(27.*SCM*S)*UNITS DENOM=S*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2)) SIG0=SIG0*(T**2+U**2+2.*S*QMW2)/DENOM DO 300 IW=1,4 IF(.NOT.GODY(IW)) GO TO 300 FAC=COUT(IW)*PROP(IW) DO 310 IQ1=2,11 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 310 IFL=IQ1/2 SIG=FAC*SIG0*(AQ(IFL,IW)**2+BQ(IFL,IW)**2) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IW,1) 310 CONTINUE 300 CONTINUE RETURN C C Standard Drell-Yan for QT=0. C 400 CONTINUE SIG0=4.*PI*ALFA**2*QMW2/(9.*SCM)*UNITS DO 410 IW=1,4 IF(.NOT.GODY(IW)) GO TO 410 FAC=COUT(IW)*PROP(IW) DO 420 IQ1=2,13 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 420 IFL=IQ1/2 SIG=FAC*SIG0*(AQ(IFL,IW)**2+BQ(IFL,IW)**2) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IW,0) 420 CONTINUE 410 CONTINUE C RETURN END +EOD +DECK,SIGDY2. SUBROUTINE SIGDY2 C C Compute the lepton-lepton-jet cross or quark-antiquark-jet C cross section C d(sigma)/d(qmw**2)d(qtw**2)d(yw)d(yj)d(omega*) C for the specified W and jet types C C Also fix the incoming partons to be the selected types. C C QT cutoff from Parisi and Petronzio, Nucl Phys B154, 427 C qk+gl-->qk+w suppressed at low QTW C C Ver 6.40: Fix underflow in standard Drell-Yan C C Ver 7.17: include top mass for gb --> Wt and gt --> Zt C with no extra qt suppression factor. Note we do NOT include C gt --> Wb; while this process makes sense for qt >> m_t, C it has a pole in the physical region at low qt from the C on-shell decay t --> Wb. We let Q**2 --> Q**2 + m_t**2 C in the scale for the parton distributions. C C Ver 7.32: Rewrite AJLWT for gb --> Wt, etc., in terms of C scaled variables, and restore SWT**5 later to avoid C floating errors on VMS. C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,WSIG +CDE,QSAVE +CDE,WCON +CDE,CONST C REAL PROP,AJLWT,FCDIR,FCINT,QT2CUT,QFCN,AMASS,STRUC REAL AJLZT1,AJLZT2,AJLZT3,AJLZT4 REAL X1WT,X2WT,P1WT,P2WT,SWT,TWT,UWT,QZW,P3Z, $S,T,U,S1,T1,U1,TDIR,UDIR,TINT,UINT,COUPL,DENOM, $AMT,AMT2,TERM1,TERM2,SIG0,QMW2,Q2,XX,S1WT,T1WT,U1WT,P1M,P2M, $AMI2,AMF2,EFWT,A2,A2B2,AB,AL2BL2,ALBL,QQ,TM2 REAL AMFAC(13) INTEGER I,JF,IFLQ,JQK,IQ1,IQ2,IFL1,IQ,IFLL,IH,IQ3 INTEGER NZERO(4) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) EQUIVALENCE (S1,SHAT1),(T1,THAT1),(U1,UHAT1) C DATA NZERO/13,9,9,11/ DATA AMFAC/11*0.,2*1./ C Functions. FCDIR and FCINT are direct and interference C terms for virtual Compton cross section. C PROP(I)=1./((QMW2-WMASS(I)**2)**2+(WMASS(I)*WGAM(I))**2) FCDIR(S,T,U,S1,T1,U1)=COUPL*(S*(2.*S1**2-2.*S1*U1-2.*T1*U1) 1+T*(-2.*S1*T1-4.*S1*U1-2.*T1*U1)+U*(2.*U1**2-2.*S1*T1-2.*S1*U1) 2+QMW2*(S**2+U**2+2.*T*QMW2))*(-T)/DENOM FCINT(S,T,U,S1,T1,U1)=-COUPL*(S1*(S*T-T*U+T*QMW2+QMW2**2) 1+T1*(-S**2+U**2+2.*S*QMW2-2.*U*QMW2)+U1*(S*T-T*U-T*QMW2-QMW2**2)) 2*(-T)/DENOM C QT cutoff function QT2CUT(QMW)=CUTOFF*QMW**CUTPOW C Parton distributions for top processes QFCN(XX,IQ,IH)=STRUC(XX,QSQ+AMT2,IQ,IDIN(IH))/XX C Matrix elements JL/128 from FORM AJLWT(S,T,T1,U1,QQ,TM2)= $ + 2*QQ**3*S*T - 2*QQ**3*S*TM2 - 2*QQ**2*S**2*TM2 $ - 2*QQ**2*S*T**2 + 4*QQ**2*S*T*T1 + 2*QQ**2*S*T*U1 $ - 4*QQ**2*S*T1*TM2 - 2*QQ**2*S*U1*TM2 + 2*QQ**2*S*TM2**2 $ + QQ*S**2*T*TM2 - 4*QQ*S**2*T1*TM2 + QQ*S**2*TM2**2 $ + QQ*S*T**3 - 2*QQ*S*T**2*T1 - QQ*S*T**2*TM2 + 2*QQ*S*T*T1**2 $ + 2*QQ*S*T*T1*U1 - 2*QQ*S*T*T1*TM2 + QQ*S*T*U1**2 $ - 3*QQ*S*T*U1*TM2 + QQ*S*T*TM2**2 - 2*QQ*S*T1**2*TM2 $ - 2*QQ*S*T1*U1*TM2 + 4*QQ*S*T1*TM2**2 - QQ*S*U1**2*TM2 $ + 3*QQ*S*U1*TM2**2 - QQ*S*TM2**3 + S**2*T*T1*TM2 $ - S**2*T*U1*TM2 - 2*S**2*T1**2*TM2 + S**2*T1*TM2**2 $ + S**2*U1*TM2**2 + S*T**2*T1*TM2 - 2*S*T*T1**2*TM2 $ - 2*S*T*T1*U1*TM2 - S*T*U1**2*TM2 + S*T*U1*TM2**2 $ + 2*S*T1**2*TM2**2 + 2*S*T1*U1*TM2**2 - S*T1*TM2**3 $ + S*U1**2*TM2**2 - S*U1*TM2**3 C AJLZT1(S,T,T1,U1,QQ,TM2)= $ + A2*AL2BL2 * ( 8*QQ**2*S*T*TM2 - 8*QQ**2*S*TM2**2 $ - 8*QQ**2*T*TM2**2 + 8*QQ**2*TM2**3 - 8*QQ*S**2*T*TM2 $ - 8*QQ*S*T**2*TM2 + 16*QQ*S*T*TM2**2 + 8*QQ*S*TM2**3 $ + 8*QQ*T*TM2**3 - 16*QQ*TM2**4 + 8*S**2*T*U1*TM2 $ - 8*S**2*U1*TM2**2 + 8*S*T**2*U1*TM2 + 8*S*T*U1**2*TM2 $ - 32*S*T*U1*TM2**2 - 8*S*U1**2*TM2**2 + 24*S*U1*TM2**3 $ - 8*T**2*U1*TM2**2 - 8*T*U1**2*TM2**2 + 24*T*U1*TM2**3 $ + 8*U1**2*TM2**3 - 16*U1*TM2**4 )/8. AJLZT2(S,T,T1,U1,QQ,TM2)= $ + A2B2*AL2BL2 * ( 2*QQ**3*S*T - 2*QQ**3*S*TM2 $ - 2*QQ**3*T*TM2 + 2*QQ**3*TM2**2 - 2*QQ**2*S**2*TM2 $ - 2*QQ**2*S*T**2 + 4*QQ**2*S*T*T1 + 2*QQ**2*S*T*U1 $ - 8*QQ**2*S*T*TM2 - 4*QQ**2*S*T1*TM2 - 2*QQ**2*S*U1*TM2 $ + 14*QQ**2*S*TM2**2 - 4*QQ**2*T*T1*TM2 - 2*QQ**2*T*U1*TM2 $ + 12*QQ**2*T*TM2**2 + 4*QQ**2*T1*TM2**2 + 2*QQ**2*U1*TM2**2 $ - 14*QQ**2*TM2**3 + QQ*S**3*T - QQ*S**3*TM2 + 2*QQ*S**2*T*T1 $ + 2*QQ*S**2*T*U1 - QQ*S**2*T*TM2 - 6*QQ*S**2*T1*TM2 $ - 2*QQ*S**2*U1*TM2 + 9*QQ*S**2*TM2**2 + QQ*S*T**3 $ - 2*QQ*S*T**2*T1 + 3*QQ*S*T**2*TM2 + 4*QQ*S*T*T1**2 $ + 4*QQ*S*T*T1*U1 - 16*QQ*S*T*T1*TM2 + 2*QQ*S*T*U1**2 $ - 12*QQ*S*T*U1*TM2 + 10*QQ*S*T*TM2**2 - 4*QQ*S*T1**2*TM2 $ - 4*QQ*S*T1*U1*TM2 + 26*QQ*S*T1*TM2**2 - 2*QQ*S*U1**2*TM2 $ + 12*QQ*S*U1*TM2**2 - 30*QQ*S*TM2**3 - QQ*T**3*TM2 $ - 2*QQ*T**2*T1*TM2 - 4*QQ*T**2*U1*TM2 + 5*QQ*T**2*TM2**2 $ - 4*QQ*T*T1**2*TM2 - 4*QQ*T*T1*U1*TM2 + 22*QQ*T*T1*TM2**2 $ - 2*QQ*T*U1**2*TM2 + 18*QQ*T*U1*TM2**2 )/8. AJLZT3(S,T,T1,U1,QQ,TM2)= $ + A2B2*AL2BL2 * ( - 26*QQ*T*TM2**3 + 4*QQ*T1**2*TM2**2 $ + 4*QQ*T1*U1*TM2**2 - 24*QQ*T1*TM2**3 + 2*QQ*U1**2*TM2**2 $ - 14*QQ*U1*TM2**3 + 30*QQ*TM2**4 - 8*S**2*T*U1*TM2 $ - 4*S**2*T1**2*TM2 + 8*S**2*T1*TM2**2 + 8*S**2*U1*TM2**2 $ - 4*S**2*TM2**3 - 8*S*T**2*U1*TM2 - 8*S*T*T1**2*TM2 $ - 8*S*T*T1*U1*TM2 + 16*S*T*T1*TM2**2 - 8*S*T*U1**2*TM2 $ + 40*S*T*U1*TM2**2 - 8*S*T*TM2**3 + 16*S*T1**2*TM2**2 $ + 8*S*T1*U1*TM2**2 - 32*S*T1*TM2**3 + 8*S*U1**2*TM2**2 $ - 32*S*U1*TM2**3 + 16*S*TM2**4 - 4*T**2*T1**2*TM2 $ - 8*T**2*T1*U1*TM2 + 8*T**2*T1*TM2**2 - 4*T**2*U1**2*TM2 $ + 16*T**2*U1*TM2**2 - 4*T**2*TM2**3 + 16*T*T1**2*TM2**2 $ + 24*T*T1*U1*TM2**2 - 32*T*T1*TM2**3 + 16*T*U1**2*TM2**2 $ - 48*T*U1*TM2**3 + 16*T*TM2**4 - 16*T1**2*TM2**3 $ - 16*T1*U1*TM2**3 + 32*T1*TM2**4 - 12*U1**2*TM2**3 $ + 32*U1*TM2**4 - 16*TM2**5 )/8. AJLZT4(S,T,T1,U1,QQ,TM2)= $ + AB*ALBL * ( 8*QQ**3*S*T - 8*QQ**3*S*TM2 - 8*QQ**3*T*TM2 $ + 8*QQ**3*TM2**2 - 8*QQ**2*S**2*TM2 - 8*QQ**2*S*T**2 $ + 16*QQ**2*S*T*T1 + 8*QQ**2*S*T*U1 - 16*QQ**2*S*T*TM2 $ - 16*QQ**2*S*T1*TM2 - 8*QQ**2*S*U1*TM2 + 40*QQ**2*S*TM2**2 $ - 16*QQ**2*T*T1*TM2 - 8*QQ**2*T*U1*TM2 + 32*QQ**2*T*TM2**2 $ + 16*QQ**2*T1*TM2**2 + 8*QQ**2*U1*TM2**2 - 40*QQ**2*TM2**3 $ - 4*QQ*S**3*T + 4*QQ*S**3*TM2 - 8*QQ*S**2*T*T1 $ - 8*QQ*S**2*T*U1 + 20*QQ*S**2*T*TM2 - 8*QQ*S**2*T1*TM2 $ + 8*QQ*S**2*U1*TM2 - 4*QQ*S**2*TM2**2 + 4*QQ*S*T**3 $ - 8*QQ*S*T**2*T1 - 4*QQ*S*T**2*TM2 + 40*QQ*S*T1*TM2**2 $ - 32*QQ*S*TM2**3 - 4*QQ*T**3*TM2 - 8*QQ*T**2*T1*TM2 $ - 16*QQ*T**2*U1*TM2 + 20*QQ*T**2*TM2**2 + 40*QQ*T*T1*TM2**2 $ + 40*QQ*T*U1*TM2**2 - 48*QQ*T*TM2**3 - 48*QQ*T1*TM2**3 $ - 24*QQ*U1*TM2**3 + 48*QQ*TM2**4 )/8. C C Find whether JETTYP(1) or JETTYP(2) is particle C JF=1 IF(2*(JETTYP(1)/2).NE.JETTYP(1)) JF=2 C C Kinematics C QMW2=QMW**2 QZW=QTMW*SINH(YW) Q0W=QTMW*COSH(YW) QW=SQRT(QZW**2+QTW**2) T1=-X2*ECM*PT(JF)*EXP(YJ(JF)) U1=-X1*ECM*PT(JF)*EXP(-YJ(JF)) S1=-T1-U1-QMW2 SIGLLQ=0. IF(STDDY) GO TO 400 C C qk + qb --> gl + w C IF(JETTYP(3).EQ.1) THEN IFLL=JETTYP(1)/2 COUPL=-ALFA**2*ALFQSQ*PROP(JWTYP)/(9.*PI*SCM*S) DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2)) TDIR=FCDIR(T,S,U,T1,S1,U1)*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2) UDIR=FCDIR(U,S,T,U1,S1,T1)*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2) TINT=FCINT(T,S,U,T1,S1,U1)*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP) UINT=FCINT(U,S,T,U1,S1,T1)*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP) IQ1=INITYP(1) IQ2=INITYP(2) IFL1=IQ1/2 IF(2*IFL1.EQ.IQ1) THEN TERM1=TDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) TERM2=TINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) SIGLLQ=SIGLLQ+TERM1+TERM2 ELSE TERM1=UDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) TERM2=UINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) SIGLLQ=SIGLLQ+TERM1+TERM2 ENDIF SIGLLQ=SIGLLQ*UNITS IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ RETURN C C qk + gl --> qk + w C ELSEIF(JETTYP(3).LE.NZERO(JWTYP)) THEN JQK=MATCH(JETTYP(3),4) JQK=MATCH(JQK,JWTYP) IF(JQK.EQ.0) RETURN COUPL=ALFA**2*ALFQSQ*PROP(JWTYP)/(24.*PI*SCM*S) DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2)) IFLQ=JQK/2 IFLL=JETTYP(1)/2 IF(INITYP(2).EQ.1) THEN TDIR=FCDIR(S,T,U,S1,T1,U1)*QSAVE(JQK,1)*QSAVE(1,2) ELSE TDIR=FCDIR(S,U,T,S1,U1,T1)*QSAVE(JQK,2)*QSAVE(1,1) ENDIF TDIR=TDIR*(AQ(IFLQ,JWTYP)**2+BQ(IFLQ,JWTYP)**2) $ *(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2) IF(INITYP(2).EQ.1) THEN TINT=FCINT(S,T,U,S1,T1,U1)*QSAVE(JQK,1)*QSAVE(1,2) ELSE TINT=FCINT(S,U,T,S1,U1,T1)*QSAVE(JQK,2)*QSAVE(1,1) ENDIF TINT=TINT*4.*AQ(IFLQ,JWTYP)*BQ(IFLQ,JWTYP)*AQ(IFLL,JWTYP) $ *BQ(IFLL,JWTYP) SIGLLQ=TDIR+TINT SIGLLQ=SIGLLQ*UNITS IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ SIGLLQ=SIGLLQ*QTW**2/(QTW**2+QT2CUT(QMW)) RETURN C C bt,tp + gl --> bt,tp + W,Z C ELSEIF(JETTYP(3).GE.NZERO(JWTYP)+1) THEN IQ3=JETTYP(3) JQK=MATCH(IQ3,4) JQK=MATCH(JQK,JWTYP) IF(JQK.EQ.0) RETURN AMT=AMASS(6) AMT2=AMT**2 Q2=QMW2 AMF2=AMFAC(IQ3)*AMT2 AMI2=AMFAC(JQK)*AMT2 EFWT=SQRT(P(3)**2+AMF2) P3Z=P(3)*CTH(3) SWT=QMW2+AMF2+2.*Q0W*EFWT-2.*QZW*P3Z+2.*PT(3)**2 C Kinematics IF(INITYP(2).EQ.1) THEN P1WT=EFWT+P3Z+Q0W+QZW P1M=AMI2/P1WT P2WT=EFWT-P3Z+Q0W-QZW-P1M X1WT=.5*P1WT/HALFE X2WT=.5*P2WT/HALFE TWT=-P1WT*(EFWT-P3Z)-P1M*(P(3)+P3Z)+AMI2+AMF2 UWT=-P2WT*(EFWT+P3Z)+AMF2 T1WT=-X2WT*ECM*PT(JF)*EXP(YJ(JF)) U1WT=-X1WT*ECM*PT(JF)*EXP(-YJ(JF))-P1M*PT(JF)*EXP(YJ(JF)) S1WT=-T1WT-U1WT-QMW2+AMI2+AMF2 ELSE P2WT=EFWT-P3Z+Q0W-QZW P2M=AMI2/P2WT P1WT=EFWT+P3Z+Q0W+QZW-P2M X1WT=.5*P1WT/HALFE X2WT=.5*P2WT/HALFE TWT=-P1WT*(EFWT-P3Z)+AMF2 UWT=-P2WT*(EFWT+P3Z)-P2M*(EFWT-P3Z)+AMI2+AMF2 T1WT=-X2WT*ECM*PT(JF)*EXP(YJ(JF))-P2M*PT(JF)*EXP(-YJ(JF)) U1WT=-X1WT*ECM*PT(JF)*EXP(-YJ(JF)) S1WT=-T1WT-U1WT-QMW2+AMI2+AMF2 ENDIF C Cross section SIG0=-ALFA**2*ALFQSQ/(12*PI*SCM*SWT)*PROP(JWTYP)*UNITS IF(JETTYP(1).LE.13) SIG0=3*SIG0 IF(JWTYP.EQ.2.OR.JWTYP.EQ.3) THEN SIG0=SIG0*(AQ(6,JWTYP)**2+BQ(6,JWTYP)**2)**2 IF(INITYP(2).EQ.1.AND.(IQ3.EQ.12.OR.IQ3.EQ.13)) THEN SIGLLQ=AJLWT(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,Q2/SWT, $ AMT2/SWT) SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2 SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,1)*QFCN(X2WT,1,2) ELSEIF(INITYP(1).EQ.1.AND.(IQ3.EQ.12.OR.IQ3.EQ.13)) THEN SIGLLQ=AJLWT(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,Q2/SWT, $ AMT2/SWT) SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2 SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,2)*QFCN(X2WT,1,1) ENDIF ELSEIF(JWTYP.EQ.4) THEN A2=AQ(6,JWTYP)**2 A2B2=AQ(6,JWTYP)**2+BQ(6,JWTYP)**2 AB=AQ(6,JWTYP)*BQ(6,JWTYP) AL2BL2=AQ(JETTYP(1)/2,JWTYP)**2+BQ(JETTYP(1)/2,JWTYP)**2 ALBL=AQ(JETTYP(1)/2,JWTYP)*BQ(JETTYP(1)/2,JWTYP) IF(INITYP(2).EQ.1) THEN SIGLLQ=AJLZT1(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT2(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT3(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT4(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2 SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,1)*QFCN(X2WT,1,2) ELSEIF(INITYP(1).EQ.1) THEN SIGLLQ=AJLZT1(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT2(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT3(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ+AJLZT4(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT, $ Q2/SWT,AMT2/SWT) SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2 SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,2)*QFCN(X2WT,1,1) ENDIF ENDIF ENDIF RETURN C C Standard Drell-Yan with QT=0. C 400 CONTINUE IFLL=JETTYP(1)/2 COUPL=ALFA**2*PROP(JWTYP)*UNITS TDIR=COUPL*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2) $*((U1**2+T1**2)/(6.*SCM*QMW2)) TINT=COUPL*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP) $*((U1**2-T1**2)/(6.*SCM*QMW2)) IQ1=INITYP(1) IQ2=INITYP(2) IFL1=IQ1/2 TERM1=TDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2) $*QSAVE(IQ1,1)*QSAVE(IQ2,2) TERM2=-TINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP) $*QSAVE(IQ1,1)*QSAVE(IQ2,2) IF(2*IFL1.EQ.IQ1) SIGLLQ=SIGLLQ+TERM1+TERM2 IF(2*IFL1.NE.IQ1) SIGLLQ=SIGLLQ+TERM1-TERM2 IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ RETURN END +EOD +DECK,SIGEE. SUBROUTINE SIGEE C C Compute d(sigma)/d(cos theta) with interference C and polarization for C E+ E- --> GM, Z0 ----> QK QB, L LB, N NB, W+ W-, Z Z C C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C USING JETTYPE CODE. C C Extra factor of 1/2 needed because all jets are treated C as identical. C Version 7.42 includes bremsstrahlung contribution; C also, beamstrahlung C Version 7.54: Add Z+H C Add gamma+gamma -> f+ fbar 1/27/04 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSIG +CDE,EEPAR +CDE,PRIMAR +CDE,JETPAR +CDE,Q1Q2 +CDE,CONST +CDE,WCON +CDE,BREMBM +CDE,HCON C REAL FLEP,FLEM,FREP,FREM,PROPZ,REDZ,SH,E,G,GP,COS2W, $TNTHW,CTTHW,ALQ(2),BEQ(2),ALL(2),BEL(2),AE,BE,EQ,AMQ,AMQ2, $PCM,Z,AF,BF,PHILRG,PHILRZ,PHILRI,PHIRLG,PHIRLZ,PHIRLI, $THT,UH,RSH,UT,PHIRL,PHILR,SIGLR,SIGRL,SIG,AMASS,EE, $ALFAEM,AMZ,GAMZ,AMW,JAC,ESTRUC,SSFEL,FACLR,FACRL,EZ0,FAC1, $BKT_GG,SIG_GG,GSTRUC,GBEAM REAL AMH,SSXLAM INTEGER I,IQ,IQ2,IFL,ISGN,IQ2EQ(25),LISTJ(29) DATA IQ2EQ/0,2,-2,-1,1,-1,1,2,-2,-1,1,2,-2,0,0,-3,3, $0,0,-3,3,0,0,-3,3/ DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, $10,80,-80,90/ C Fractional polarizations FLEP=(1.+PLEP)/2. FLEM=(1.+PLEM)/2. FREP=(1.-PLEP)/2. FREM=(1.-PLEM)/2. C FUNCTIONS ALFAEM=1./128. AMZ=WMASS(4) GAMZ=WGAM(4) AMW=WMASS(3) AMH=HMASS IF (IBREM) THEN SH=SHAT JAC=2*(1.-SHAT/SCM)*2*SQRT(SH)*(RSHMAX-RSHMIN)/SCM/(X1+X2) ELSE SH=SCM END IF PROPZ=(SH-AMZ**2)**2+AMZ**2*GAMZ**2 REDZ=(SH-AMZ**2)/PROPZ C C CONSTANTS RSH=SQRT(SH) EE=RSH/2. QSQBM=QSQ E=SQRT(4*PI*ALFAEM) G=SQRT(4*PI*ALFAEM/SIN2W) GP=G*SQRT(SIN2W/(1.-SIN2W)) COS2W=1.-SIN2W TNTHW=SQRT(SIN2W/COS2W) CTTHW=1./TNTHW ALQ(1)=CTTHW/4.-5*TNTHW/12. BEQ(1)=-(CTTHW+TNTHW)/4. ALQ(2)=TNTHW/12.-CTTHW/4. BEQ(2)=-BEQ(1) ALL(1)=(CTTHW+TNTHW)/4. BEL(1)=-(CTTHW+TNTHW)/4. ALL(2)=(3*TNTHW-CTTHW)/4. BEL(2)=-BEL(1) AE=ALL(2) BE=BEL(2) C C ENTRY SIG=0. SIGMA=0. NSIGS=0 DO 10 I=1,MXSIGS 10 SIGS(I)=0. C C Sum over allowed jet types. IQ labels JETTYPE1. C DO 100 IQ=2,25 IQ2=MATCH(IQ,4) IF(.NOT.(GOQ(IQ,1).AND.GOQ(IQ2,2))) GO TO 100 IFL=IQ/2 EQ=ABS(FLOAT(IQ2EQ(IQ))/3.) IF (EQ.LT..5.OR.EQ.GT..8) EQ=-EQ ISGN=1 IF(2*IFL.NE.IQ) ISGN=2 AMQ=AMASS(LISTJ(IQ)) AMQ2=AMQ**2 IF(2.*AMQ.GE.ECM) GO TO 100 PCM=.5*SQRT(SH-4.*AMQ2) Z=CTH(ISGN) IF (IQ.LE.13.AND.ABS(EQ).GT..5) THEN AF=ALQ(1) BF=BEQ(1) ELSE IF (IQ.LE.13.AND.ABS(EQ).LT..5) THEN AF=ALQ(2) BF=BEQ(2) ELSE IF (IQ.GT.13.AND.ABS(EQ).EQ.0.) THEN AF=ALL(1) BF=BEL(1) ELSE AF=ALL(2) BF=BEL(2) END IF PHILRG=EQ**2/SH**2*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2)) PHILRZ=(AE-BE)**2/PROPZ*((AF**2+BF**2)*(EE**2+PCM**2*Z**2)- , 4*AF*BF*EE*PCM*Z+(AF**2-BF**2)*AMQ2) PHILRI=-2*EQ*(AE-BE)*REDZ/SH* , (AF*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2))-2*BF*EE*PCM*Z) PHILR=E**4*(PHILRG+PHILRZ+PHILRI) PHIRLG=PHILRG PHIRLZ=(AE+BE)**2/PROPZ*((AF**2+BF**2)*(EE**2+PCM**2*Z**2)+ , 4*AF*BF*EE*PCM*Z+(AF**2-BF**2)*AMQ2) PHIRLI=-2*EQ*(AE+BE)*REDZ/SH* , (AF*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2))+2*BF*EE*PCM*Z) PHIRL=E**4*(PHIRLG+PHIRLZ+PHIRLI) SIGLR=4*PCM*PHILR/16./PI/EE SIGRL=4*PCM*PHIRL/16./PI/EE SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. BKT_GG=(EE**2+PCM**2*Z**2)/(AMQ2+PCM**2*(1.-Z**2))+ , 2*AMQ2/(AMQ2+PCM**2*(1.-Z**2))-2*AMQ2**2/ , (AMQ2+PCM**2*(1.-Z**2))**2 SIG_GG=EQ**4*2*PI*ALFAEM**2/SH*(PCM/EE)*BKT_GG*UNITS/2. IF (IQ.LE.13) THEN SIG=3*SIG SIG_GG=3*SIG_GG END IF IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC SIG=SIG+SIG_GG*GSTRUC(X1,QSQ)*GSTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC IF (GAMGAM) THEN SIG=SIG+SIG_GG*GSTRUC(X1,QSQ)*GSTRUC(X2,QSQ)*JAC+ , SIG_GG*GBEAM(X1,EB)*GBEAM(X2,EB)*JAC END IF END IF CALL SIGFIL(SIG,0,0,IQ,IQ2) 100 CONTINUE C Z Z Cross section IF(.NOT.(GOQ(29,1).AND.GOQ(29,2))) GO TO 200 PCM=.5*SQRT(SH-4.*AMZ**2) THT=AMZ**2-SH/2.+RSH*PCM*CTH(1) UH=2*AMZ**2-SH-THT SIGLR=4*E**4*(AE-BE)**4*PCM/16./PI/SH/RSH* , (UH/THT+THT/UH+4*AMZ**2*SH/UH/THT-AMZ**4*(1./THT**2+1./UH**2)) SIGRL=4*E**4*(AE+BE)**4*PCM/16./PI/SH/RSH* , (UH/THT+THT/UH+4*AMZ**2*SH/UH/THT-AMZ**4*(1./THT**2+1./UH**2)) SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,29,29) 200 CONTINUE C W W Cross section IF(.NOT.(GOQ(27,1).AND.GOQ(28,2))) GO TO 300 PCM=.5*SQRT(SH-4.*AMW**2) THT=AMW**2-SH/2.+RSH*PCM*CTH(2) UH=2*AMW**2-SH-THT UT=UH*THT-AMW**4 PHIRL=4*(AE+BE)**2*TNTHW**2/SH/SH/PROPZ* , (UT*(PCM**2*SH+3*AMW**4)+4*AMW**2*PCM**2*SH*SH) PHILR=UT/SH/SH*(3.+2*(AE-BE)*TNTHW*(SH-6*AMW**2)*REDZ+ , 4*(AE-BE)**2*TNTHW**2*(PCM**2*SH+3*AMW**4)/PROPZ)+ , 8*(AE-BE)*TNTHW*AMW**2*REDZ+16*(AE-BE)**2*TNTHW**2* , AMW**2*PCM**2/PROPZ+2*(1.-2*(AE-BE)*TNTHW*AMW**2*REDZ)* , (UT/SH/THT-2*AMW**2/THT)+UT/THT**2 SIGLR=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHILR SIGRL=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHIRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,27,28) 300 CONTINUE IF(.NOT.(GOQ(28,1).AND.GOQ(27,2))) GO TO 400 PCM=.5*SQRT(SH-4.*AMW**2) THT=AMW**2-SH/2.+RSH*PCM*CTH(1) UH=2*AMW**2-SH-THT UT=UH*THT-AMW**4 PHIRL=4*(AE+BE)**2*TNTHW**2/SH/SH/PROPZ* , (UT*(PCM**2*SH+3*AMW**4)+4*AMW**2*PCM**2*SH*SH) PHILR=UT/SH/SH*(3.+2*(AE-BE)*TNTHW*(SH-6*AMW**2)*REDZ+ , 4*(AE-BE)**2*TNTHW**2*(PCM**2*SH+3*AMW**4)/PROPZ)+ , 8*(AE-BE)*TNTHW*AMW**2*REDZ+16*(AE-BE)**2*TNTHW**2* , AMW**2*PCM**2/PROPZ+2*(1.-2*(AE-BE)*TNTHW*AMW**2*REDZ)* , (UT/SH/THT-2*AMW**2/THT)+UT/THT**2 SIGLR=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHILR SIGRL=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHIRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,28,27) 400 CONTINUE C C Higgs boson mechanisms C E+ E- --> Z H_SM; symmetric in cos(theta) C IF(AMH.GT.0.AND.(AMZ+AMH).LT.RSH) THEN FACLR=E**2*G**2*(AE-BE)**2/COS2W FACRL=E**2*G**2*(AE+BE)**2/COS2W Z=CTH(1) PCM=SQRT(SSXLAM(SH,AMZ**2,AMH**2))/4./EE EZ0=SQRT(PCM**2+AMZ**2) FAC1=AMZ**2+EZ0**2-PCM**2*Z**2 SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(29,1).AND.GOQ(30,2)) CALL SIGFIL(SIG,0,0,29,30) IF(GOQ(30,1).AND.GOQ(29,2)) CALL SIGFIL(SIG,0,0,30,29) ENDIF C----------------------------------------------------------------------- RETURN END +EOD +DECK,SIGFIL. SUBROUTINE SIGFIL(SIG,I1,I2,I3,I4) C Fill /JETSIG/ arrays if SIG > 0 C Write error message if SIG < 0 +CDE,ITAPES +CDE,JETSIG. C IF(SIG.GT.0) THEN NSIGS=NSIGS+1 SIGMA=SIGMA+SIG SIGS(NSIGS)=SIG INOUT(NSIGS)=I1+IOPAK*(I2+IOPAK*(I3+IOPAK*I4)) ELSEIF(SIG.LT.0.) THEN WRITE(ITLIS,1010) SIG,I1,I2,I3,I4 1010 FORMAT(' ERROR IN SIGFIL ... SIG = ',E12.5,' FOR ',4I6) ENDIF RETURN END +EOD +DECK,SIGGAM. SUBROUTINE SIGGAM C C Compute D(SIGMA)/D(PT**2)D(Y1)D(Y2) for gamma + jet and C gamma + gamma. C C SIGMA = cross section summed over quark types allowed by C JETTYPE card. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C C Cross sections from Berger, Bratten, and Field, Nucl. Phys. C B239, 52 (1984), Table 2. Masses are neglected. C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,CONST +CDE,WCON C REAL BBF1,BBF2,BBF3,S,T,U,FJAC,STRUC,SIG0,SIG,BBF3TU,BBF3UT INTEGER I,IH,IQ,IFL REAL X(2),QSAVE(13,2) INTEGER LISTJ(13) EQUIVALENCE (X(1),X1),(S,SHAT),(T,THAT),(U,UHAT) DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6/ C C Cross sections with couplings and Jacobean removed. BBF1(S,T,U)=8./9.*(U/T+T/U) BBF2(S,T,U)=2./3.*(U/T+T/U) BBF3(S,T,U)=-1./3.*(U/S+S/U) C C Initialize cross sections. C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS SIGS(I)=0. 100 CONTINUE C C Kinematics and structure functions for CH and lighter quarks C CALL TWOKIN(0.,0.,0.,0.) FJAC=SHAT/SCM*UNITS*PI/SHAT**2 IF(X1.GE.1.0.OR.X2.GE.1.0) RETURN DO 110 IH=1,2 DO 110 IQ=1,9 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) 110 CONTINUE C C Compute cross sections summed over all types allowed by C JETTYPE card. C IF(.NOT.(GOQ(26,1).OR.GOQ(26,2))) RETURN C C Gluon-photon C IF((GOQ(1,1).AND.GOQ(26,2)).OR.(GOQ(26,1).AND.GOQ(1,2))) THEN SIG0=.5*FJAC*ALFQSQ*ALFA*BBF1(S,T,U) DO 210 I=1,4 IFL=LISTJ(2*I) SIG=SIG0*AQ(IFL,1)**2*QSAVE(2*I,1)*QSAVE(2*I+1,2) IF(GOQ(26,1).AND.GOQ(1,2)) CALL SIGFIL(SIG,2*I,2*I+1,26,1) IF(GOQ(1,1).AND.GOQ(26,2)) CALL SIGFIL(SIG,2*I,2*I+1,1,26) SIG=SIG0*AQ(IFL,1)**2*QSAVE(2*I+1,1)*QSAVE(2*I,2) IF(GOQ(26,1).AND.GOQ(1,2)) CALL SIGFIL(SIG,2*I+1,2*I,26,1) IF(GOQ(1,1).AND.GOQ(26,2)) CALL SIGFIL(SIG,2*I+1,2*I,1,26) 210 CONTINUE ENDIF C C Photon-photon C IF(GOQ(26,1).AND.GOQ(26,2)) THEN SIG0=.5*FJAC*ALFA**2*BBF2(S,T,U) DO 220 I=1,4 IFL=LISTJ(2*I) SIG=SIG0*AQ(IFL,1)**4*QSAVE(2*I,1)*QSAVE(2*I+1,2) CALL SIGFIL(SIG,2*I,2*I+1,26,26) SIG=SIG0*AQ(IFL,1)**4*QSAVE(2*I+1,1)*QSAVE(2*I,2) CALL SIGFIL(SIG,2*I+1,2*I,26,26) 220 CONTINUE ENDIF C C Quark-photon C BBF3TU=.5*FJAC*ALFA*ALFQSQ*BBF3(S,T,U) BBF3UT=.5*FJAC*ALFA*ALFQSQ*BBF3(S,U,T) DO 230 I=2,9 IFL=IABS(LISTJ(I)) IF(GOQ(26,1).AND.GOQ(I,2)) THEN SIG=BBF3TU*AQ(IFL,1)**2*QSAVE(I,1)*QSAVE(1,2) CALL SIGFIL(SIG,I,1,26,I) SIG=BBF3UT*AQ(IFL,1)**2*QSAVE(1,1)*QSAVE(I,2) CALL SIGFIL(SIG,1,I,26,I) ENDIF IF(GOQ(I,1).AND.GOQ(26,2)) THEN SIG=BBF3UT*AQ(IFL,1)**2*QSAVE(I,1)*QSAVE(1,2) CALL SIGFIL(SIG,I,1,I,26) SIG=BBF3TU*AQ(IFL,1)**2*QSAVE(1,1)*QSAVE(I,2) CALL SIGFIL(SIG,1,I,I,26) ENDIF 230 CONTINUE C RETURN END +EOD +DECK,SIGH SUBROUTINE SIGH C C COMPUTE THE INTEGRATED WEINBERG-SALAM HIGGS CROSS SECTION C D(SIGMA)/D(QMW**2)D(YW) C C SIGMA = CROSS SECTION SUMMED OVER QUARK TYPES ALLOWED BY C JETTYPE3 AND WTYPE CARDS. C SIGS(I) = PARTIAL CROSS SECTION FOR I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C USING JETTYPE CODE. C C VER. 7.14: CHECK INITIAL QUARK MASS IS ALLOWED C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,JETLIM +CDE,HCON C DIMENSION AMQCUR(6),LISTW(4),WTHELI(4),FINT(9) DIMENSION X(2) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) +SELF,IF=DOUBLE. DOUBLE PRECISION C,TERM,SUM,FINT,ZLIM +SELF. DATA AMQCUR/.005,.009,.175,1.25,4.50,30./ DATA LISTW/10,80,-80,90/ C WTHELI ARE WEIGHTS OF HELICITY AMPLITUDES IN SIGMA. DATA WTHELI/1.,2.,2.,4./ C C FUNCTIONS ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.)) ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z)) C C KINEMATICS (IDENTICAL TO DRELL-YAN) C AMQCUR(6)=AMASS(6) QMW2=QMW**2 QTMW=SQRT(QMW2+QTW**2) Q0W=QTMW*COSH(YW) QZW=QTMW*SINH(YW) QW=SQRT(QZW**2+QTW**2) IF(QW.NE.0.) THEN CTHW=QZW/QW STHW=QTW/QW IF(ABS(CTHW).LT.1.) THEN THW=ACOS(CTHW) ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF EHAT=QMW SHAT=QMW**2 QSQ=SHAT ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2)) Q2SAVE=QSQ YHAT=YW EY=EXP(YHAT) X1=EHAT/ECM*EY X2=EHAT/(ECM*EY) C C INITIALIZE C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS 100 SIGS(I)=0 C IF(X1.GE.1..OR.X2.GE.1.) RETURN C C COMPUTE STRUCTURE FUNCTIONS DO 110 IH=1,2 DO 120 IQ=1,13 120 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) DO 130 IQ=14,26 130 QSAVE(IQ,IH)=0. DO 140 IW=2,4 AMW=AMASS(LISTW(IW)) IF(QMW.GT.2.*AMW) THEN QSAVE(25+IW,IH)=STRUCW(X(IH),IW,IDIN(IH))/X(IH) ELSE QSAVE(25+IW,IH)=0. ENDIF 140 CONTINUE 110 CONTINUE C C CALCULATE HIGGS-GLUON-GLUON COUPLING FOR GIVEN Q**2 ETAR=0. ETAI=0. DO 150 IQ=1,8 AMQ=AMASS(IQ) IF(AMQ.LE.0.) GO TO 150 RQ=(2.*AMQ/HMASS)**2 IF(RQ.GE.1.) THEN ETAR=ETAR+.5*RQ*(1.+(1.-RQ)*ASIN(1./SQRT(RQ))**2) ELSE RQLOG=ALOG((1.+SQRT(1.-RQ))/(1.-SQRT(1.-RQ))) PHIR=.25*(RQLOG**2-PI**2) ETAR=ETAR+.5*RQ*(1.+(RQ-1.)*PHIR) PHII=.5*PI*RQLOG ETAI=ETAI+.5*RQ*(RQ-1.)*PHII ENDIF 150 CONTINUE ETAHGG=ETAR**2+ETAI**2 C C GL + GL --> HIGGS C SIG0=GF*ALFQSQ**2/(32.*PI*SQRT2)*ETAHGG*X1*X2*UNITS SIG0=SIG0*S/(PI*HMASS*((S-HMASS**2)**2+(HMASS*HGAM)**2)) SIG0=SIG0*QSAVE(1,1)*QSAVE(1,2) DO 160 IQ1=2,29 IQ2=MATCHH(IQ1) IF(GOQ(IQ1,1).AND.GOQ(IQ2,2)) THEN SIG=SIG0*HGAMS(IQ1) IF(IQ1.GT.25) SIG=SIG*TBRWW(IQ1-25,1)*TBRWW(IQ2-25,2) CALL SIGFIL(SIG,1,1,IQ1,IQ2) ENDIF 160 CONTINUE C C QK + QB --> HIGGS C SIG0=PI*GF/(3.*SQRT2*HMASS**2)*X1*X2*UNITS SIG0=SIG0*S/(PI*HMASS*((S-HMASS**2)**2+(HMASS*HGAM)**2)) DO 210 IQ1=2,13 IQ2=MATCHH(IQ1) AMQ=AMQCUR(IQ1/2) IF(QMW.LE.2*AMQ) GO TO 210 SIG1=SIG0*AMQ**2*QSAVE(IQ1,1)*QSAVE(IQ2,2) DO 220 IQ3=2,29 IQ4=MATCHH(IQ3) IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN SIG=SIG1*HGAMS(IQ3) IF(IQ3.GT.25) SIG=SIG*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4) ENDIF 220 CONTINUE 210 CONTINUE C C W+W FUSION AND W+W->W+W IN EFFECTIVE W APPROXIMATION WITH C ANGULAR DISTRIBUTION CUT OFF BY PTMIN. C Z0 Z0 FINAL STATE HAS SYMMETRY FACTOR OF .5 C IF(QMW.LE.2.*AMASS(80)) GO TO 500 C C W+ W- --> W+ W- C IF(.NOT.((GOQ(27,1).AND.GOQ(28,2)).OR.(GOQ(28,1).AND.GOQ(27,2)))) $GO TO 400 WM=AMASS(80) PWWCM=.5*SQRT(QMW**2-4.*WM**2) STHLIM=PTMIN(1)/PWWCM IF(STHLIM.LE.1) THEN ZLIM=SQRT(1.-STHLIM**2) ELSE GO TO 400 ENDIF C SET UP AMPLITUDES CALL XWWWW C SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS. C L RUNS OVER HELICITY STATES. N RUNS OVER POWERS. C REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2) SUM=0. DO 311 I=1,4 DO 311 J=I,4 CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J), $ADWWWW(2,J)) DO 312 L=1,4 TERM=0. DO 313 N=0,6 C=0. N1=MAX(N-3,0) N2=MIN(3,N) DO 314 K=N1,N2 314 C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L) C=C*WTHELI(L) IF(J.NE.I) C=2.*C IF(L.EQ.4) THEN TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3) ELSE TERM=TERM+C*FINT(N+1) ENDIF 313 CONTINUE SUM=SUM+TERM 312 CONTINUE 311 CONTINUE C ADD INTEGRAL OF IMAGINARY PART SQUARED. SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2 $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2) C CROSS SECTION SIG0=SUM/(32.*PI*S*SCM)*UNITS SIG1=.5*SIG0*QSAVE(27,1)*QSAVE(28,2) IF(GOQ(27,1).AND.GOQ(28,2)) THEN SIG=SIG1*TBRWW(2,1)*TBRWW(3,2) CALL SIGFIL(SIG,27,28,27,28) ENDIF IF(GOQ(28,1).AND.GOQ(27,2)) THEN SIG=SIG1*TBRWW(3,1)*TBRWW(2,2) CALL SIGFIL(SIG,27,28,28,27) ENDIF SIG1=.5*SIG0*QSAVE(28,1)*QSAVE(27,2) IF(GOQ(27,1).AND.GOQ(28,2)) THEN SIG=SIG1*TBRWW(2,1)*TBRWW(3,2) CALL SIGFIL(SIG,28,27,27,28) ENDIF IF(GOQ(28,1).AND.GOQ(27,2)) THEN SIG=SIG1*TBRWW(3,1)*TBRWW(2,2) CALL SIGFIL(SIG,28,27,28,27) ENDIF C C Z0 Z0 --> W+ W- C C SET UP AMPLITUDES IF(QMW.LE.2.*AMASS(90)) GO TO 500 CALL XZZWW C SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS. C L RUNS OVER HELICITY STATES. N RUNS OVER POWERS. C REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2) SUM=0. DO 321 I=1,4 DO 321 J=I,4 CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J), $ADWWWW(2,J)) DO 322 L=1,4 TERM=0. DO 323 N=0,6 C=0. N1=MAX(N-3,0) N2=MIN(3,N) DO 324 K=N1,N2 324 C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L) C=C*WTHELI(L) IF(J.NE.I) C=2.*C IF(L.EQ.4) THEN TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3) ELSE TERM=TERM+C*FINT(N+1) ENDIF 323 CONTINUE SUM=SUM+TERM 322 CONTINUE 321 CONTINUE C ADD INTEGRAL OF IMAGINARY PART SQUARED. SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2 $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2) C CROSS SECTION SIG0=SUM/(32.*PI*S*SCM)*UNITS SIG1=.5*SIG0*QSAVE(29,1)*QSAVE(29,2) IF(GOQ(27,1).AND.GOQ(28,2)) THEN SIG=SIG1*TBRWW(2,1)*TBRWW(3,2) CALL SIGFIL(SIG,29,29,27,28) ENDIF IF(GOQ(28,1).AND.GOQ(27,2)) THEN SIG=SIG1*TBRWW(3,1)*TBRWW(2,2) CALL SIGFIL(SIG,29,29,28,27) ENDIF C C W+ W- --> Z0 Z0 C 400 IF(QMW.LE.2.*AMASS(90)) GO TO 500 IF(.NOT.(GOQ(29,1).AND.GOQ(29,2))) GO TO 500 WM=AMASS(90) PWWCM=.5*SQRT(QMW**2-4.*WM**2) STHLIM=PTMIN(1)/PWWCM IF(STHLIM.LE.1) THEN ZLIM=SQRT(1.-STHLIM**2) ELSE GO TO 500 ENDIF C SET UP AMPLITUDES CALL XWWZZ C SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS. C L RUNS OVER HELICITY STATES. N RUNS OVER POWERS. C REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2) SUM=0. DO 411 I=1,4 DO 411 J=I,4 CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J), $ADWWWW(2,J)) DO 412 L=1,4 TERM=0. DO 413 N=0,6 C=0. N1=MAX(N-3,0) N2=MIN(3,N) DO 414 K=N1,N2 414 C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L) C=C*WTHELI(L) IF(J.NE.I) C=2.*C IF(L.EQ.4) THEN TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3) ELSE TERM=TERM+C*FINT(N+1) ENDIF 413 CONTINUE SUM=SUM+TERM 412 CONTINUE 411 CONTINUE C ADD INTEGRAL OF IMAGINARY PART SQUARED. SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2 $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2) C CROSS SECTION SIG0=SUM/(32.*PI*S*SCM)*UNITS SIG0=.5*SIG0 SIG0=SIG0*TBRWW(4,1)*TBRWW(4,2) SIG=SIG0*QSAVE(27,1)*QSAVE(28,2) CALL SIGFIL(SIG,27,28,29,29) SIG=SIG0*QSAVE(28,1)*QSAVE(27,2) CALL SIGFIL(SIG,28,27,29,29) C C Z0 Z0 --> Z0 Z0 C C SET UP AMPLITUDES CALL XZZZZ C SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS. C L RUNS OVER HELICITY STATES. N RUNS OVER POWERS. C REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2) SUM=0. DO 421 I=1,4 DO 421 J=I,4 CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J), $ADWWWW(2,J)) DO 422 L=1,4 TERM=0. DO 423 N=0,6 C=0. N1=MAX(N-3,0) N2=MIN(3,N) DO 424 K=N1,N2 424 C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L) C=C*WTHELI(L) IF(J.NE.I) C=2.*C IF(L.EQ.4) THEN TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3) ELSE TERM=TERM+C*FINT(N+1) ENDIF 423 CONTINUE SUM=SUM+TERM 422 CONTINUE 421 CONTINUE C ADD INTEGRAL OF IMAGINARY PART SQUARED. SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2 $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2) C CROSS SECTION SIG0=SUM/(32.*PI*S*SCM)*UNITS SIG0=.5*SIG0 SIG0=SIG0*TBRWW(4,1)*TBRWW(4,2) SIG=SIG0*QSAVE(29,1)*QSAVE(29,2) CALL SIGFIL(SIG,29,29,29,29) C 500 RETURN END +EOD +DECK,SIGH2 SUBROUTINE SIGH2 C C COMPUTE THE WEINBERG-SALAM HIGGS CROSS SECTION C D(SIGMA)/D(QMW**2)D(YW)D(OMEGA) C FOR THE SPECIFIED JET TYPES. TRIVIAL EXCEPT FOR W W FUSION, C WHICH HAS INTERFERENCE WITH W W SCATTERING. C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PJETS +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,WSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,HCON C DIMENSION X(2),LISTJ(29),WTHELI(4) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) +SELF,IF=DOUBLE. DOUBLE PRECISION C,TERM,SUM,DENOM,ZCM +SELF. C C WTHELI ARE WEIGHTS OF HELICITY AMPLITUDES IN SIGMA. DATA WTHELI/1.,2.,2.,4./ DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, $10,80,-80,90/ C C QUARK OR GLUON FUSION TO HIGGS C IF(INITYP(1).LE.25) THEN SIGLLQ=SIGEVT/(4.*PI) RETURN ENDIF C C W+W FUSION AND W+W->W+W IN EFFECTIVE W APPROXIMATION. C C KINEMATICS IFL1=LISTJ(JETTYP(1)) IFL2=LISTJ(JETTYP(2)) IFIN1=LISTJ(INITYP(1)) IFIN2=LISTJ(INITYP(2)) WMF=AMASS(IFL1) WMI=AMASS(IFIN1) PINPF=SQRT((S-4.*WMI**2)*(S-4.*WMF**2)) ZCM=(.5*S+T-WMI**2-WMF**2)/(.5*PINPF) C RESET COEFFICIENTS FOR SELECTED PROCESS IABSI=IABS(IFIN1) IABSF=IABS(IFL1) IF(IABSI.EQ.80) THEN IF(IABSF.EQ.80) THEN CALL XWWWW ELSE CALL XWWZZ ENDIF ELSE IF(IABSF.EQ.80) THEN CALL XZZWW ELSE CALL XZZZZ ENDIF ENDIF C SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS. C L RUNS OVER HELICITY STATES. N RUNS OVER POWERS. C REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2) SUM=0. DO 111 I=1,4 DO 111 J=I,4 DENOM=1./((ADWWWW(1,I)+ADWWWW(2,I)*ZCM) $*(ADWWWW(1,J)+ADWWWW(2,J)*ZCM)) DO 112 L=1,4 TERM=0. DO 113 N=0,6 C=0. N1=MAX(N-3,0) N2=MIN(3,N) DO 114 K=N1,N2 114 C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L) C=C*WTHELI(L) IF(J.NE.I) C=2.*C TERM=TERM+C*ZCM**N 113 CONTINUE IF(L.EQ.4) TERM=TERM*(1.-ZCM**2)/2. TERM=TERM*DENOM SUM=SUM+TERM 112 CONTINUE 111 CONTINUE C ADD IMAGINARY PART SQUARED. SUM=SUM+WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2 $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2 C CROSS SECTION. NOTE D(OMEGA)=2.*PI*D(Z) SIG0=SUM/(64.*PI**2*S*SCM)*UNITS SIG0=SIG0*TBRWW(JETTYP(1)-25,1)*TBRWW(JETTYP(2)-25,2) C SYMMETRY FACTOR IF(IABSF.EQ.90) SIG0=.5*SIG0 SIGLLQ=SIG0*QSAVE(INITYP(1),1)*QSAVE(INITYP(2),2) RETURN END +EOD +DECK,SIGH3 SUBROUTINE SIGH3 C C Calculate angular distributions for W decays from Higgs, C d(sigma)/d(qmw**2)d(yw)d(omega)d(omega1)d(omega2) C C Ver 7.14: Only modification needed for MSSM is to check C GOMSSM flag instead of INITYP C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PJETS +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,WSIG +CDE,WWSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,WWPAR +CDE,HCON +CDE,XMSSM C EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) DIMENSION IDADDR(4),IW(2),LAM(3),LISTJ(29) $,T12(3,3),T34(3,3),FTERM(4),FR(3,3),FI(3,3) $,CPHI12(3),SPHI12(3),CPHI34(3),SPHI34(3) DIMENSION PFCM(5,4),PWCM(5,2) +SELF,IF=DOUBLE. DOUBLE PRECISION TERM,FTERM,ZCM +SELF. DATA LAM/0,1,-1/ DATA LISTJ/ $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, $10,80,-80,90/ C C FUNCTIONS DOTP(I,J)=PPAIR(4,I)*PPAIR(4,J)-PPAIR(1,I)*PPAIR(1,J) $-PPAIR(2,I)*PPAIR(2,J)-PPAIR(3,I)*PPAIR(3,J) C C ENTRY IF(NPAIR.NE.4) RETURN C C RECONSTRUCT W-->FF DECAY ANGLES C C INITIALIZE PFCM AND PWCM DO 10 I=1,4 DO 10 K=1,5 10 PFCM(K,I)=PPAIR(K,I) DO 11 I=1,2 DO 11 K=1,5 11 PWCM(K,I)=PJETS(K,I) C C Z BOOST TO WW CENTER OF MASS CHWW=QWJET(4)/QWJET(5) SHWW=QWJET(3)/QWJET(5) DO 20 I=1,4 TMP=CHWW*PFCM(4,I)-SHWW*PFCM(3,I) PFCM(3,I)=-SHWW*PFCM(4,I)+CHWW*PFCM(3,I) 20 PFCM(4,I)=TMP DO 21 I=1,2 TMP=CHWW*PWCM(4,I)-SHWW*PWCM(3,I) PWCM(3,I)=-SHWW*PWCM(4,I)+CHWW*PWCM(3,I) 21 PWCM(4,I)=TMP C C ROTATE W1 TO +Z AXIS PTW1=SQRT(PWCM(1,1)**2+PWCM(2,1)**2) CPHIW1=PWCM(1,1)/PTW1 SPHIW1=PWCM(2,1)/PTW1 PW1=SQRT(PTW1**2+PWCM(3,1)**2) CTHW1=PWCM(3,1)/PW1 STHW1=PTW1/PW1 C Z ROTATION DO 30 I=1,4 TMP=CPHIW1*PFCM(1,I)+SPHIW1*PFCM(2,I) PFCM(2,I)=-SPHIW1*PFCM(1,I)+CPHIW1*PFCM(2,I) 30 PFCM(1,I)=TMP C Y ROTATION DO 31 I=1,4 TMP=CTHW1*PFCM(1,I)-STHW1*PFCM(3,I) PFCM(3,I)=STHW1*PFCM(1,I)+CTHW1*PFCM(3,I) 31 PFCM(1,I)=TMP C C BOOST TO W REST FRAMES CHW1=PWCM(4,1)/PWCM(5,1) SHW1=PW1/PWCM(5,1) DO 40 I=1,4 IF(I.LE.2) THEN SHWI=SHW1 ELSE SHWI=-SHW1 ENDIF TMP=CHW1*PFCM(4,I)-SHWI*PFCM(3,I) PFCM(3,I)=-SHWI*PFCM(4,I)+CHW1*PFCM(3,I) 40 PFCM(4,I)=TMP C C COMPUTE ANGLES TH12=ACOS(PFCM(3,1)/SQRT(PFCM(1,1)**2+PFCM(2,1)**2+PFCM(3,1)**2)) PHI12=ATAN2(PFCM(2,1),PFCM(1,1)) TH34=ACOS(PFCM(3,3)/SQRT(PFCM(1,3)**2+PFCM(2,3)**2+PFCM(3,3)**2)) PHI34=ATAN2(PFCM(2,3),PFCM(1,3)) C C COMPUTE DECAY ANGULAR DISTRIBUTIONS. C DO 100 I=1,4 IDADDR(I)=IABS(IDPAIR(I)) 100 IF(IDADDR(I).GE.11) IDADDR(I)=IDADDR(I)-4 IF(GOMSSM) THEN IW(1)=JETTYP(1)-76 IW(2)=JETTYP(2)-76 ELSE IW(1)=JETTYP(1)-25 IW(2)=JETTYP(2)-25 ENDIF C AMV=PJETS(5,1) GAMV=WGAM(IW(1)) QMH=QMW C COUPLINGS A12=AQ(IDADDR(1),IW(1)) B12=BQ(IDADDR(1),IW(1)) A34=AQ(IDADDR(3),IW(2)) B34=BQ(IDADDR(3),IW(2)) C DECAY DISTRIBUTIONS TVV12=8.*PI*ALFA*(A12**2+B12**2) TVA12=16.*PI*ALFA*A12*B12 COS12=COS(TH12) SIN12=SIN(TH12) T12(1,1)=TVV12*SIN12**2 T12(1,2)=TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2 T12(1,3)=-TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2 T12(2,1)=T12(1,2) T12(2,2)=TVV12*(.5+.5*COS12**2)+TVA12*COS12 T12(2,3)=TVV12*.5*SIN12**2 T12(3,1)=T12(1,3) T12(3,2)=T12(2,3) T12(3,3)=TVV12*(.5+.5*COS12**2)-TVA12*COS12 C TVV34=8.*PI*ALFA*(A34**2+B34**2) TVA34=16.*PI*ALFA*A34*B34 COS34=COS(TH34) SIN34=SIN(TH34) T34(1,1)=TVV34*SIN34**2 T34(1,2)=TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2 T34(1,3)=-TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2 T34(2,1)=T34(1,2) T34(2,2)=TVV34*(.5+.5*COS34**2)+TVA34*COS34 T34(2,3)=TVV34*.5*SIN34**2 T34(3,1)=T34(1,3) T34(3,2)=T34(2,3) T34(3,3)=TVV34*(.5+.5*COS34**2)-TVA34*COS34 C CPHI12(1)=1. CPHI12(2)=COS(PHI12) CPHI12(3)=COS(2.*PHI12) SPHI12(1)=0. SPHI12(2)=SIN(PHI12) SPHI12(3)=SIN(2.*PHI12) CPHI34(1)=1. CPHI34(2)=COS(PHI34) CPHI34(3)=COS(2.*PHI34) SPHI34(1)=0. SPHI34(2)=SIN(PHI34) SPHI34(3)=SIN(2.*PHI34) C TCPHI=CPHI12(2)*CPHI34(2)-SPHI12(2)*SPHI34(2) TSPHI=SPHI12(2)*CPHI34(2)+CPHI12(2)*SPHI34(2) TC2PHI=CPHI12(3)*CPHI34(3)-SPHI12(3)*SPHI34(3) TS2PHI=SPHI12(3)*CPHI34(3)+CPHI12(3)*SPHI34(3) C C PURE HIGGS --> W W. CALCULATE ANGULAR DISTRIBUTION FOR C HIGGS DECAY AND MULTIPLY BY CROSS SECTION. C IF(INITYP(1).LE.25.OR.GOMSSM) THEN F0=.5*QMH**2/AMV**2-1. F1=1. TOTAL=(8.*PI/3.)**2*TVV12*TVV34*(F0**2+2.*F1**2) DIFF=F0**2*T12(1,1)*T34(1,1) $ +F0*F1*(2.*T12(1,2)*T34(1,2)+2.*T12(1,3)*T34(1,3))*TCPHI $ +F1**2*(T12(2,2)*T34(1,2)+T12(3,3)*T34(3,3) $ +2.*T12(2,3)*T34(2,3)*TC2PHI) WWSIG=SIGLLQ*DIFF/TOTAL RETURN ENDIF C C W W FUSION. CALCULATE ANGULAR DISTRIUBTION FOR DECAY C INCLUDING ALL GRAPHS. C C KINEMATICS IFL1=LISTJ(JETTYP(1)) IFL2=LISTJ(JETTYP(2)) IFIN1=LISTJ(INITYP(1)) IFIN2=LISTJ(INITYP(2)) WMF=AMASS(IFL1) WMI=AMASS(IFIN1) PINPF=SQRT((S-4.*WMI**2)*(S-4.*WMF**2)) ZCM=(.5*S+T-WMI**2-WMF**2)/(.5*PINPF) C PRODUCTION AMPLITUDES. REMEMBER MISSING SIN(THETA)/SQRT(2) DO 110 L=1,4 FTERM(L)=0. DO 120 J=1,4 TERM=0. DO 130 I=1,4 130 TERM=TERM+ANWWWW(I,J,L)*ZCM**(I-1) TERM=TERM/(ADWWWW(1,J)+ADWWWW(2,J)*ZCM) 120 FTERM(L)=FTERM(L)+TERM 110 CONTINUE FTERM(4)=FTERM(4)*SQRT(ABS(1.-ZCM**2))/SQRT2 C HELICITY AMPLITUDES. NOTATION IS 0,+,- FR(1,1)=FTERM(1) FI(1,1)=AIWWWW(1) FR(1,2)=FTERM(4) FI(1,2)=AIWWWW(4) FR(2,2)=FTERM(3) FI(2,2)=AIWWWW(3) FR(2,3)=FTERM(2) FI(2,3)=AIWWWW(2) C FR(1,3)=FR(1,2) FI(1,3)=FI(1,2) FR(3,1)=FR(1,3) FI(3,1)=FI(1,3) FR(2,1)=FR(1,2) FI(2,1)=FI(1,2) C FR(3,3)=FR(2,2) FI(3,3)=FI(2,2) FR(3,2)=FR(2,3) FI(3,2)=FI(2,3) C C DIFFERENTIAL DISTRIBUTION FROM DENSITY MATRIX DIFF=0. DO 140 I1=1,3 L1=LAM(I1) DO 140 I2=1,3 L2=LAM(I2) DO 140 I3=1,3 L3=LAM(I3) DO 140 I4=1,3 L4=LAM(I4) L12=L1-L2 I12=IABS(L12)+1 IF(I12.EQ.0) I12=3 L34=L3-L4 I34=IABS(L34)+1 IF(I34.EQ.0) I34=3 C1234=CPHI12(I12)*CPHI34(I34) $-SPHI12(I12)*ISIGN(1,L12)*SPHI34(I34)*ISIGN(1,L34) S1234=SPHI12(I12)*ISIGN(1,L12)*CPHI34(I34) $+CPHI12(I12)*SPHI34(I34)*ISIGN(1,L34) DIFF=DIFF+(FR(I1,I2)*FR(I3,I4)+FI(I1,I2)*FI(I3,I4)) $*T12(I3,I1)*T34(I4,I2)*C1234 $+(FR(I1,I2)*FI(I3,I4)-FI(I1,I2)*FR(I3,I4)) $*T12(I3,I1)*T34(I4,I2)*S1234 140 CONTINUE C INTEGRATED DISTRIBUTION TOTAL=0. DO 150 I1=1,3 DO 150 I2=1,3 TOTAL=TOTAL+FR(I1,I2)**2+FI(I1,I2)**2 150 CONTINUE FAC=(16.*PI/3.*4.*PI*ALFA)**2 FAC=FAC*(A12**2+B12**2)*(A34**2+B34**2) TOTAL=TOTAL*FAC WWSIG=DIFF/TOTAL*SIGLLQ RETURN END +EOD +DECK,SIGHSS SUBROUTINE SIGHSS C C Compute the integrated MSSM Higgs cross section C d(sigma)/d(QMW**2)d(YW) C Since SUSY Higgs are always narrow, can use the widths to C determine couplings and ignore interference with continuum. C C SIGMA = cross section summed over quark types allowed by C JETTYPE and WTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code from LISTSS. C C Ver 7.18: Correct GOQ's and include TBRWW for W/Z modes. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,JETLIM +CDE,HCON C REAL X(2) REAL AMASS,STRUC REAL AM1,AM2,S,T,U,Q2SAVE,YHAT,EY,ANEFF,QMW2,QZW,EHAT,SIG0,SIG, $AMW INTEGER JT1,JT2,I,J,IH,IQ,I1,I2,JTGL,JTOFF EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) C C Kinematics (identical to Drell-Yan) C QMW2=QMW**2 QTMW=SQRT(QMW2+QTW**2) Q0W=QTMW*COSH(YW) QZW=QTMW*SINH(YW) QW=SQRT(QZW**2+QTW**2) IF(QW.NE.0.) THEN CTHW=QZW/QW STHW=QTW/QW IF(ABS(CTHW).LT.1.) THEN THW=ACOS(CTHW) ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF EHAT=QMW SHAT=QMW**2 QSQ=SHAT ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2)) Q2SAVE=QSQ YHAT=YW EY=EXP(YHAT) X1=EHAT/ECM*EY X2=EHAT/(ECM*EY) C C Initialize C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS 100 SIGS(I)=0 IF(X1.GE.1..OR.X2.GE.1.) RETURN C C Compute structure functions C DO 110 IH=1,2 DO 120 IQ=1,13 120 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) DO 130 IQ=14,26 130 QSAVE(IQ,IH)=0. 110 CONTINUE C C gl + gl -> Higgs C JTGL=52 SIG0=PI*HMASS**2/(8*S**2)*HGAMSS(JTGL,JTGL)*X1*X2*UNITS $/((S-HMASS**2)**2+(HMASS*HGAM)**2) SIG0=SIG0*QSAVE(1,1)*QSAVE(1,2) DO 200 I=1,85 DO 210 J=1,85 IF(HGAMSS(I,J).EQ.0) GO TO 210 IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 210 SIG=SIG0*HGAMSS(I,J) C Include W/Z branching ratios IF((I.GE.78.AND.I.LE.80).AND.(J.GE.78.AND.J.LE.80)) THEN SIG=SIG*TBRWW(I-76,1)*TBRWW(J-76,2) ENDIF CALL SIGFIL(SIG,JTGL,JTGL,I,J) 210 CONTINUE 200 CONTINUE C C qk + qb -> Higgs C JTOFF=51 C Note I1,I2 run over quarks; JT1,JT2,I,J over LISTSS DO 300 I1=2,13 AM1=AMASS(I1/2) JT1=I1+JTOFF DO 310 I2=2,13 AM2=AMASS(I2/2) JT2=I2+JTOFF IF(HGAMSS(JT1,JT2).LE.0) GO TO 310 SIG0=4*PI*HMASS**2/(9*S**2)*HGAMSS(JT1,JT2)*X1*X2*UNITS $ /((S-HMASS**2)**2+(HMASS*HGAM)**2) SIG0=SIG0*QSAVE(I1,1)*QSAVE(I2,2) C Decay partial cross sections DO 320 I=1,85 DO 330 J=1,85 IF(HGAMSS(I,J).EQ.0) GO TO 330 IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 330 SIG=SIG0*HGAMSS(I,J) C Include W/Z branching ratios IF((I.GE.78.AND.I.LE.80).AND.(J.GE.78.AND.J.LE.80)) THEN SIG=SIG*TBRWW(I-76,1)*TBRWW(J-76,2) ENDIF CALL SIGFIL(SIG,JT1,JT2,I,J) 330 CONTINUE 320 CONTINUE 310 CONTINUE 300 CONTINUE C RETURN END +EOD +DECK,SIGINT SUBROUTINE SIGINT(F,Z,A1S,B1S,A2S,B2S) C C F(N+1) = INT(-Z,Z)(DX X**N/((A1+B1*X)*A2+B2*X))) C F(8) = F(9) = 0 (DUMMY VALUES) C DIMENSION F(9) +SELF,IF=DOUBLE. DOUBLE PRECISION A1,B1,A2,B2,A,B,C,Z,F,A1S,B1S,A2S,B2S +SELF. C A1=A1S B1=B1S A2=A2S B2=B2S F(8)=0. F(9)=0. C C SPECIAL CASE: X**N/(A1*A2) IF(B1.EQ.0..AND.B2.EQ.0.) THEN F(1)=2.*Z/(A1*A2) F(2)=0. F(3)=2.*Z**3/(3.*A1*A2) F(4)=0. F(5)=2.*Z**5/(5.*A1*A2) F(6)=0. F(7)=2.*Z**7/(7.*A1*A2) RETURN ENDIF C C SPECIAL CASE: X**N/(A+BX) IF(B1.EQ.0..OR.B2.EQ.0.) THEN IF(B1.EQ.0.) THEN A=A2/B2 C=1./(A1*B2) ELSE A=A1/B1 C=1./(A2*B1) ENDIF F(1)=LOG((A+Z)/(A-Z)) F(1)=F(1)*C F(2)=-A*LOG((A+Z)/(A-Z))+2.*Z F(2)=F(2)*C F(3)=A**2*LOG((A+Z)/(A-Z))-2.*A*Z F(3)=F(3)*C F(4)=-A**3*LOG((A+Z)/(A-Z))+2.*A**2*Z+2.*Z**3/3. F(4)=F(4)*C F(5)=A**4*LOG((A+Z)/(A-Z))-2.*A**3*Z-2.*A*Z**3/3. F(5)=F(5)*C F(6)=-A**5*LOG((A+Z)/(A-Z))+2.*A**4*Z+2.*A**2*Z**3/3.+2.*Z**5/5. F(6)=F(6)*C F(7)=A**6*LOG((A+Z)/(A-Z))-2.*A**5*Z-2.*A**3*Z**3/3. $ -2.*A*Z**5/5. F(7)=F(7)*C RETURN ENDIF C C B1 AND B2 NONZERO A1=A1/B1 A2=A2/B2 C=1./(B1*B2) C C SPECIAL CASE: X**N/(A+B*X)**2 IF(A1.EQ.A2) THEN A=A1 F(1)=2.*Z/(A**2-Z**2) F(1)=F(1)*C F(2)=-2.*A*Z/(A**2-Z**2)+LOG((A+Z)/(A-Z)) F(2)=F(2)*C F(3)=(4.*A**2*Z-2.*Z**3)/(A**2-Z**2)-2.*A*LOG((A+Z)/(A-Z)) F(3)=F(3)*C F(4)=(4.*A*Z**3-6.*A**3*Z)/(A**2-Z**2)+3.*A**2*LOG((A+Z)/(A-Z)) F(4)=F(4)*C F(5)=(-16.*A**2*Z**3/3.+8.*A**4*Z-2.*Z**5/3.)/(A**2-Z**2) $ -4.*A**3*LOG((A+Z)/(A-Z)) F(5)=F(5)*C F(6)=(4.*A*Z**5/3.+20.*A**3*Z**3/3.-10.*A**5*Z)/(A**2-Z**2) $ +5*A**4*LOG((A+Z)/(A-Z)) F(6)=F(6)*C F(7)=(-8.*A**2*Z**5/5.-8.*A**4*Z**3+12.*A**6*Z-2.*Z**7/5.) $ /(A**2-Z**2)-6.*A**5*LOG((A+Z)/(A-Z)) F(7)=F(7)*C RETURN ENDIF C C GENERAL CASE F(1)=(-LOG((A1+Z)/(A1-Z))+LOG((A2+Z)/(A2-Z)))/(A1-A2) F(1)=F(1)*C F(2)=(A1*LOG((A1+Z)/(A1-Z))-A2*LOG((A2+Z)/(A2-Z)))/(A1-A2) F(2)=F(2)*C F(3)=(-A1**2*LOG((A1+Z)/(A1-Z))+A2**2*LOG((A2+Z)/(A2-Z)))/(A1-A2) $+2.*Z F(3)=F(3)*C F(4)=(A1**3*LOG((A1+Z)/(A1-Z))-A2**3*LOG((A2+Z)/(A2-Z)))/(A1-A2) $+2.*Z*(-A1-A2) F(4)=F(4)*C F(5)=(-A1**4*LOG((A1+Z)/(A1-Z))+A2**4*LOG((A2+Z)/(A2-Z)))/(A1-A2) $+2.*Z*(A1*A2+A1**2+A2**2)+2.*Z**3/3. F(5)=F(5)*C F(6)=(A1**5*LOG((A1+Z)/(A1-Z))-A2**5*LOG((A2+Z)/(A2-Z)))/(A1-A2) $+2.*Z*(-A1*A2**2-A1**2*A2-A1**3-A2**3)+2.*Z**3/3.*(-A1-A2) F(6)=F(6)*C F(7)=(-A1**6*LOG((A1+Z)/(A1-Z))+A2**6*LOG((A2+Z)/(A2-Z)))/(A1-A2) $+2.*Z*(A1*A2**3+A1**2*A2**2+A1**3*A2+A1**4+A2**4) $+2.*Z**3/3.*(A1*A2+A1**2+A2**2)+2.*Z**5/5. F(7)=F(7)*C RETURN END +EOD +DECK,SIGKKG SUBROUTINE SIGKKG C C Compute the KK graviton direct production cross-section C d(sigma)/d(m**2)d(pT**2)d(y3)d(y4) C X-sections: G.F.Giudice et al. hep-ph/9811291 C Kinematics: sigdy.car (Drell-Yan + jet) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,NODCAY +CDE,KKGRAV C REAL X(2) REAL Z,S,T,U,QMW2,QZW,EHAT,Q2SAVE,YHAT,EY,P3Z,P1,P2,AMASS,ANEFF, $SIG0,DENOM,QT2CUT,SIGT,SIGU,FAC,PROP,FACTOR,SIG,AMT,AMT2,SWT, $P1WT,P2WT,X1WT,X2WT,TWT,UWT,Q2,QFCN,STRUC,XX,ACOSH,ATANH,P2M,P1M REAL AMI2,AMF2,EFWT REAL AJLWT,AJLZT1,AJLZT2,A2,A2B2,QQ,TM2 INTEGER I,IQ,IH,IQ1,IFL,IQ2,IW,IQ3 INTEGER NZERO(4) REAL AMFAC(13) INTEGER NUTYP(25) INTEGER IFL1,IFL2 REAL TERM REAL KKGF1,KKGF2,KKGF3,SIG1,SIG2,XG,YG,F1,F2T,F2U,F3 EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) C Electric charge: REAL CHARGE EXTERNAL CHARGE C C Kinematics: (Drell-Yan plus jet) C QMW2=QMW**2 QTMW=SQRT(QMW2+QTW**2) Q0W=QTMW*COSH(YW) QZW=QTMW*SINH(YW) QW=SQRT(QZW**2+QTW**2) C Protect against errors IF(QW.NE.0.) THEN CTHW=QZW/QW STHW=QTW/QW IF(ABS(CTHW).LT.1.) THEN THW=ACOS(CTHW) ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF c Drell-Yan plus jet P3Z=P(3)*CTH(3) SHAT=QMW2+2.*Q0W*P(3)-2.*QZW*P3Z+2.*PT(3)**2 P1=.5*(P(3)+P3Z+Q0W+QZW) P2=.5*(P(3)-P3Z+Q0W-QZW) X1=P1/HALFE X2=P2/HALFE THAT=-2.*P1*(P(3)-P3Z) UHAT=-2.*P2*(P(3)+P3Z) QSQ=QTW**2 QSQ=AMAX1(QSQ,4.) ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2)) Q2SAVE=QSQ QSQ=SHAT C C Initialize C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS SIGS(I)=0. 100 CONTINUE IF(X1.GE.1..OR.X2.GE.1.) RETURN C C Structure functions C DO 110 IH=1,2 DO 120 IQ=1,11 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) 120 CONTINUE QSAVE(12,IH)=0 QSAVE(13,IH)=0 110 CONTINUE QSQ=Q2SAVE C IF((THAT/SHAT).EQ.0.) RETURN IF(ABS(THAT/SHAT+1).LT.1.E-06) RETURN F1=KKGF1(SHAT,THAT,QMW2) F2T=KKGF2(SHAT,THAT,QMW2) F2U=KKGF2(SHAT,UHAT,QMW2) F3=KKGF3(SHAT,THAT,QMW2) IF(F1.LE.0.OR.F2T.LE.0.OR.F2U.LE.0.OR.F3.LE.0) RETURN C SIG0=UNITS*0.5*KKGSD*ALFQSQ*QMW**(NEXTRAD-2)/SCM C C Jet 3 = gamma: C IF(GOQ(26,3)) THEN SIG1=UNITS*0.5*KKGSD*ALFA*QMW**(NEXTRAD-2)/SCM SIG1=SIG1*F1/48.0 C qk + qb --> gamma + KKG DO 410 IFL=1,5 IQ1=2*IFL IQ2=IQ1+1 SIG2=SIG1*ABS(CHARGE(IFL)) SIG=SIG2*QSAVE(IQ1,1)*QSAVE(IQ2,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,IQ1,IQ2,5,26) SIG=SIG2*QSAVE(IQ2,1)*QSAVE(IQ1,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,IQ2,IQ1,5,26) 410 CONTINUE ENDIF C C Jet 3 = gluon: C IF(GOQ(1,3)) THEN SIG1=SIG0*F1/36.0 C qk + qb --> gl + KKG DO 210 IFL=1,5 IQ1=2*IFL IQ2=IQ1+1 SIG=SIG1*QSAVE(IQ1,1)*QSAVE(IQ2,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,IQ1,IQ2,5,1) SIG=SIG1*QSAVE(IQ2,1)*QSAVE(IQ1,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,IQ1,IQ1,5,1) 210 CONTINUE C gl + gl --> gl + KKG SIG1=SIG0*F3*3.0/16.0 SIG=SIG1*QSAVE(1,1)*QSAVE(1,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,1,1,5,1) ENDIF C C Jet 3 = quark: C SIGT=SIG0*F2T/96.0 SIGU=SIG0*F2U/96.0 C qk + gl --> qk + KKG DO 310 IQ1=2,11 IQ3=IQ1 IF(GOQ(IQ3,3)) THEN SIG=SIGU*QSAVE(IQ1,1)*QSAVE(1,2) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,IQ1,1,5,IQ3) SIG=SIGT*QSAVE(IQ1,2)*QSAVE(1,1) IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2 CALL SIGFIL(SIG,1,IQ1,5,IQ3) ENDIF 310 CONTINUE C RETURN END +EOD +DECK,SIGQCD. SUBROUTINE SIGQCD C C Compute D(SIGMA)/D(PT**2)D(Y1)D(Y2) C Include quark masses for ch, bt, and tp and 4th generation. C Note ch is now treated as heavy. C C SIGMA = cross section summed over quark types allowed by C JETTYPE card. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C C Cross sections from Feynman, Field and Fox, P.R. D18, 3320 C Massive cross sections from B. Combridge, N.P. B151, 429. C Extra factor of 1/2 needed for non-identical jets since all C all jets are treated as identical. C C Ver 6.35: Fix kinematics for gl + tp -> gl + tp, etc. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,CONST C REAL X(2),QSAVE(13,2),EBT(2) EQUIVALENCE (X(1),X1),(S,SHAT),(T,THAT),(U,UHAT) REAL FFF1,FFF2,FFF3,FFF4,FFF5,FFF6,FFF7,S,T,U,FGQ,AM2,FQQ, $ QFCN,STRUC,FJAC,SIG,AMASS,SIG1,AMQ,FJACBT,SIG2,QQ,XQMIN, $ E1,E2 INTEGER IQ,IH,I,J,IFL,JTYP1,JTYP2,IQ1,IQ2 C C Elementary cross sections from Feynman, Field, and Fox. C FFF1(S,T,U)=4./9.*(S**2+U**2)/T**2 FFF2(S,T,U)=4./9.*((S**2+U**2)/T**2+(S**2+T**2)/U**2) 1-8./27.*S**2/(U*T) FFF3(S,T,U)=4./9.*((S**2+U**2)/T**2+(T**2+U**2)/S**2) 1-8./27.*U**2/(S*T) FFF4(S,T,U)=32./27.*(U**2+T**2)/(U*T)-8./3.*(U**2+T**2)/S**2 FFF5(S,T,U)=1./6.*(U**2+T**2)/(U*T)-3./8.*(U**2+T**2)/S**2 FFF6(S,T,U)=-4./9.*(U**2+S**2)/(U*S)+(U**2+S**2)/T**2 FFF7(S,T,U)=9./2.*(3.-U*T/S**2-U*S/T**2-S*T/U**2) C Heavy quark cross sections from Combridge FGQ(S,T,U)=2.*(S-AM2)*(AM2-U)/T**2 1+4./9.*((S-AM2)*(AM2-U)+2.*AM2*(S+AM2))/(S-AM2)**2 2+4./9.*((S-AM2)*(AM2-U)+2.*AM2*(AM2+U))/(AM2-U)**2 3+1./9.*AM2*(4.*AM2-T)/((S-AM2)*(AM2-U)) 4+((S-AM2)*(AM2-U)+AM2*(S-U))/(T*(S-AM2)) 5-((S-AM2)*(AM2-U)-AM2*(S-U))/(T*(AM2-U)) FQQ(S,T,U)=4./9.*((AM2-U)**2+(S-AM2)**2+2.*AM2*T)/T**2 QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C C Use massless kinematics for ch and lighter quarks. C CALL TWOKIN(0.,0.,0.,0.) FJAC=SHAT/SCM*UNITS FJAC=FJAC*PI*ALFQSQ**2/SHAT**2 C C Initialize cross sections. C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS SIGS(I)=0. 100 CONTINUE IF(X1.GE.1.0.OR.X2.GE.1.0) RETURN C Compute structure functions DO 110 IH=1,2 DO 110 IQ=1,7 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) 110 CONTINUE C C Compute cross sections summed over quark types allowed by C JETTYPE card. C C Gluon-gluon IF(.NOT.(GOQ(1,1).AND.GOQ(1,2))) GO TO 210 SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF7(S,T,U) CALL SIGFIL(SIG,1,1,1,1) C DO 201 I=1,3 SIG=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF4(S,T,U) CALL SIGFIL(SIG,2*I,2*I+1,1,1) SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF4(S,U,T) CALL SIGFIL(SIG,2*I+1,2*I,1,1) 201 CONTINUE C C Quark-gluon 210 CONTINUE DO 211 I=2,7 IF(.NOT.(GOQ(I,1).AND.GOQ(1,2))) GO TO 212 SIG=.5*FJAC*QSAVE(I,1)*QSAVE(1,2)*FFF6(S,T,U) CALL SIGFIL(SIG,I,1,I,1) SIG=.5*FJAC*QSAVE(1,1)*QSAVE(I,2)*FFF6(S,U,T) CALL SIGFIL(SIG,1,I,I,1) 212 CONTINUE IF(.NOT.(GOQ(1,1).AND.GOQ(I,2))) GO TO 211 SIG=.5*FJAC*QSAVE(1,1)*QSAVE(I,2)*FFF6(S,T,U) CALL SIGFIL(SIG,1,I,1,I) SIG=.5*FJAC*QSAVE(I,1)*QSAVE(1,2)*FFF6(S,U,T) CALL SIGFIL(SIG,I,1,1,I) 211 CONTINUE C C Identical quark-quark DO 220 I=2,7 IF(.NOT.(GOQ(I,1).AND.GOQ(I,2))) GO TO 220 SIG=.5*FJAC*QSAVE(I,1)*QSAVE(I,2)*FFF2(S,T,U) CALL SIGFIL(SIG,I,I,I,I) 220 CONTINUE C C Identical quark-antiquark DO 230 I=1,3 IF(SHAT.LT.4.*AMASS(I)**2) GO TO 230 IF(.NOT.(GOQ(2*I,1).AND.GOQ(2*I+1,2))) GO TO 235 SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF5(S,T,U) CALL SIGFIL(SIG,1,1,2*I,2*I+1) DO 231 J=1,3 IF(J.EQ.I) GO TO 231 SIG=.5*FJAC*QSAVE(2*J,1)*QSAVE(2*J+1,2)*FFF1(T,S,U) CALL SIGFIL(SIG,2*J,2*J+1,2*I,2*I+1) SIG=.5*FJAC*QSAVE(2*J+1,1)*QSAVE(2*J,2)*FFF1(T,S,U) CALL SIGFIL(SIG,2*J+1,2*J,2*I,2*I+1) 231 CONTINUE SIG=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF3(S,T,U) CALL SIGFIL(SIG,2*I,2*I+1,2*I,2*I+1) SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF3(S,U,T) CALL SIGFIL(SIG,2*I+1,2*I,2*I,2*I+1) C 235 CONTINUE IF(.NOT.(GOQ(2*I+1,1).AND.GOQ(2*I,2))) GO TO 230 SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF5(S,T,U) CALL SIGFIL(SIG,1,1,2*I+1,2*I) DO 236 J=1,3 IF(J.EQ.I) GO TO 236 SIG=.5*FJAC*QSAVE(2*J,1)*QSAVE(2*J+1,2)*FFF1(T,S,U) CALL SIGFIL(SIG,2*J,2*J+1,2*I+1,2*I) SIG=.5*FJAC*QSAVE(2*J+1,1)*QSAVE(2*J,2)*FFF1(T,S,U) CALL SIGFIL(SIG,2*J+1,2*J,2*I+1,2*I) 236 CONTINUE SIG1=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF3(S,U,T) CALL SIGFIL(SIG1,2*I,2*I+1,2*I+1,2*I) SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF3(S,T,U) CALL SIGFIL(SIG,2*I+1,2*I,2*I+1,2*I) 230 CONTINUE C C General massless quark-quark DO 240 I=2,7 DO 241 J=2,7 IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 241 IF((I/2).EQ.(J/2)) GO TO 241 SIG=.5*FJAC*QSAVE(I,1)*QSAVE(J,2)*FFF1(S,T,U) CALL SIGFIL(SIG,I,J,I,J) SIG=.5*FJAC*QSAVE(J,1)*QSAVE(I,2)*FFF1(S,U,T) CALL SIGFIL(SIG,I,J,J,I) 241 CONTINUE 240 CONTINUE C C CH+CB, BT+BB, and TP+TB cross sections. C Y=-log(tan(theta/2)), so Jacobean contains P1*P2/E1*E2. C Also fourth generation. C DO 250 IQ=1,5 IFL=IQ+3 JTYP1=2*IFL JTYP2=JTYP1+1 IF(.NOT.((GOQ(JTYP1,1).AND.GOQ(JTYP2,2)).OR. 1 (GOQ(JTYP2,1).AND.GOQ(JTYP1,2)))) GO TO 250 AMQ=AMASS(IFL) IF(AMQ.LT.0.) GO TO 250 AM2=AMQ**2 CALL TWOKIN(0.,0.,AMQ,AMQ) IF(X(1).GE.1..OR.X(2).GE.1.) GO TO 250 EBT(1)=SQRT(P(1)**2+AM2) EBT(2)=SQRT(P(2)**2+AM2) FJACBT=.5*S/SCM*UNITS*P(1)*P(2)/(EBT(1)*EBT(2)) SIG1=12.*(AM2-T)*(AM2-U)/S**2 1 +8./3.*((AM2-T)*(AM2-U)-2.*AM2*(AM2+T))/(AM2-T)**2 2 +8./3.*((AM2-T)*(AM2-U)-2.*AM2*(AM2+U))/(AM2-U)**2 3 -2./3.*AM2*(S-4.*AM2)/((AM2-T)*(AM2-U)) 4 -6.*((AM2-T)*(AM2-U)+AM2*(U-T))/(S*(AM2-T)) 5 -6.*((AM2-T)*(AM2-U)+AM2*(T-U))/(S*(AM2-U)) SIG1=SIG1*PI**2*ALFQSQ**2/(16.*PI*S**2) SIG=FJACBT*SIG1*STRUC(X(1),QSQ,1,IDIN(1))/X(1) 1 *STRUC(X(2),QSQ,1,IDIN(2))/X(2) IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2)) $ CALL SIGFIL(SIG,1,1,JTYP1,JTYP2) IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2)) $ CALL SIGFIL(SIG,1,1,JTYP2,JTYP1) C SIG2=((AM2-T)**2+(AM2-U)**2+2.*S*AM2)/S**2 SIG2=FJACBT*SIG2*64.*PI**2*ALFQSQ**2/(9.*16.*PI*S**2) DO 255 I=1,3 QQ=STRUC(X(1),QSQ,2*I,IDIN(1))*STRUC(X(2),QSQ,2*I+1,IDIN(2)) SIG=SIG2*QQ/(X(1)*X(2)) IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2)) $ CALL SIGFIL(SIG,2*I,2*I+1,JTYP1,JTYP2) IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2)) $ CALL SIGFIL(SIG,2*I,2*I+1,JTYP2,JTYP1) QQ=STRUC(X(1),QSQ,2*I+1,IDIN(1))*STRUC(X(2),QSQ,2*I,IDIN(2)) SIG=SIG2*QQ/(X(1)*X(2)) IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2)) $ CALL SIGFIL(SIG,2*I+1,2*I,JTYP1,JTYP2) IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2)) $ CALL SIGFIL(SIG,2*I+1,2*I,JTYP2,JTYP1) 255 CONTINUE 250 CONTINUE C C Gluon + heavy quark DO 300 IQ=8,13 IF(.NOT.(GOQ(1,1).AND.GOQ(IQ,2))) GO TO 310 AMQ=AMASS(IQ/2) AM2=AMQ**2 XQMIN=AMQ/ECM E1=P(1) E2=SQRT(P(2)**2+AM2) FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2 CALL TWOKIN(0.,AMQ,0.,AMQ) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,T,U)*QFCN(1,1)*QFCN(IQ,2) CALL SIGFIL(SIG,1,IQ,1,IQ) ENDIF CALL TWOKIN(AMQ,0.,0.,AMQ) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,U,T)*QFCN(IQ,1)*QFCN(1,2) CALL SIGFIL(SIG,IQ,1,1,IQ) ENDIF C 310 IF(.NOT.(GOQ(IQ,1).AND.GOQ(1,2))) GO TO 300 AMQ=AMASS(IQ/2) AM2=AMQ**2 XQMIN=AMQ/ECM E1=SQRT(P(1)**2+AM2) E2=P(2) FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2 CALL TWOKIN(0.,AMQ,AMQ,0.) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,U,T)*QFCN(1,1)*QFCN(IQ,2) CALL SIGFIL(SIG,1,IQ,IQ,1) ENDIF CALL TWOKIN(AMQ,0.,AMQ,0.) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,T,U)*QFCN(IQ,1)*QFCN(1,2) CALL SIGFIL(SIG,IQ,1,IQ,1) ENDIF 300 CONTINUE C C Light quark + heavy quark DO 320 IQ1=2,7 DO 330 IQ2=8,13 IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 340 AMQ=AMASS(IQ2/2) AM2=AMQ**2 XQMIN=AMQ/ECM E1=P(1) E2=SQRT(P(2)**2+AM2) FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2 CALL TWOKIN(0.,AMQ,0.,AMQ) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,T,U)*QFCN(IQ1,1) $ *QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ1,IQ2) ENDIF CALL TWOKIN(AMQ,0.,0.,AMQ) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,U,T)*QFCN(IQ1,2) $ *QFCN(IQ2,1) CALL SIGFIL(SIG,IQ2,IQ1,IQ1,IQ2) ENDIF C 340 IF(.NOT.(GOQ(IQ1,2).AND.GOQ(IQ2,1))) GO TO 330 AMQ=AMASS(IQ2/2) AM2=AMQ**2 XQMIN=AMQ/ECM E1=SQRT(P(1)**2+AM2) E2=P(2) FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2 CALL TWOKIN(0.,AMQ,AMQ,0.) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,U,T)*QFCN(IQ1,1) $ *QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ2,IQ1) ENDIF CALL TWOKIN(AMQ,0.,AMQ,0.) IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,T,U)*QFCN(IQ1,2) $ *QFCN(IQ2,1) CALL SIGFIL(SIG,IQ2,IQ1,IQ2,IQ1) ENDIF 330 CONTINUE 320 CONTINUE C RETURN END +EOD +DECK,SIGSSE. SUBROUTINE SIGSSE C C Compute d(sigma)/d(cos theta) for C e+ e- ----> SUSY particles C See Baer et. al., IJMP A4, 4111 (1989) for sigma's C Polarized cross sections added 9/18/95 hb C Mixed sbottoms and staus included 10/23/96 hb C C SIGMA = cross section summed over quark types allowed by C JETTYPE and WTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C C Extra factor of 1/2 needed because all jets are treated C as identical. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,JETSIG +CDE,EEPAR +CDE,PRIMAR +CDE,JETPAR +CDE,Q1Q2 +CDE,WCON +CDE,CONST +CDE,SSPAR +CDE,SSSM +CDE,SSTYPE +CDE,BREMBM C REAL ALQ(2),BEQ(2),E,CS2THW,TNTHW,CTTHW,AE,BE,AM1,AM2, $EQ,ALR,Z,PHIZ,PROPZ,SIG,PCM,AMASS,ALL(2),BEL(2), $G,MSNE,TM2,TM3,TM4,TM5,TM6,AZJ,AZI,MEL,MER, $AEZS,BEZS,SR2,GP,AN,BN,AEZJS,BEZJS,SSXLAM, $TGG,TNN,TGN,TZN,AMWI,XS,YS,XC,YC,SINGL,SINGR, $COSGL,COSGR,XM,YM,THX,THY,XI,DEL,AMWISS(2),KK, $AMZIZ1,AMZIZ2,SIGLL,SIGRR,SIGLZ,SIGRZ,SSGT,SSGST, $FAC1,EZ0,BETA,EEL,EER, $FLEP,FLEM,FREP,FREM,SIGLR,SIGRL,PHIZLR,PHIZRL, $TM1LR,TM1RL,TZZRL,TZZLR,TGZLR,TGZRL,SIGZZL,SIGZZR, $FACLR,FACRL,RSH,JAC,ESTRUC,SH,SSFEL COMPLEX AEZ(4),BEZ(4),ZI,ZONE,WIJ INTEGER IS2UD(25),IUD(13),JS2JT(25),IQ1,IQ2,IFL1,IFL2, $IFLQ,IFM,I,IDQSS(25),MATCHL(18),IL2JS(18),IS2LN(18), $I1,I2,IL1,IL2,IDL1,IDL2,IZ,IZ1,IP,ITHZ(4),IDLSS(18), $IW2JS(4),IW1,JW1,JTW1,JTW2,IZ2JS(4), $IZ2,JTYPZ1,JTYPZ2 INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) DATA IDQSS/0, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2/ DATA IDLSS/ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL, $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR, $ISTAU2,MSTAU2/ DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/ DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/ DATA JS2JT/1, $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/ DATA MATCHL/2,1,4,3,6,5,8,7,10,9,12,11,14,13,16,15,18,17/ DATA IL2JS/34,35,36,37,38,39,40,41,42,43,44,45,46,47, $48,49,50,51/ DATA IS2LN/1,1,2,2,1,1,2,2,1,1,2,2,2,2,2,2,2,2/ DATA IW2JS/26,27,28,29/ DATA IZ2JS/30,31,32,33/ DATA ZONE,ZI/(1.,0.),(0.,1.)/ C C FUNCTIONS IF (IBREM) THEN SH=SHAT JAC=2*(1.-SHAT/SCM)*2*SQRT(SHAT)*(RSHMAX-RSHMIN)/SCM/(X1+X2) ELSE SH=SCM END IF PROPZ=(SH-AMZ**2)**2+AMZ**2*GAMZ**2 C C CONSTANTS RSH=SQRT(SH) EB=RSH/2. QSQBM=QSQ E=SQRT(4*PI*ALFAEM) G=SQRT(4*PI*ALFAEM/SN2THW) GP=G*SQRT(SN2THW/(1.-SN2THW)) BETA=ATAN(1./RV2V1) SR2=SQRT(2.) CS2THW=1.-SN2THW TNTHW=SQRT(SN2THW/CS2THW) CTTHW=1./TNTHW ALQ(1)=CTTHW/4.-5*TNTHW/12. BEQ(1)=-(CTTHW+TNTHW)/4. ALQ(2)=TNTHW/12.-CTTHW/4. BEQ(2)=-BEQ(1) ALL(1)=(CTTHW+TNTHW)/4. BEL(1)=-(CTTHW+TNTHW)/4. ALL(2)=(3*TNTHW-CTTHW)/4. BEL(2)=-BEL(1) AE=ALL(2) BE=BEL(2) AN=ALL(1) BN=BEL(1) FLEP=(1.+PLEP)/2. FLEM=(1.+PLEM)/2. FREP=(1.-PLEP)/2. FREM=(1.-PLEM)/2. MEL=AMASS(ISEL) MER=AMASS(ISER) MSNE=AMASS(ISNEL) XM=1./TAN(GAMMAL) YM=1./TAN(GAMMAR) THX=SIGN(1.,XM) THY=SIGN(1.,YM) AMWISS(1)=ABS(AMW1SS) AMWISS(2)=ABS(AMW2SS) DO 5 IZ=1,4 ITHZ(IZ)=0 IF (AMZISS(IZ).LT.0.) ITHZ(IZ)=1 AEZ(IZ)=-1*ZI**(ITHZ(IZ)-1)*(-1)**(ITHZ(IZ)+1)* $ (G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2 BEZ(IZ)=-1*ZI**(ITHZ(IZ)-1)*SR2*GP*ZMIXSS(4,IZ) 5 CONTINUE C C ENTRY SIG=0. SIGMA=0. NSIGS=0 DO 10 I=1,MXSIGS SIGS(I)=0. 10 CONTINUE C C First do squark pairs: IQ1 labels JETTYPE1. C DO 100 IQ1=2,25 IQ2=MATCH(IQ1,4) IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 100 IFL1=IDQSS(IQ1) IFL2=IDQSS(IQ2) AM1=AMASS(IFL1) AM2=AMASS(IFL2) IF((AM1+AM2).GE.RSH) GO TO 100 IFLQ=IS2UD(IQ1) IF (IFLQ.EQ.1) THEN EQ=2./3. ELSE EQ=-1./3. END IF C Left squarks IF(IQ1.LE.9) THEN ALR=2*(ALQ(IFLQ)-BEQ(IFLQ)) C Right squarks ELSEIF(IQ1.GE.14.AND.IQ1.LE.21) THEN ALR=2*(ALQ(IFLQ)+BEQ(IFLQ)) C Mixed stops and sbottoms ELSEIF(IQ1.EQ.10.OR.IQ1.EQ.11) THEN ALR=2*(ALQ(IFLQ)-BEQ(IFLQ)*COS(2*THETAB)) ELSEIF(IQ1.EQ.12.OR.IQ1.EQ.13) THEN ALR=2*(ALQ(IFLQ)-BEQ(IFLQ)*COS(2*THETAT)) ELSEIF(IQ1.EQ.22.OR.IQ1.EQ.23) THEN ALR=2*(ALQ(IFLQ)+BEQ(IFLQ)*COS(2*THETAB)) ELSEIF(IQ1.EQ.24.OR.IQ1.EQ.25) THEN ALR=2*(ALQ(IFLQ)+BEQ(IFLQ)*COS(2*THETAT)) END IF PCM=.5*SQRT(SH-4.*AM1**2) IFM=ISIGN(1,IUD(JS2JT(IQ1))) IF (IFM.GT.0) THEN Z=CTH(1) ELSE Z=-CTH(1) END IF C Calculate d(sigma)/d(cos theta) in mb PHIZLR=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2* $ SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) PHIZRL=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2* $ SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) SIGLR=3*PCM**3/512./PI/EB**3*PHIZLR SIGRL=3*PCM**3/512./PI/EB**3*PHIZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,IQ1,IQ2) 100 CONTINUE C Mixed sbottom_1 and sbottom_2 production IF ((AMB1SS+AMB2SS).LT.RSH) THEN Z=CTH(1) PCM=SQRT(SSXLAM(SH,AMB1SS**2,AMB2SS**2))/2./RSH SIGLR=2*3*8*PI*ALFAEM**2*BEQ(2)**2*COS(THETAB)**2* $ SIN(THETAB)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIGRL=2*3*8*PI*ALFAEM**2*BEQ(2)**2*COS(THETAB)**2* $ SIN(THETAB)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(10,1).AND.GOQ(23,2)) THEN CALL SIGFIL(SIG,0,0,10,23) END IF IF(GOQ(23,1).AND.GOQ(10,2)) THEN CALL SIGFIL(SIG,0,0,23,10) END IF IF(GOQ(11,1).AND.GOQ(22,2)) THEN CALL SIGFIL(SIG,0,0,11,22) END IF IF(GOQ(22,1).AND.GOQ(11,2)) THEN CALL SIGFIL(SIG,0,0,22,11) END IF ENDIF C Mixed stop_1 and stop_2 production IF ((AMT1SS+AMT2SS).LT.RSH) THEN Z=CTH(1) PCM=SQRT(SSXLAM(SH,AMT1SS**2,AMT2SS**2))/2./RSH SIGLR=2*3*8*PI*ALFAEM**2*BEQ(1)**2*COS(THETAT)**2* $ SIN(THETAT)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIGRL=2*3*8*PI*ALFAEM**2*BEQ(1)**2*COS(THETAT)**2* $ SIN(THETAT)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(12,1).AND.GOQ(25,2)) THEN CALL SIGFIL(SIG,0,0,12,25) END IF IF(GOQ(25,1).AND.GOQ(12,2)) THEN CALL SIGFIL(SIG,0,0,25,12) END IF IF(GOQ(13,1).AND.GOQ(24,2)) THEN CALL SIGFIL(SIG,0,0,13,24) END IF IF(GOQ(24,1).AND.GOQ(13,2)) THEN CALL SIGFIL(SIG,0,0,24,13) END IF ENDIF C C 2nd and 3rd generation sleptons: IL1 labels JETTYPE1. C DO 200 I=5,16 I1=I IF (I1.GE.13) I1=I1+2 I2=MATCHL(I1) IL1=IL2JS(I1) IL2=IL2JS(I2) IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 200 IDL1=IDLSS(I1) IDL2=IDLSS(I2) AM1=AMASS(IDL1) AM2=AMASS(IDL2) IF((AM1+AM2).GE.RSH) GO TO 200 IFL1=IS2LN(I1) IFL2=IS2LN(I2) IF (IFL1.EQ.1) THEN EQ=0. ELSE EQ=-1. END IF IF (I1.EQ.15.OR.I1.EQ.16) THEN ALR=2*(ALL(IFL1)+BEL(IFL1)) ELSE IF (I1.GE.5.AND.I1.LE.10) THEN ALR=2*(ALL(IFL1)-BEL(IFL1)) ELSE IF (I1.EQ.11.OR.I1.EQ.12) THEN ALR=2*(ALL(IFL1)-BEL(IFL1)*COS(2*THETAL)) ELSE IF (I1.EQ.17.OR.I1.EQ.18) THEN ALR=2*(ALL(IFL1)+BEL(IFL1)*COS(2*THETAL)) END IF PCM=.5*SQRT(SH-4.*AM1**2) IFM=ISIGN(1,IDL1) IF (IFM.GT.0) THEN Z=CTH(1) ELSE Z=-CTH(1) END IF C Calculate d(sigma)/d(cos theta) in mb PHIZLR=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2* $ SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) PHIZRL=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2* $ SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) SIGLR=PCM**3/512./PI/EB**3*PHIZLR SIGRL=PCM**3/512./PI/EB**3*PHIZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,IL1,IL2) 200 CONTINUE C Mixed stau_1 and stau_2 production IF ((AML1SS+AML2SS).LT.RSH) THEN Z=CTH(1) PCM=SQRT(SSXLAM(SH,AML1SS**2,AML2SS**2))/2./RSH SIGLR=2*8*PI*ALFAEM**2*BEL(2)**2*COS(THETAL)**2* $ SIN(THETAL)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIGRL=2*8*PI*ALFAEM**2*BEL(2)**2*COS(THETAL)**2* $ SIN(THETAL)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(44,1).AND.GOQ(51,2)) THEN CALL SIGFIL(SIG,0,0,44,51) END IF IF(GOQ(51,1).AND.GOQ(44,2)) THEN CALL SIGFIL(SIG,0,0,51,44) END IF IF(GOQ(45,1).AND.GOQ(50,2)) THEN CALL SIGFIL(SIG,0,0,45,50) END IF IF(GOQ(50,1).AND.GOQ(45,2)) THEN CALL SIGFIL(SIG,0,0,50,45) END IF ENDIF C C Next do 1st generation sleptons C C Sneutrino_e pairs DO 210 I1=1,2 I2=MATCHL(I1) IL1=IL2JS(I1) IL2=IL2JS(I2) IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 210 MSNE=AMASS(ISNEL) IF((2*MSNE).GE.RSH) GO TO 210 IF (I1.EQ.1) THEN Z=CTH(1) ELSE Z=-CTH(1) END IF PCM=.5*SQRT(SH-4*MSNE**2) TM1LR=32*E**4*(AN-BN)**2*(AE-BE)**2/PROPZ TM1RL=32*E**4*(AN-BN)**2*(AE+BE)**2/PROPZ TM2=8*G**4*SIN(GAMMAR)**4/(2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2)**2 TM3=8*G**4*COS(GAMMAR)**4/(2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2)**2 TM4=-32*E**2*(AN-BN)*G**2*SIN(GAMMAR)**2*(SH-AMZ**2)*(AE-BE)/ $ PROPZ/(2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2) TM5=-32*E**2*(AN-BN)*G**2*COS(GAMMAR)**2*(SH-AMZ**2)*(AE-BE)/ $ PROPZ/(2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2) TM6=16*G**4*SIN(GAMMAR)**2*COS(GAMMAR)**2/ $ (2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2)/ $ (2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2) SIGLR=2*PCM**3*EB*(1.-Z**2)/128./PI/SH* $ (TM1LR+TM2+TM3+TM4+TM5+TM6) SIGRL=2*PCM**3*EB*(1.-Z**2)/128./PI/SH*TM1RL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,IL1,IL2) 210 CONTINUE C E_L~ pairs DO 220 I1=3,4 I2=MATCHL(I1) IL1=IL2JS(I1) IL2=IL2JS(I2) IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 220 IF(2*MEL.GE.RSH) GO TO 220 PCM=.5*SQRT(SH-4.*MEL**2) EQ=-1. ALR=2*(AE-BE) IF (I1.EQ.3) THEN Z=CTH(1) ELSE Z=-CTH(1) END IF PHIZLR=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2* $ SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) PHIZRL=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2* $ SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) DO 221 IZ1=1,4 AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1)) PHIZLR=PHIZLR+2*AEZS**2*SH*(1.-Z**2)/(2*EB*(EB-PCM*Z)- $ MEL**2+AMZISS(IZ1)**2)**2-4*E**2*(1.-Z**2)*AEZS/ $ (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IZ1)**2)*(2.+(AE-BE)*ALR* $ SH*(SH-AMZ**2)/PROPZ) IF (IZ1.LE.3) THEN DO 222 IP=IZ1+1,4 AEZJS=AEZ(IP)*CONJG(AEZ(IP)) PHIZLR=PHIZLR+4*AEZS*AEZJS*SH*(1.-Z**2)/ $ (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IZ1)**2)/ $ (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IP)**2) 222 CONTINUE END IF 221 CONTINUE SIGLR=2*PCM**3/512./PI/EB**3*PHIZLR SIGRL=2*PCM**3/512./PI/EB**3*PHIZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,IL1,IL2) 220 CONTINUE C E_R~ pairs DO 230 I1=13,14 I2=MATCHL(I1) IL1=IL2JS(I1) IL2=IL2JS(I2) IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 230 IF(2*MER.GE.RSH) GO TO 230 PCM=.5*SQRT(SH-4.*MER**2) EQ=-1. ALR=2*(AE+BE) IF (I1.EQ.13) THEN Z=CTH(1) ELSE Z=-CTH(1) END IF PHIZLR=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2* $ SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) PHIZRL=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2* $ SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ) DO 231 IZ1=1,4 BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1)) PHIZRL=PHIZRL+2*BEZS**2*SH*(1.-Z**2)/(2*EB*(EB-PCM*Z)- $ MER**2+AMZISS(IZ1)**2)**2-4*E**2*(1.-Z**2)*BEZS/ $ (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IZ1)**2)*(2.+(AE+BE)*ALR* $ SH*(SH-AMZ**2)/PROPZ) IF (IZ1.LE.3) THEN DO 232 IP=IZ1+1,4 BEZJS=BEZ(IP)*CONJG(BEZ(IP)) PHIZRL=PHIZRL+4*BEZS*BEZJS*SH*(1.-Z**2)/ $ (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IZ1)**2)/ $ (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IP)**2) 232 CONTINUE END IF 231 CONTINUE SIGLR=2*PCM**3/512./PI/EB**3*PHIZLR SIGRL=2*PCM**3/512./PI/EB**3*PHIZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,IL1,IL2) 230 CONTINUE C E_L~+E_R~bar and E_R~+E_L~bar pairs; now has MEL =/ MER ! IF((MEL+MER).GE.RSH) GO TO 270 IF(GOQ(36,1).AND.GOQ(47,2)) THEN PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB EEL=SQRT(PCM**2+MEL**2) Z=CTH(1) PHIZ=0. DO 241 IZ1=1,4 BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1)) AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1)) AZI=(AMZISS(IZ1)**2-MEL**2)/2./EB PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EEL-PCM*Z+AZI)**2 IF (IZ1.LE.3) THEN DO 242 IP=IZ1+1,4 AZJ=(AMZISS(IP)**2-MEL**2)/2./EB PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))* $ REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/ $ (EEL-PCM*Z+AZI)/(EEL-PCM*Z+AZJ) 242 CONTINUE END IF 241 CONTINUE SIG=4*PCM/128./PI/SH/EB*PHIZ SIG=FLEM*FLEP*SIG*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,36,47) ENDIF IF(GOQ(46,1).AND.GOQ(37,2)) THEN PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB EER=SQRT(PCM**2+MER**2) Z=CTH(1) PHIZ=0. DO 243 IZ1=1,4 BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1)) AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1)) AZI=(AMZISS(IZ1)**2-MER**2)/2./EB PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EER-PCM*Z+AZI)**2 IF (IZ1.LE.3) THEN DO 244 IP=IZ1+1,4 AZJ=(AMZISS(IP)**2-MER**2)/2./EB PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))* $ REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/ $ (EER-PCM*Z+AZI)/(EER-PCM*Z+AZJ) 244 CONTINUE END IF 243 CONTINUE SIG=4*PCM/128./PI/SH/EB*PHIZ SIG=FREM*FREP*SIG*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,46,37) ENDIF C E_R~bar+E_L~ and E_L~bar+E_R~ pairs; now assumes MEL =/ MER ! IF(GOQ(47,1).AND.GOQ(36,2)) THEN PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB EEL=SQRT(PCM**2+MEL**2) Z=-CTH(1) PHIZ=0. DO 251 IZ1=1,4 BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1)) AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1)) AZI=(AMZISS(IZ1)**2-MEL**2)/2./EB PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EEL-PCM*Z+AZI)**2 IF (IZ1.LE.3) THEN DO 252 IP=IZ1+1,4 AZJ=(AMZISS(IP)**2-MEL**2)/2./EB PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))* $ REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/ $ (EEL-PCM*Z+AZI)/(EEL-PCM*Z+AZJ) 252 CONTINUE END IF 251 CONTINUE SIG=4*PCM/128./PI/SH/EB*PHIZ SIG=FLEM*FLEP*SIG*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,47,36) ENDIF IF(GOQ(37,1).AND.GOQ(46,2)) THEN PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB EER=SQRT(PCM**2+MER**2) Z=-CTH(1) PHIZ=0. DO 253 IZ1=1,4 BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1)) AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1)) AZI=(AMZISS(IZ1)**2-MER**2)/2./EB PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EER-PCM*Z+AZI)**2 IF (IZ1.LE.3) THEN DO 254 IP=IZ1+1,4 AZJ=(AMZISS(IP)**2-MER**2)/2./EB PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))* $ REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/ $ (EER-PCM*Z+AZI)/(EER-PCM*Z+AZJ) 254 CONTINUE END IF 253 CONTINUE SIG=4*PCM/128./PI/SH/EB*PHIZ SIG=FREM*FREP*SIG*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,37,46) ENDIF 270 CONTINUE C C Chargino pair production C DO 300 IW1=1,4 JW1=(IW1+1)/2 AMWI=ABS(AMWISS(JW1)) JTW1=IW2JS(IW1) JTW2=IW2JS(MATCHL(IW1)) IF (.NOT.(GOQ(JTW1,1).AND.GOQ(JTW2,2))) GO TO 300 IF((2*AMWI).GE.RSH) GO TO 300 PCM=SQRT(SSXLAM(SH,AMWI**2,AMWI**2))/4./EB Z=CTH(1) IF (IW1.EQ.1.OR.IW1.EQ.3) Z=-CTH(1) SINGR=SIN(GAMMAR) COSGR=COS(GAMMAR) SINGL=SIN(GAMMAL) COSGL=COS(GAMMAL) XC=1.-(COSGL**2+COSGR**2)/4./CS2THW YC=(COSGR**2-COSGL**2)/4./CS2THW XS=1.-(SINGL**2+SINGR**2)/4./CS2THW YS=(SINGR**2-SINGL**2)/4./CS2THW IF (IW1.GE.3) THEN XC=XS YC=YS SINGR=COSGR END IF TGG=16*E**4/SH*(EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2)) TZZLR=16*E**4*CTTHW**2*SH/PROPZ*((XC**2+YC**2)*(AE-BE)**2* $ (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))- $ 2*YC**2*(AE-BE)**2*AMWI**2+4*XC*YC*(AE-BE)**2*EB*PCM*Z) TZZRL=16*E**4*CTTHW**2*SH/PROPZ*((XC**2+YC**2)*(AE+BE)**2* $ (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))- $ 2*YC**2*(AE+BE)**2*AMWI**2-4*XC*YC*(AE+BE)**2*EB*PCM*Z) TGZLR=-32*E**4*CTTHW*(SH-AMZ**2)/PROPZ*((AE-BE)*XC* $ (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-2*(BE-AE)*YC*EB*PCM*Z) TGZRL=-32*E**4*CTTHW*(SH-AMZ**2)/PROPZ*((AE+BE)*XC* $ (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-2*(BE+AE)*YC*EB*PCM*Z) TNN=2*E**4*SINGR**4*SH*(EB-PCM*Z)**2/SN2THW**2/ $ (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2)**2 TGN=-8*E**4*SINGR**2*((EB-PCM*Z)**2+AMWI**2)/SN2THW/ $ (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2) TZN=8*E**4*CTTHW*SINGR**2*(SH-AMZ**2)*(AE-BE)*SH/ $ SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2+AMWI**2)+2*YC*AMWI**2)/ $ (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2) SIGLR=2*PCM/128./PI/SH/EB*(TGG+TZZLR+TGZLR+TNN+TGN+TZN) SIGRL=2*PCM/128./PI/SH/EB*(TGG+TZZRL+TGZRL) SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,JTW1,JTW2) 300 CONTINUE C C Chargino_1 + chargino_2 pair production IF((ABS(AMW1SS)+ABS(AMW2SS)).GE.RSH) GO TO 340 PCM=SQRT(SSXLAM(SH,AMW1SS**2,AMW2SS**2))/4./EB XC=(THX*SIN(GAMMAL)*COS(GAMMAL)-THY*SIN(GAMMAR)*COS(GAMMAR))/2. YC=(THX*SIN(GAMMAL)*COS(GAMMAL)+THY*SIN(GAMMAR)*COS(GAMMAR))/2. DEL=(AMW2SS**2-AMW1SS**2)/4./EB XI=-1.*SIGN(1.,AMWISS(1))*SIGN(1.,AMWISS(2)) IF (.NOT.(GOQ(27,1).AND.GOQ(28,2))) GO TO 310 Z=CTH(1) TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+ $ 4*XC*YC*(AE-BE)**2*EB*PCM*Z) TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)- $ 4*XC*YC*(AE+BE)**2*EB*PCM*Z) TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/ $ SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2 TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2) $ *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2- $ XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/ $ (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2) SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN) SIGRL=2*E**4*PCM/128./PI/EB*TZZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,27,28) 310 CONTINUE IF (.NOT.(GOQ(28,1).AND.GOQ(27,2))) GO TO 320 Z=-CTH(1) TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+ $ 4*XC*YC*(AE-BE)**2*EB*PCM*Z) TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)- $ 4*XC*YC*(AE+BE)**2*EB*PCM*Z) TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/ $ SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2 TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2) $ *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2- $ XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/ $ (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2) SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN) SIGRL=2*E**4*PCM/128./PI/EB*TZZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,28,27) 320 CONTINUE IF (.NOT.(GOQ(29,1).AND.GOQ(26,2))) GO TO 330 Z=CTH(1) TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+ $ 4*XC*YC*(AE-BE)**2*EB*PCM*Z) TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)- $ 4*XC*YC*(AE+BE)**2*EB*PCM*Z) TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/ $ SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2 TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2) $ *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2- $ XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/ $ (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2) SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN) SIGRL=2*E**4*PCM/128./PI/EB*TZZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,29,26) 330 CONTINUE IF (.NOT.(GOQ(26,1).AND.GOQ(29,2))) GO TO 340 Z=-CTH(1) TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+ $ 4*XC*YC*(AE-BE)**2*EB*PCM*Z) TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2* $ (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+ $ 2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)- $ 4*XC*YC*(AE+BE)**2*EB*PCM*Z) TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/ $ SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2 TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2) $ *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2- $ XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/ $ (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2) SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN) SIGRL=2*E**4*PCM/128./PI/EB*TZZRL SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,26,29) 340 CONTINUE C C Neutralino pair production C DO 400 IZ1=1,4 AMZIZ1=ABS(AMZISS(IZ1)) JTYPZ1=IZ2JS(IZ1) DO 410 IZ2=1,4 AMZIZ2=ABS(AMZISS(IZ2)) JTYPZ2=IZ2JS(IZ2) IF(.NOT.(GOQ(JTYPZ1,1).AND.GOQ(JTYPZ2,2))) GO TO 410 IF((AMZIZ1+AMZIZ2).GE.RSH) GO TO 410 WIJ=SQRT(G**2+GP**2)*ZI**(ITHZ(IZ2))*(-ZI)**(ITHZ(IZ1))* $ (ZMIXSS(1,IZ1)*ZMIXSS(1,IZ2)-ZMIXSS(2,IZ1)* $ ZMIXSS(2,IZ2))/4. KK=SQRT(SH*SH+(AMZIZ1**2-AMZIZ2**2)**2-2*SH* $ (AMZIZ1**2+AMZIZ2**2))/4./EB Z=CTH(1) SIGLL=2*AEZ(IZ1)*CONJG(AEZ(IZ1))*AEZ(IZ2)*CONJG(AEZ(IZ2))* $ SSGT(SH,MEL,Z,IZ1,IZ2) SIGRR=2*BEZ(IZ1)*CONJG(BEZ(IZ1))*BEZ(IZ2)*CONJG(BEZ(IZ2))* $ SSGT(SH,MER,Z,IZ1,IZ2) SIGZZL=4*E**2*WIJ*CONJG(WIJ)*(AE-BE)**2* $ (SH*SH-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+ $ ITHZ(IZ2)+1)*SH*AMZIZ1*AMZIZ2+4*SH*KK*KK*Z*Z)/PROPZ SIGZZR=4*E**2*WIJ*CONJG(WIJ)*(AE+BE)**2* $ (SH*SH-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+ $ ITHZ(IZ2)+1)*SH*AMZIZ1*AMZIZ2+4*SH*KK*KK*Z*Z)/PROPZ SIGLZ=-E*(AE-BE)*(SH-AMZ**2)/2./PROPZ* $ (REAL(WIJ*CONJG(AEZ(IZ1))*AEZ(IZ2))* $ SSGST(SH,MEL,Z,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))* $ REAL(WIJ*AEZ(IZ1)*CONJG(AEZ(IZ2)))* $ SSGST(SH,MEL,-Z,IZ1,IZ2)) SIGRZ=-E*(-1.)**(ITHZ(IZ1)+ITHZ(IZ2)+1)* $ (AE+BE)*(SH-AMZ**2)/2./PROPZ* $ (REAL(WIJ*CONJG(BEZ(IZ1))*BEZ(IZ2))* $ SSGST(SH,MER,Z,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))* $ REAL(WIJ*BEZ(IZ1)*CONJG(BEZ(IZ2)))* $ SSGST(SH,MER,-Z,IZ1,IZ2)) SIGLR=2*KK/16./PI/SH/SQRT(SH)*(SIGLL+SIGZZL+SIGLZ) SIGRL=2*KK/16./PI/SH/SQRT(SH)*(SIGRR+SIGZZR+SIGRZ) C BELOW FACTOR OF 2 FOR ID PARTICLES AND JETTYP SWITCH SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF CALL SIGFIL(SIG,0,0,JTYPZ1,JTYPZ2) 410 CONTINUE 400 CONTINUE C C Higgs boson mechanisms C C E+ E- --> Z H_L; symmetric in cos(theta) IF((AMZ+AMHL).LT.RSH) THEN FACLR=E**2*G**2*(SIN(ALFAH+BETA))**2*(AE-BE)**2/CS2THW FACRL=E**2*G**2*(SIN(ALFAH+BETA))**2*(AE+BE)**2/CS2THW Z=CTH(1) PCM=SQRT(SSXLAM(SH,AMZ**2,AMHL**2))/4./EB EZ0=SQRT(PCM**2+AMZ**2) FAC1=AMZ**2+EZ0**2-PCM**2*Z**2 SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(80,1).AND.GOQ(81,2)) CALL SIGFIL(SIG,0,0,80,81) IF(GOQ(81,1).AND.GOQ(80,2)) CALL SIGFIL(SIG,0,0,81,80) ENDIF C E+ E- --> Z H_H; symmetric in cos(theta) IF((AMZ+AMHH).LT.RSH) THEN FACLR=E**2*G**2*(COS(ALFAH+BETA))**2*(AE-BE)**2/CS2THW FACRL=E**2*G**2*(COS(ALFAH+BETA))**2*(AE+BE)**2/CS2THW Z=CTH(1) PCM=SQRT(SSXLAM(SH,AMZ**2,AMHH**2))/4./EB EZ0=SQRT(PCM**2+AMZ**2) FAC1=AMZ**2+EZ0**2-PCM**2*Z**2 SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1 SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(80,1).AND.GOQ(82,2)) CALL SIGFIL(SIG,0,0,80,82) IF(GOQ(82,1).AND.GOQ(80,2)) CALL SIGFIL(SIG,0,0,82,80) ENDIF C E+ E- --> H_P H_L; symmetric in cos(theta) IF((AMHA+AMHL).LT.RSH) THEN PCM=SQRT(SSXLAM(SH,AMHA**2,AMHL**2))/4./EB Z=CTH(1) FAC1=PCM**3*(1.-Z**2) FACLR=E**4*(COS(ALFAH+BETA))**2*(AE-BE)**2*FAC1 FACRL=E**4*(COS(ALFAH+BETA))**2*(AE+BE)**2*FAC1 SIGLR=2*FACLR/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ SIGRL=2*FACRL/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(81,1).AND.GOQ(83,2)) CALL SIGFIL(SIG,0,0,81,83) IF(GOQ(83,1).AND.GOQ(81,2)) CALL SIGFIL(SIG,0,0,83,81) ENDIF C E+ E- --> H_P H_H; SYMMETRIC IN COS(THETA) IF((AMHA+AMHH).LT.RSH) THEN PCM=SQRT(SSXLAM(SH,AMHA**2,AMHH**2))/4./EB Z=CTH(1) FAC1=PCM**3*(1.-Z**2) FACLR=E**4*(SIN(ALFAH+BETA))**2*(AE-BE)**2*FAC1 FACRL=E**4*(SIN(ALFAH+BETA))**2*(AE+BE)**2*FAC1 SIGLR=2*FACLR/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ SIGRL=2*FACRL/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(82,1).AND.GOQ(83,2)) CALL SIGFIL(SIG,0,0,82,83) IF(GOQ(83,1).AND.GOQ(82,2)) CALL SIGFIL(SIG,0,0,83,82) ENDIF C E+ E- --> H^+ H^-; symmetric in cos(theta) IF((2*AMHC).LT.RSH) THEN PCM=SQRT(SSXLAM(SH,AMHC**2,AMHC**2))/4./EB Z=CTH(1) FAC1=PCM**3*(1.-Z**2) FACLR=FAC1*(1./SH**2+(2*SN2THW-1.)**2/SN2THW/CS2THW* $(AE-BE)**2/4./PROPZ+(2*SN2THW-1.)*(AE-BE)*(SH-AMZ**2)/SH/ $SQRT(SN2THW*CS2THW)/PROPZ) FACRL=FAC1*(1./SH**2+(2*SN2THW-1.)**2/SN2THW/CS2THW* $(AE+BE)**2/4./PROPZ+(2*SN2THW-1.)*(AE+BE)*(SH-AMZ**2)/SH/ $SQRT(SN2THW*CS2THW)/PROPZ) SIGLR=2*E**4*FACLR/8./PI/SQRT(SH) SIGRL=2*E**4*FACRL/8./PI/SQRT(SH) SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2. IF (IBREM.AND..NOT.IBEAM) THEN SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC ELSE IF (IBEAM) THEN SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC END IF IF(GOQ(84,1).AND.GOQ(85,2)) CALL SIGFIL(SIG,0,0,84,85) IF(GOQ(85,1).AND.GOQ(84,2)) CALL SIGFIL(SIG,0,0,85,84) ENDIF C RETURN END +EOD +DECK,SIGSSL. SUBROUTINE SIGSSL C C Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric C sleptons and sneutrinos in MSSM using cross C sections from Baer and Tata. C C SIGMA = cross section summed over types allowed by C JETTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4 C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1 C JETTYP -> IDENT mapping: C GLSS, UPSSL, UBSSL, ..., UPSSR, UBSSR, ..., C W1SS+, W1SS-, WS22+, W2SS-, Z1SS, Z2SS, Z3SS, Z4SS C NUEL, ANUEL, EL-, ..., TAUL+ C C Extra factor of 1/2 needed for nonidentical final jets. C Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2 C C Called from SIGSSY and so does not reinitialize /JETSIG/. C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,CONST +CDE,JETPAR +CDE,JETSIG +CDE,PRIMAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,SSPAR +CDE,SSSM +CDE,SSTYPE +CDE,WCON C REAL X(2) EQUIVALENCE (X(1),X1) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) INTEGER JS2JT(25),IW2JS(4),IW2IM(4),IZ2JS(4),IS2UD(25) SAVE JS2JT,IW2JS,IW2IM,IZ2JS,IS2UD INTEGER IDLSS(18) SAVE IDLSS INTEGER IL2JS(18),IS2LN(18),II SAVE IL2JS,IS2LN REAL SIG,S,T,U,FAC,AM22,AM12,TT,GP,G, $E1,E2 INTEGER IQ,IQ1,IQ2,IH REAL QFCN,STRUC,PSIFCN,AMASS REAL SR2,AML,AMN,SIGW,PROPZ REAL CS2THW,TNTHW,CTTHW,AL(2),BE(2),ESQ,XWI(2),YWI(2) REAL ALL(2),BEL(2),EL1 REAL EQ1,XMGG,XMZZ,XMGZ,XM,CTH2L REAL SIGUT,SIGTU,EHAT,PHAT,EBM,TPP,AMWI,AMQ,PROPW REAL A,B,ASPBS,ASMBS,TM1,TM2,TM3,COTB,TANB INTEGER JTYP1,JTYP2,IFLQ,IUD(13) INTEGER IFLL,IL,IN,IDL,IDN,IL1,IL2,JTYPL1,JTYPL2,IDL1,IDL2 C C IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in C parameter statements but not data statements.) INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) DATA IDLSS/ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL, $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR, $ISTAU2,MSTAU2/ DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/ C C JS2JT: Susy jettype -> normal jettype DATA JS2JT/1, $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/ C IW2JS: Wino index -> susy jettype DATA IW2JS/26,27,28,29/ C IW2IM: Wino index -> match code DATA IW2IM/2,3,2,3/ C IZ2JS: Zino index -> susy jettype DATA IZ2JS/30,31,32,33/ C IS2UD: Susy jettype -> u/d code DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/ DATA IS2LN/1,1,2,2,1,1,2,2,1,1,2,2,2,2,2,2,2,2/ DATA IL2JS/34,35,36,37,38,39,40,41,42,43,44,45,46,47, $48,49,50,51/ C C Functions QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) PSIFCN(AM12,AM22,TT)=((S+TT-AM12)/(2*S) $-AM12*(AM22-TT)/(AM12-TT)**2 $+(TT*(AM22-AM12)+AM22*(S-AM22+AM12))/(S*(AM12-TT))) C C Constants from Baer and Tata, C G=SQRT(4*PI*ALFAEM/SN2THW) GP=G*SQRT(SN2THW/(1.-SN2THW)) C Quark couplings to Z CS2THW=1.-SN2THW TNTHW=SQRT(SN2THW/CS2THW) CTTHW=1./TNTHW AL(1)=(CTTHW/4.-5*TNTHW/12.) AL(2)=(TNTHW/12.-CTTHW/4.) BE(1)=-(CTTHW+TNTHW)/4. BE(2)=-BE(1) ALL(1)=(CTTHW+TNTHW)/4. ALL(2)=(-CTTHW+3*TNTHW)/4. BEL(1)=-(CTTHW+TNTHW)/4. BEL(2)=-BEL(1) ESQ=4*PI*ALFAEM SR2=SQRT(2.) COTB=RV2V1 TANB=1./COTB C C qk qb --> slss slbss C C C Left-leftbar slepton pair production C DO 200 IL=1,6 IL1=2*IL-1 IL2=IL1+1 AML=AMASS(IDLSS(IL1)) JTYPL1=IL2JS(IL1) JTYPL2=IL2JS(IL2) IDL1=IDLSS(IL1) IDL2=IDLSS(IL2) IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 210 CALL TWOKIN(0.,0.,AML,AML) IF (X1.GE.1..OR.X2.GE.1.) GO TO 210 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 220 IQ1=2,11 IFLQ=IS2UD(IQ1) IFLL=IS2LN(IL1) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IFLL.EQ.1) THEN EL1=0. ELSE EL1=-1. END IF IQ2=MATCH(IQ1,4) PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 220 XMGG=EL1**2*EQ1**2/S/S CTH2L=1. IF (JTYPL1.EQ.44) CTH2L=COS(2*THETAL) XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)-BEL(IFLL)* $ CTH2L)**2/PROPZ XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)-BEL(IFLL)*CTH2L)* $ (S-AMZ**2)/S/PROPZ XM=2*ESQ*ESQ*(U*T-AML**4)/3. SIG=XM*(XMGG+XMZZ+XMGZ) SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2) 220 CONTINUE 210 CONTINUE 200 CONTINUE C stau_1 + stau_2 bar IF (GOQ(44,1).AND.GOQ(51,2)) THEN CALL TWOKIN(0.,0.,AML1SS,AML2SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 231 E1=SQRT(P(1)**2+AML1SS**2) E2=SQRT(P(2)**2+AML2SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 230 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230 SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2* $ SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,44,51) 230 CONTINUE 231 CONTINUE END IF C C C Right-rightbar slepton pair production C DO 300 IL=1,3 IL1=11+2*IL IL2=IL1+1 AML=AMASS(IDLSS(IL1)) JTYPL1=IL2JS(IL1) JTYPL2=IL2JS(IL2) IDL1=IDLSS(IL1) IDL2=IDLSS(IL2) IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 310 CALL TWOKIN(0.,0.,AML,AML) IF (X1.GE.1..OR.X2.GE.1.) GO TO 310 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 320 IQ1=2,11 IFLQ=IS2UD(IQ1) IFLL=IS2LN(IL1) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IFLL.EQ.1) THEN EL1=0. ELSE EL1=-1. END IF IQ2=MATCH(IQ1,4) PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 320 XMGG=EL1**2*EQ1**2/S/S CTH2L=1. IF (JTYPL1.EQ.50) CTH2L=COS(2*THETAL) XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)+BEL(IFLL)* $ CTH2L)**2/PROPZ XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)+BEL(IFLL)*CTH2L)* $ (S-AMZ**2)/S/PROPZ XM=2*ESQ*ESQ*(U*T-AML**4)/3. SIG=XM*(XMGG+XMZZ+XMGZ) SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2) 320 CONTINUE 310 CONTINUE 300 CONTINUE C stau_2 bar + stau_1 IF (GOQ(51,1).AND.GOQ(44,2)) THEN CALL TWOKIN(0.,0.,AML2SS,AML1SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 331 E1=SQRT(P(1)**2+AML2SS**2) E2=SQRT(P(2)**2+AML1SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 330 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 330 SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2* $ SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,51,44) 330 CONTINUE 331 CONTINUE END IF C C C Leftbar-left slepton pair production C DO 400 IL=1,6 IL1=2*IL IL2=IL1-1 AML=AMASS(IDLSS(IL1)) JTYPL1=IL2JS(IL1) JTYPL2=IL2JS(IL2) IDL1=IDLSS(IL1) IDL2=IDLSS(IL2) IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 410 CALL TWOKIN(0.,0.,AML,AML) IF (X1.GE.1..OR.X2.GE.1.) GO TO 410 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 420 IQ1=2,11 IFLQ=IS2UD(IQ1) IFLL=IS2LN(IL1) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IFLL.EQ.1) THEN EL1=0. ELSE EL1=-1. END IF IQ2=MATCH(IQ1,4) PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 420 XMGG=EL1**2*EQ1**2/S/S CTH2L=1. IF (JTYPL1.EQ.45) CTH2L=COS(2*THETAL) XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)-BEL(IFLL)* $ CTH2L)**2/PROPZ XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)-BEL(IFLL)*CTH2L)* $ (S-AMZ**2)/S/PROPZ XM=2*ESQ*ESQ*(U*T-AML**4)/3. SIG=XM*(XMGG+XMZZ+XMGZ) SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2) 420 CONTINUE 410 CONTINUE 400 CONTINUE C stau_1 bar + stau_2 IF (GOQ(45,1).AND.GOQ(50,2)) THEN CALL TWOKIN(0.,0.,AML1SS,AML2SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 431 E1=SQRT(P(1)**2+AML1SS**2) E2=SQRT(P(2)**2+AML2SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 430 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 430 SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2* $ SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,45,50) 430 CONTINUE 431 CONTINUE END IF C C C Rightbar-right slepton pair production C DO 500 IL=1,3 IL1=12+2*IL IL2=IL1-1 AML=AMASS(IDLSS(IL1)) JTYPL1=IL2JS(IL1) JTYPL2=IL2JS(IL2) IDL1=IDLSS(IL1) IDL2=IDLSS(IL2) IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 510 CALL TWOKIN(0.,0.,AML,AML) IF (X1.GE.1..OR.X2.GE.1.) GO TO 510 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 520 IQ1=2,11 IFLQ=IS2UD(IQ1) IFLL=IS2LN(IL1) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IFLL.EQ.1) THEN EL1=0. ELSE EL1=-1. END IF IQ2=MATCH(IQ1,4) PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 520 XMGG=EL1**2*EQ1**2/S/S CTH2L=1. IF (JTYPL1.EQ.51) CTH2L=COS(2*THETAL) XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)+BEL(IFLL)* $ CTH2L)**2/PROPZ XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)+BEL(IFLL)*CTH2L)* $ (S-AMZ**2)/S/PROPZ XM=2*ESQ*ESQ*(U*T-AML**4)/3. SIG=XM*(XMGG+XMZZ+XMGZ) SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2) 520 CONTINUE 510 CONTINUE 500 CONTINUE C stau_2 + stau_1 bar IF (GOQ(50,1).AND.GOQ(45,2)) THEN CALL TWOKIN(0.,0.,AML2SS,AML1SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 531 E1=SQRT(P(1)**2+AML2SS**2) E2=SQRT(P(2)**2+AML1SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 530 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 530 SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2* $ SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,50,45) 530 CONTINUE 531 CONTINUE END IF C C slepton+sneutrino-bar via W-* C DO 600 II=1,3 IL=4*II-1 IN=IL-1 IDL=IDLSS(IL) IDN=IDLSS(IN) AML=AMASS(IDL) AMN=AMASS(IDN) JTYP1=IL2JS(IL) JTYP2=IL2JS(IN) IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 610 CALL TWOKIN(0.,0.,AML,AMN) IF(X1.GE.1..OR.X2.GE.1.) GO TO 610 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AMN**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW IF (JTYP1.EQ.44) SIGW=SIGW*COS(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,JTYP1,JTYP2) 610 CONTINUE 600 CONTINUE C stau_2 +nu_tau bar IF (GOQ(50,1).AND.GOQ(43,2)) THEN CALL TWOKIN(0.,0.,AML2SS,AMN3SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 620 E1=SQRT(P(1)**2+AML2SS**2) E2=SQRT(P(2)**2+AMN3SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW SIGW=SIGW*SIN(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,50,43) SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,50,43) SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,50,43) SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,50,43) 620 CONTINUE END IF C C sneutrino-bar+slepton via W-* C DO 700 II=1,3 IN=4*II-2 IL=IN+1 IDL=IDLSS(IL) IDN=IDLSS(IN) AML=AMASS(IDL) AMN=AMASS(IDN) JTYP1=IL2JS(IN) JTYP2=IL2JS(IL) IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 710 CALL TWOKIN(0.,0.,AMN,AML) IF(X1.GE.1..OR.X2.GE.1.) GO TO 710 E1=SQRT(P(1)**2+AMN**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW IF (JTYP2.EQ.44) SIGW=SIGW*COS(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,JTYP1,JTYP2) 710 CONTINUE 700 CONTINUE C nu_tau bar + STAU_2 IF (GOQ(43,1).AND.GOQ(50,2)) THEN CALL TWOKIN(0.,0.,AMN3SS,AML2SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 720 E1=SQRT(P(1)**2+AMN3SS**2) E2=SQRT(P(2)**2+AML2SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW SIGW=SIGW*SIN(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,43,50) SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,43,50) SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,43,50) SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,43,50) 720 CONTINUE END IF C C slepton-bar+sneutrino via W+* C DO 800 II=1,3 IL=4*II IN=IL-3 IDL=IDLSS(IL) IDN=IDLSS(IN) AML=AMASS(IDL) AMN=AMASS(IDN) JTYP1=IL2JS(IL) JTYP2=IL2JS(IN) IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 810 CALL TWOKIN(0.,0.,AML,AMN) IF(X1.GE.1..OR.X2.GE.1.) GO TO 810 E1=SQRT(P(1)**2+AML**2) E2=SQRT(P(2)**2+AMN**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW IF (JTYP1.EQ.45) SIGW=SIGW*COS(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,JTYP1,JTYP2) 810 CONTINUE 800 CONTINUE C stau_2 bar+nu_tau IF (GOQ(51,1).AND.GOQ(42,2)) THEN CALL TWOKIN(0.,0.,AML2SS,AMN3SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 820 E1=SQRT(P(1)**2+AML2SS**2) E2=SQRT(P(2)**2+AMN3SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW SIGW=SIGW*SIN(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,51,42) SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,51,42) SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,51,42) SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,51,42) 820 CONTINUE END IF C C sneutrino+slepton-bar via W+* C DO 900 II=1,3 IN=4*II-3 IL=IN+3 IDL=IDLSS(IL) IDN=IDLSS(IN) AML=AMASS(IDL) AMN=AMASS(IDN) JTYP1=IL2JS(IN) JTYP2=IL2JS(IL) IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 910 CALL TWOKIN(0.,0.,AMN,AML) IF(X1.GE.1..OR.X2.GE.1.) GO TO 910 E1=SQRT(P(1)**2+AMN**2) E2=SQRT(P(2)**2+AML**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW IF (JTYP2.EQ.45) SIGW=SIGW*COS(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,JTYP1,JTYP2) SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,JTYP1,JTYP2) 910 CONTINUE 900 CONTINUE C nu_tau + stau_2 bar IF (GOQ(42,1).AND.GOQ(51,2)) THEN CALL TWOKIN(0.,0.,AMN3SS,AML2SS) IF(X1.GE.1..OR.X2.GE.1.) GO TO 920 E1=SQRT(P(1)**2+AMN3SS**2) E2=SQRT(P(2)**2+AML2SS**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW SIGW=SIGW*SIN(THETAL)**2 SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,42,51) SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,42,51) SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,42,51) SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,42,51) 920 CONTINUE END IF C RETURN END +EOD +DECK,SIGSSY. SUBROUTINE SIGSSY C C Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric C particle pairs, including gluinos, gauginos, and squarks. C C SIGMA = cross section summed over types allowed by C JETTYPE cards (with natural equivalence.) C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4 C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1 C C Extra factor of 1/2 needed for nonidentical final jets. C Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2 C C Dec. 1992: Use cross sections from Baer and Tata, Phys. C Lett. 160B, 159; Phys. Rev. D42, 2259. These papers C separate L and R squarks. C C Gauginos are included only for MSSM. The cross sections are C calculated in SIGSSZ, which is called from here. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,CONST +CDE,QSAVE +CDE,WCON. +CDE,SSTYPE +CDE,XMSSM C REAL X(2) INTEGER IDQ(13),IDQSS(25),JS2JT(25) EQUIVALENCE (X(1),X1) LOGICAL LLRR REAL QFCN,STRUC,AMASS,FQG REAL AMG,SIG0,SIGR,AM1,SIG,FAC,AMQ,AM,AM2,AMQ2,S,T,U,AMG2,E1,E2, $AMSQ,AM1SQ,AM2SQ,SIGL INTEGER IFL1,IFL2,IQ1,IQ2,JQ1,JQ2,I,IFLQ1,IFLQ2,IH,IQ, $JQ,JQIN1,JQIN2 C C IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in C parameter statements but not data statements.) INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2, $MDUP,MDDN,MDST,MDCH,MDBT,MDTP PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MDUP=-IDUP) PARAMETER (MDDN=-IDDN) PARAMETER (MDST=-IDST) PARAMETER (MDCH=-IDCH) PARAMETER (MDBT=-IDBT) PARAMETER (MDTP=-IDTP) DATA IDQSS/0, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2/ DATA IDQ/IDGL,IDUP,MDUP,IDDN,MDDN,IDST,MDST,IDCH,MDCH, $IDBT,MDBT,IDTP,MDTP/ C JS2JT: Susy jettype -> normal jettype DATA JS2JT/1, $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/ C C Functions QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) FQG(S,T,U)=((16./3.)*(1./(U*T)**2+1./(S*U)**2) $+2.*(-2./3.)/(S*T*U**2))*(-U*S*T**2+2.*U*S*T*(AMG2-AMQ2) $-2.*U*S*(AMG2-AMQ2)**2-2.*S**2*AMG2*(AMG2-AMQ2)) C C Initialize C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS SIGS(I)=0. 100 CONTINUE C C Gluino + gluino C IF(.NOT.(GOQ(1,1).AND.GOQ(1,2))) GO TO 300 AM=AMASS(ISGL) CALL TWOKIN(0.,0.,AM,AM) IF(X1.GE.1..OR.X2.GE.1.) GO TO 300 AM2=AM**2 S=SHAT T=THAT U=UHAT E1=SQRT(P(1)**2+AM2) E2=SQRT(P(2)**2+AM2) FAC=PI*ALFQSQ**2/S**2 FAC=FAC*(S/SCM)*(P(1)*P(2)/(E1*E2))*UNITS C C gl gl ---> glss glss SIG=9./4.*(2.*(T-AM2)*(U-AM2)/S**2 $+((T-AM2)*(U-AM2)-2.*AM2*(T+AM2))/(T-AM2)**2 $+((U-AM2)*(T-AM2)-2.*AM2*(U+AM2))/(U-AM2)**2 $+((T-AM2)*(U-AM2)+AM2*(U-T))/(S*(T-AM2)) $+((U-AM2)*(T-AM2)+AM2*(T-U))/(S*(U-AM2)) $+AM2*(S-4*AM2)/((T-AM2)*(U-AM2))) SIG=.5*FAC*SIG*QFCN(1,1)*QFCN(1,2) CALL SIGFIL(SIG,1,1,1,1) C C qk qb ---> glss glss DO 220 IQ=1,5 IQ1=2*IQ IQ2=IQ1+1 C Left squark exchange AMQ=AMASS(IDQSS(IQ1)) AMQ2=AMQ**2 SIGL=(8./3.)*((T-AM2)**2+(U-AM2)**2+2.*AM2*S)/(S**2) $ +(32./27.)*(T-AM2)**2/(T-AMQ2)**2 $ +(32./27.)*(U-AM2)**2/(U-AMQ2)**2 $ +(8./3.)*((T-AM2)**2+AM2*S)/(S*(T-AMQ2)) $ +(8./3.)*((U-AM2)**2+AM2*S)/(S*(U-AMQ2)) $ +(8./27.)*AM2*S/((T-AMQ2)*(U-AMQ2)) SIGL=.5*FAC*SIGL C Right squark exchange AMQ=AMASS(IDQSS(IQ1+12)) AMQ2=AMQ**2 SIGR=(8./3.)*((T-AM2)**2+(U-AM2)**2+2.*AM2*S)/(S**2) $ +(32./27.)*(T-AM2)**2/(T-AMQ2)**2 $ +(32./27.)*(U-AM2)**2/(U-AMQ2)**2 $ +(8./3.)*((T-AM2)**2+AM2*S)/(S*(T-AMQ2)) $ +(8./3.)*((U-AM2)**2+AM2*S)/(S*(U-AMQ2)) $ +(8./27.)*AM2*S/((T-AMQ2)*(U-AMQ2)) SIGR=.5*FAC*SIGR SIG0=.5*(SIGL+SIGR) C Total SIG=SIG0*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,1,1) SIG=SIG0*QFCN(IQ2,1)*QFCN(IQ1,2) CALL SIGFIL(SIG,IQ2,IQ1,1,1) 220 CONTINUE C C Scalar quark + scalar (anti)quark C 300 CONTINUE AMG=AMASS(ISGL) AMG2=AMG**2 C IQ1 and IQ2 loop over left and right (anti)squarks DO 310 IQ1=2,25 DO 320 IQ2=2,25 IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 320 JQ1=JS2JT(IQ1) JQ2=JS2JT(IQ2) C IF(JQ1.GE.12.OR.JQ2.GE.12) GO TO 320 IFL1=IDQSS(IQ1) IFL2=IDQSS(IQ2) IFLQ1=IDQ(JQ1) IFLQ2=IDQ(JQ2) C LLRR is true for left-left or right-right IF((IQ1.LE.13.AND.IQ2.LE.13).OR.(IQ1.GT.13.AND.IQ2.GT.13)) $ THEN LLRR=.TRUE. ELSE LLRR=.FALSE. ENDIF C Kinematics AM1=AMASS(IFL1) AM2=AMASS(IFL2) AM=AM1 CALL TWOKIN(0.,0.,AM1,AM2) IF(X1.GE.1..OR.X2.GE.1.) GO TO 320 AMSQ=AM**2 AM1SQ=AM1**2 AM2SQ=AM2**2 S=SHAT T=THAT U=UHAT E1=SQRT(P(1)**2+AM1SQ) E2=SQRT(P(2)**2+AM2SQ) FAC=PI*ALFQSQ**2/S**2 FAC=FAC*(S/SCM)*(P(1)*P(2)/(E1*E2))*UNITS C C gl gl ---> qkss qbss C IF(IFL1.EQ.-IFL2) THEN SIG=(7./48.+3.*(U-T)**2/(16.*S**2)) $ *(1.+2.*AMSQ*T/(T-AMSQ)**2+2.*AMSQ*U/(U-AMSQ)**2 $ +4.*AMSQ**2/((T-AMSQ)*(U-AMSQ))) SIG=SIG*FAC*QFCN(1,1)*QFCN(1,2) SIG=.5*SIG C Another .5 to sum over L and R SIG=.5*SIG CALL SIGFIL(SIG,1,1,IQ1,IQ2) ENDIF C C qk qb ---> qkss qbss C IF(IFLQ1.EQ.-IFLQ2.AND.LLRR) THEN C Identical squark-antisquark, LL or RR SIG=(2./9.)*(1/(T-AMG2)**2+2/S**2-2/(3*S*(T-AMG2))) $ *(-S*T-(T-AMSQ)**2)*FAC*QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*(1/(U-AMG2)**2+2/S**2-2/(3*S*(U-AMG2))) $ *(-S*U-(U-AMSQ)**2)*FAC*QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSEIF(IFLQ1.EQ.-IFLQ2.AND..NOT.LLRR) THEN C Identical squark-antisquark, LR or RL SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSEIF(IFLQ1.EQ.IFLQ2.AND.LLRR) THEN C Identical squark-squark, LL or RR SIG=(1./9.)*AMG2*S*(1/(T-AMG2)**2+1/(U-AMG2)**2 $ -(2./3.)/((T-AMG2)*(U-AMG2)))*FAC*QFCN(JQ1,1)*QFCN(JQ2,2) CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) ELSEIF(IFLQ1.EQ.IFLQ2.AND..NOT.LLRR) THEN C Identical squark-squark, LR or RL SIG=(2./9.)*(1/(T-AMG2)**2*(-S*T-(T-AM1SQ)*(T-AM2SQ)) $ +1/(U-AMG2)**2*(-S*U-(U-AM1SQ)*(U-AM2SQ))) $ *FAC*QFCN(JQ1,1)*QFCN(JQ2,2) CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) ELSEIF(IFL1*IFL2.LT.0.AND.LLRR) THEN C Nonidentical squark-antisquark, LL or RR SIG=(2./9.)*(-S*T-(T-AM1SQ)*(T-AM2SQ))/(T-AMG2)**2*FAC $ *QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*(-S*U-(U-AM1SQ)*(U-AM2SQ))/(U-AMG2)**2*FAC $ *QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSEIF(IFL1*IFL2.LT.0.AND..NOT.LLRR) THEN C Nonidentical squark-antisquark, LR or RL SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSEIF(IFL1*IFL2.GT.0.AND.LLRR) THEN C Nonidentical squark-squark, LL or RR SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSEIF(IFL1*IFL2.GT.0.AND..NOT.LLRR) THEN C Nonidentical squark-squark, LR or RL SIG=(2./9.)*(-S*T-(T-AM1SQ)*(T-AM2SQ))/(T-AMG2)**2*FAC $ *QFCN(JQ1,1)*QFCN(JQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2) SIG=(2./9.)*(-S*U-(U-AM1SQ)*(U-AM2SQ))/(U-AMG2)**2*FAC $ *QFCN(JQ2,1)*QFCN(JQ1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2) ELSE STOP99 ENDIF C C q1 + q1bar --> q2ss + q2ssbar C IF(IFLQ1.EQ.-IFLQ2.AND.LLRR) THEN DO 330 JQIN1=2,10,2 IF(JQIN1.EQ.JQ1.OR.JQIN1.EQ.JQ2) GO TO 330 JQIN2=MATCH(JQIN1,4) SIG=(4./9.)*(-S*T-(T-AM1SQ)**2)/S**2*FAC $ *QFCN(JQIN1,1)*QFCN(JQIN2,2) SIG=.5*SIG CALL SIGFIL(SIG,JQIN1,JQIN2,IQ1,IQ2) SIG=(4./9.)*(-S*U-(U-AM1SQ)**2)/S**2*FAC $ *QFCN(JQIN2,1)*QFCN(JQIN1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQIN2,JQIN1,IQ1,IQ2) 330 CONTINUE ENDIF 320 CONTINUE 310 CONTINUE C C Scalar quark + gluino C AMG=AMASS(ISGL) AMG2=AMG**2 DO 400 IQ=2,25 AMQ=AMASS(IDQSS(IQ)) AMQ2=AMQ**2 JQ=JS2JT(IQ) C C Jet 1 = scalar quark IF(.NOT.(GOQ(JQ,1).AND.GOQ(1,2))) GO TO 410 CALL TWOKIN(0.,0.,AMQ,AMG) IF(X1.GE.1..OR.X2.GE.1.) GO TO 410 S=SHAT E1=SQRT(P(1)**2+AMQ2) E2=SQRT(P(2)**2+AMG2) FAC=PI*ALFQSQ**2/S**2 FAC=FAC*S/SCM*P(1)*P(2)/(E1*E2)*UNITS C T=THAT-AMQ2 U=UHAT-AMG2 SIG=FQG(S,T,U)*FAC/12.*QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,IQ,1) C T=UHAT-AMQ2 U=THAT-AMG2 SIG=FQG(S,T,U)*FAC/12.*QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,IQ,1) C C Jet 2 = scalar quark 410 IF(.NOT.(GOQ(1,1).AND.GOQ(JQ,2))) GO TO 400 CALL TWOKIN(0.,0.,AMG,AMQ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 400 S=SHAT E1=SQRT(P(1)**2+AMG2) E2=SQRT(P(2)**2+AMQ2) FAC=PI*ALFQSQ**2/S**2 FAC=FAC*S/SCM*P(1)*P(2)/(E1*E2)*UNITS C T=UHAT-AMQ2 U=THAT-AMG2 SIG=FQG(S,T,U)*FAC/12.*QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,1,IQ) C T=THAT-AMQ2 U=UHAT-AMG2 SIG=FQG(S,T,U)*FAC/12.*QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,1,IQ) 400 CONTINUE C C Calculate gaugino AND slepton cross sections only for MSSM C IF(GOMSSM) CALL SIGSSZ IF(GOMSSM) CALL SIGSSL C RETURN END +EOD +DECK,SIGSSZ. SUBROUTINE SIGSSZ C C Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric C zino or wino plus squark or gluino in MSSM using cross C sections from Baer, Karatas, and Tata, PR D42, 2259. C Also include wino and zino pairs. C C SIGMA = cross section summed over types allowed by C JETTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4 C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1 C JETTYP -> IDENT mapping: C GLSS, UPSSL, UBSSL, ..., UPSSR, UBSSR, ..., C W1SS+, W1SS-, WS22+, W2SS-, Z1SS, Z2SS, Z3SS, Z4SS C C Extra factor of 1/2 needed for nonidentical final jets. C Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2 C C Called from SIGSSY and so does not reinitialize /JETSIG/. C C Ver 7.23: Add test setting SIG=0 for Z_i pairs if C ABS(ZZ)>0.999 and SIG<0. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,CONST +CDE,JETPAR +CDE,JETSIG +CDE,PRIMAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,SSPAR +CDE,SSSM +CDE,SSTYPE +CDE,WCON C REAL X(2) EQUIVALENCE (X(1),X1) COMPLEX AQZ(2,4),BQZ(2,4),AQW(2,2),WIJ EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) INTEGER JS2JT(25),IW2JS(4),IW2IM(4),IZ2JS(4),IS2UD(25) SAVE JS2JT,IW2JS,IW2IM,IZ2JS,IS2UD INTEGER IDQSS(25),IDZSS(4),IDWSS(4) SAVE IDQSS,IDZSS,IDWSS INTEGER ITHZ(4),ITHW(2) REAL AMWISS(2) REAL XZIWJ(4,2),YZIWJ(4,2) REAL SIG,SIG0,CON,AMQIQ,S,T,U,AMWIW,FAC,AM22,AM12,TT,GP,G, $E1,E2,AMG,YM,XM,GS,THX,THY,AMZIZ,AMSQK INTEGER IX,JQ,IQ,IQ1,IQ2,JW,IW,JTYPW,IH,JTYPZ,IZ,ITHG,IWM COMPLEX ZONE,ZI SAVE ZONE,ZI REAL QFCN,STRUC,PSIFCN,AMASS REAL CON11,CON22,CON12,AMQIQ1,AMQIQ2 INTEGER IX1,IX2 REAL CS2THW,TNTHW,CTTHW,AL(2),BE(2),ESQ,XWI(2),YWI(2) REAL X12,Y12,SN12,AMWIW1,AMWIW2,EQ1,ZZ,XMGG,XMZZ REAL XMGZ,XMUU,XMGU,XMZU,XMDD,XMGD,XMZD,DEL,RSH,SR2 REAL SIGUT,SIGTU,EHAT,PHAT,EBM,TPP,AMWI,AMQ,PROPW REAL SIGUT1,SIGUT2,SIGUT3,SGUT12,SGUT13,SGUT23 REAL SIGTU1,SIGTU2,SIGTU3,SGTU12,SGTU13,SGTU23 REAL AMSQL,AMSQR,KK,AMZIZ1,AMZIZ2 REAL SIGLL,SIGRR,SIGZZ,SIGLZ,SIGRZ,SSGT,SSGST,PROPZ,SSXLAM INTEGER IZ1,JTYPZ1,IZ2,JTYPZ2 INTEGER IW1,JW1,JTYPW1,IDW1,IW2,JW2,JTYPW2,IDW2,IFLQ,IUD(13) C C IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in C parameter statements but not data statements.) INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) DATA IDQSS/0, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2/ DATA IDZSS/ISZ1,ISZ2,ISZ3,ISZ4/ DATA IDWSS/ISW1,MSW1,ISW2,MSW2/ DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/ C C JS2JT: Susy jettype -> normal jettype DATA JS2JT/1, $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/ C IW2JS: Wino index -> susy jettype DATA IW2JS/26,27,28,29/ C IW2IM: Wino index -> match code DATA IW2IM/2,3,2,3/ C IZ2JS: Zino index -> susy jettype DATA IZ2JS/30,31,32,33/ C IS2UD: Susy jettype -> u/d code DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/ C DATA ZONE,ZI/(1.,0.),(0.,1.)/ C C Functions QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) PSIFCN(AM12,AM22,TT)=((S+TT-AM12)/(2*S) $-AM12*(AM22-TT)/(AM12-TT)**2 $+(TT*(AM22-AM12)+AM22*(S-AM22+AM12))/(S*(AM12-TT))) C C Constants from Baer, Barger, Karatas, and Tata, C PR D36, 96, using results from SSMIX C G=SQRT(4*PI*ALFAEM/SN2THW) GP=G*SQRT(SN2THW/(1.-SN2THW)) C GS=SQRT(4.*PI*ALFA3) XM=1./TAN(GAMMAL) YM=1./TAN(GAMMAR) THX=SIGN(1.,XM) THY=SIGN(1.,YM) AMG=AMASS(ISGL) ITHG=+1 C Signed masses AMWISS(1)=AMW1SS AMWISS(2)=AMW2SS C Zi couplings DO 100 IZ=1,4 ITHZ(IZ)=0 IF(AMZISS(IZ).LT.0) ITHZ(IZ)=1 AQZ(1,IZ)=ZI**(ITHZ(IZ)-1)*(-ZONE)**(ITHZ(IZ)+1) $ *(+G/SQRT2*ZMIXSS(3,IZ)+GP/(3*SQRT2)*ZMIXSS(4,IZ)) AQZ(2,IZ)=ZI**(ITHZ(IZ)-1)*(-ZONE)**(ITHZ(IZ)+1) $ *(-G/SQRT2*ZMIXSS(3,IZ)+GP/(3*SQRT2)*ZMIXSS(4,IZ)) BQZ(1,IZ)=+(4./3.)*ZI**(ITHZ(IZ)-1)*GP/SQRT2*ZMIXSS(4,IZ) BQZ(2,IZ)=-(2./3.)*ZI**(ITHZ(IZ)-1)*GP/SQRT2*ZMIXSS(4,IZ) 100 CONTINUE C Wi couplings ITHW(1)=0 IF(AMW1SS.LT.0.) ITHW(1)=1 AQW(1,1)=ZI*G*SIN(GAMMAL) AQW(2,1)=ZI*G*(-ZONE)**ITHW(1)*SIN(GAMMAR) ITHW(2)=0 IF(AMW2SS.LT.0.) ITHW(2)=1 AQW(1,2)=ZI*G*THX*COS(GAMMAL) AQW(2,2)=ZI*G*(-ZONE)**ITHW(2)*THY*COS(GAMMAR) C Quark couplings to Z CS2THW=1.-SN2THW TNTHW=SQRT(SN2THW/CS2THW) CTTHW=1./TNTHW AL(1)=CTTHW/4.-5*TNTHW/12. AL(2)=TNTHW/12.-CTTHW/4. BE(1)=-(CTTHW+TNTHW)/4. BE(2)=-BE(1) ESQ=4*PI*ALFAEM C Chargino couplings to Z XWI(1)=1.-(COS(GAMMAL)**2+COS(GAMMAR)**2)/4./CS2THW XWI(2)=1.-(SIN(GAMMAL)**2+SIN(GAMMAR)**2)/4./CS2THW YWI(1)=(COS(GAMMAR)**2-COS(GAMMAL)**2)/4./CS2THW YWI(2)=(SIN(GAMMAR)**2-SIN(GAMMAL)**2)/4./CS2THW X12=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)- $ THY*SIN(GAMMAR)*COS(GAMMAR)) Y12=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)+ $ THY*SIN(GAMMAR)*COS(GAMMAR)) SN12=-1.*SIGN(1.,AMW1SS)*SIGN(1.,AMW2SS) C C qk qb --> ziss glss C DO 200 IZ=1,4 AMZIZ=ABS(AMZISS(IZ)) JTYPZ=IZ2JS(IZ) C Jet 1 = ziss, jet 2 = glss IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(1,2))) GO TO 220 CALL TWOKIN(0.,0.,AMZIZ,AMG) IF(X1.GE.1..OR.X2.GE.1.) GO TO 220 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMZIZ**2) E2=SQRT(P(2)**2+AMG**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS C Sum over initial quarks (no top quarks) DO 210 IQ=2,11 IQ1=IQ IQ2=MATCH(IQ1,4) AMQIQ=AMASS(IDQSS(IQ)) SIG0=(AMZIZ**2-T)*(AMG**2-T)/(AMQIQ**2-T)**2 $ +(AMZIZ**2-U)*(AMG**2-U)/(AMQIQ**2-U)**2 $ -2*(-1)**(ITHZ(IZ)+ITHG)*AMG*AMZIZ*S $ /((AMQIQ**2-T)*(AMQIQ**2-U)) SIG0=SIG0*2*GS**2/9 CON=AQZ(IS2UD(IQ),IZ)*CONJG(AQZ(IS2UD(IQ),IZ)) $ +BQZ(IS2UD(IQ),IZ)*CONJG(BQZ(IS2UD(IQ),IZ)) SIG=FAC*CON*SIG0*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPZ,1) 210 CONTINUE C Jet 1 = glss, jet 2 = ziss 220 IF(.NOT.(GOQ(1,1).AND.GOQ(JTYPZ,2))) GO TO 200 CALL TWOKIN(0.,0.,AMG,AMZIZ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 200 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMG**2) E2=SQRT(P(2)**2+AMZIZ**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 230 IQ=2,11 IQ1=IQ IQ2=MATCH(IQ1,4) AMQIQ=AMASS(IDQSS(IQ)) SIG0=(AMZIZ**2-T)*(AMG**2-T)/(AMQIQ**2-T)**2 $ +(AMZIZ**2-U)*(AMG**2-U)/(AMQIQ**2-U)**2 $ -2*(-1)**(ITHZ(IZ)+ITHG)*AMG*AMZIZ*S $ /((AMQIQ**2-T)*(AMQIQ**2-U)) SIG0=SIG0*2*GS**2/9 CON=AQZ(IS2UD(IQ),IZ)*CONJG(AQZ(IS2UD(IQ),IZ)) $ +BQZ(IS2UD(IQ),IZ)*CONJG(BQZ(IS2UD(IQ),IZ)) SIG=FAC*CON*SIG0*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,1,JTYPZ) 230 CONTINUE 200 CONTINUE C C qk gl -> ziss qkss C DO 300 IZ=1,4 AMZIZ=ABS(AMZISS(IZ)) JTYPZ=IZ2JS(IZ) DO 310 IQ=2,25 JQ=JS2JT(IQ) IF(IABS(JQ).GE.12) GO TO 310 AMQIQ=AMASS(IDQSS(IQ)) C Jet 1 = ziss, jet 2 = qkss IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(IQ,2))) GO TO 320 CALL TWOKIN(0.,0.,AMZIZ,AMQIQ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 320 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMZIZ**2) E2=SQRT(P(2)**2+AMQIQ**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS IX=IS2UD(IQ) C Use AQZ for left squarks, BQZ for right IF(IQ.LE.13) THEN CON=AQZ(IX,IZ)*CONJG(AQZ(IX,IZ)) ELSE CON=BQZ(IX,IZ)*CONJG(BQZ(IX,IZ)) ENDIF SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMZIZ**2,T) $ *QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,JTYPZ,IQ) SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMZIZ**2,U) $ *QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,JTYPZ,IQ) C Jet 1 = qkss, jet 2 = ziss 320 IF(.NOT.(GOQ(IQ,1).AND.GOQ(JTYPZ,2))) GO TO 310 CALL TWOKIN(0.,0.,AMQIQ,AMZIZ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 310 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMQIQ**2) E2=SQRT(P(2)**2+AMZIZ**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS IX=IS2UD(IQ) C Use AQZ for left squarks, BQZ for right IF(IQ.LE.13) THEN CON=AQZ(IX,IZ)*CONJG(AQZ(IX,IZ)) ELSE CON=BQZ(IX,IZ)*CONJG(BQZ(IX,IZ)) ENDIF SIG=GS**2/6*CON*FAC*PSIFCN(AMQIQ**2,AMZIZ**2,U) $ *QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,IQ,JTYPZ) SIG=GS**2/6*CON*FAC*PSIFCN(AMQIQ**2,AMZIZ**2,T) $ *QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,IQ,JTYPZ) 310 CONTINUE 300 CONTINUE C C qk gl -> wiss qkss C DO 400 IW=1,4 JW=(IW+1)/2 AMWIW=ABS(AMWISS(JW)) JTYPW=IW2JS(IW) IWM=IW2IM(IW) C Left squarks only - DO 410 IQ=2,11 AMQIQ=AMASS(IDQSS(IQ)) C JQ is the matching incoming quark JQ=JS2JT(IQ) JQ=MATCH(JQ,4) JQ=MATCH(JQ,IWM) IF(JQ.EQ.0.OR.JQ.GE.12) GO TO 410 C Jet 1 = wiss, jet 2 = qkss IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(IQ,2))) GO TO 420 CALL TWOKIN(0.,0.,AMWIW,AMQIQ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 420 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMWIW**2) E2=SQRT(P(2)**2+AMQIQ**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS IX=IS2UD(JQ) CON=AQW(IX,JW)*CONJG(AQW(IX,JW)) SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,T) $ *QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,JTYPW,IQ) SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,U) $ *QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,JTYPW,IQ) C Jet 1 = qkss, jet 2 = wiss 420 IF(.NOT.(GOQ(IQ,1).AND.GOQ(JTYPW,2))) GO TO 410 CALL TWOKIN(0.,0.,AMQIQ,AMWIW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 410 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMQIQ**2) E2=SQRT(P(2)**2+AMWIW**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS IX=IS2UD(JQ) CON=AQW(IX,JW)*CONJG(AQW(IX,JW)) SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,U) $ *QFCN(JQ,1)*QFCN(1,2) SIG=.5*SIG CALL SIGFIL(SIG,JQ,1,IQ,JTYPW) SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,T) $ *QFCN(1,1)*QFCN(JQ,2) SIG=.5*SIG CALL SIGFIL(SIG,1,JQ,IQ,JTYPW) 410 CONTINUE 400 CONTINUE C C qk qb -> wiss glss C DO 500 IW=1,4 JW=(IW+1)/2 AMWIW=ABS(AMWISS(JW)) JTYPW=IW2JS(IW) IWM=IW2IM(IW) C Jet 1 = wiss, jet 2 = glss IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(1,2))) GO TO 520 CALL TWOKIN(0.,0.,AMWIW,AMG) IF(X1.GE.1..OR.X2.GE.1.) GO TO 520 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMWIW**2) E2=SQRT(P(2)**2+AMG**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS C Loop over quarks (no top quarks) DO 510 IQ=2,11 IQ1=IQ IQ2=MATCH(IQ1,IWM) IF(IQ2.EQ.0.OR.IQ2.GE.12) GO TO 510 AMQIQ1=AMASS(IDQSS(IQ1)) IX1=IS2UD(IQ1) AMQIQ2=AMASS(IDQSS(IQ2)) IX2=IS2UD(IQ2) CON11=AQW(IX1,JW)*CONJG(AQW(IX1,JW)) CON22=AQW(IX2,JW)*CONJG(AQW(IX2,JW)) CON12=2*(-1)**ITHG*REAL(AQW(IX1,JW)*AQW(IX2,JW)) SIG=CON11*(AMWIW**2-T)*(AMG**2-T)/(AMQIQ2**2-T)**2 $ +CON22*(AMWIW**2-U)*(AMG**2-U)/(AMQIQ1**2-U)**2 $ +CON12*AMG*AMWIW*S/((AMQIQ2**2-T)*(AMQIQ1**2-U)) SIG=2*GS**2/9*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPW,1) C No interchange needed here 510 CONTINUE C Jet 1 = glss, jet 2 = wiss 520 IF(.NOT.(GOQ(1,1).AND.GOQ(JTYPW,2))) GO TO 500 CALL TWOKIN(0.,0.,AMG,AMWIW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 500 GS=SQRT(4*PI*ALFQSQ) E1=SQRT(P(1)**2+AMG**2) E2=SQRT(P(2)**2+AMWIW**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS C Loop over quarks (no top quarks) DO 530 IQ=2,11 IQ1=IQ IQ2=MATCH(IQ1,IWM) IF(IQ2.EQ.0.OR.IQ2.GE.12) GO TO 530 AMQIQ1=AMASS(IDQSS(IQ1)) IX1=IS2UD(IQ1) AMQIQ2=AMASS(IDQSS(IQ2)) IX2=IS2UD(IQ2) CON11=AQW(IX1,JW)*CONJG(AQW(IX1,JW)) CON22=AQW(IX2,JW)*CONJG(AQW(IX2,JW)) CON12=2*(-1)**ITHG*REAL(AQW(IX1,JW)*AQW(IX2,JW)) SIG=CON11*(AMWIW**2-U)*(AMG**2-U)/(AMQIQ2**2-U)**2 $ +CON22*(AMWIW**2-T)*(AMG**2-T)/(AMQIQ1**2-T)**2 $ +CON12*AMG*AMWIW*S/((AMQIQ2**2-U)*(AMQIQ1**2-T)) SIG=2*GS**2/9*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,1,JTYPW) C NO INTERCHANGE NEEDED HERE 530 CONTINUE 500 CONTINUE C C Gaugino pair production. The W,Z poles are assumed C to be outside the physical region. C Constants from SSWZBF: C SR2=SQRT(2.) DO 601 IZ=1,4 XZIWJ(IZ,1)=.5*(SIGN(1.,AMWISS(1))*SIGN(1.,AMZISS(IZ)) $ *(COS(GAMMAR)*ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ)) $ -COS(GAMMAL)*ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ)) YZIWJ(IZ,1)=.5*(-SIGN(1.,AMWISS(1))*SIGN(1.,AMZISS(IZ)) $ *(COS(GAMMAR)*ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ)) $ -COS(GAMMAL)*ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ)) XZIWJ(IZ,2)=.5*(SIGN(1.,AMWISS(2))*SIGN(1.,AMZISS(IZ))*THY $ *(-SIN(GAMMAR)*ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ)) $ +THX*(SIN(GAMMAL)*ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ))) YZIWJ(IZ,2)=.5*(-SIGN(1.,AMWISS(2))*SIGN(1.,AMZISS(IZ)) $ *THY*(-SIN(GAMMAR)*ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ)) $ +THX*(SIN(GAMMAL)*ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ))) 601 CONTINUE C C Zino + wino: W* and squark graphs included C DO 610 IW=1,4 JW=(IW+1)/2 AMWIW=ABS(AMWISS(JW)) JTYPW=IW2JS(IW) IWM=IW2IM(IW) DO 620 IZ=1,4 AMZIZ=ABS(AMZISS(IZ)) JTYPZ=IZ2JS(IZ) AMQ=AMASS(IDQSS(2)) C Jet 1 = wiss, jet 2 = zjss IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(JTYPZ,2))) GO TO 630 CALL TWOKIN(0.,0.,AMWIW,AMZIZ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 630 E1=SQRT(P(1)**2+AMWIW**2) E2=SQRT(P(2)**2+AMZIZ**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS C Loop over quarks (no top quarks) SIGUT1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2) $ *((AMWIW**2-U)*(AMZIZ**2-U)+(AMWIW**2-T)*(AMZIZ**2-T))/4. $ +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW) $ *((AMWIW**2-U)*(AMZIZ**2-U)-(AMWIW**2-T)*(AMZIZ**2-T))/4. $ +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2. PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGUT1=2*G**4/3./PROPW*SIGUT1 SIGUT2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))* $ (AQW(1,JW)*CONJG(AQW(1,JW))) $ *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2 SIGUT3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))* $ (AQW(2,JW)*CONJG(AQW(2,JW))) $ *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2 SGUT12=-G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.* $ REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4. $ +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGUT13=G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.* $ REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4. $ +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGUT23=-4*AMWIW*AMZIZ*S/2./(U-AMQ**2)/(T-AMQ**2)/12.* $ REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW))) SIGUT=SIGUT1+SIGUT2+SIGUT3+SGUT12+SGUT13+SGUT23 C SIGTU1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2) $ *((AMWIW**2-T)*(AMZIZ**2-T)+(AMWIW**2-U)*(AMZIZ**2-U))/4. $ +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW) $ *((AMWIW**2-T)*(AMZIZ**2-T)-(AMWIW**2-U)*(AMZIZ**2-U))/4. $ +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2. SIGTU1=2*G**4/3./PROPW*SIGTU1 SIGTU2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))* $ (AQW(1,JW)*CONJG(AQW(1,JW))) $ *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2 SIGTU3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))* $ (AQW(2,JW)*CONJG(AQW(2,JW))) $ *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2 SGTU12=-G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.* $ REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4. $ +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGTU13=G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.* $ REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4. $ +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGTU23=-4*AMWIW*AMZIZ*S/2./(T-AMQ**2)/(U-AMQ**2)/12.* $ REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW))) SIGTU=SIGTU1+SIGTU2+SIGTU3+SGTU12+SGTU13+SGTU23 IF (IWM.EQ.2) THEN SIG=.5*SIGUT*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,JTYPW,JTYPZ) SIG=.5*SIGUT*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,JTYPW,JTYPZ) SIG=.5*SIGTU*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,JTYPW,JTYPZ) SIG=.5*SIGTU*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,JTYPW,JTYPZ) ELSE SIG=.5*SIGTU*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,JTYPW,JTYPZ) SIG=.5*SIGTU*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,JTYPW,JTYPZ) SIG=.5*SIGUT*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,JTYPW,JTYPZ) SIG=.5*SIGUT*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,JTYPW,JTYPZ) END IF C Jet 1 = zjss, jet 2 = wiss 630 IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(JTYPW,2))) GO TO 620 CALL TWOKIN(0.,0.,AMZIZ,AMWIW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 610 E1=SQRT(P(1)**2+AMZIZ**2) E2=SQRT(P(2)**2+AMWIW**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS C Loop over quarks (no top quarks) SIGUT1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2) $ *((AMWIW**2-U)*(AMZIZ**2-U)+(AMWIW**2-T)*(AMZIZ**2-T))/4. $ +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW) $ *((AMWIW**2-U)*(AMZIZ**2-U)-(AMWIW**2-T)*(AMZIZ**2-T))/4. $ +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2. PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGUT1=2*G**4/3./PROPW*SIGUT1 SIGUT2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))* $ (AQW(1,JW)*CONJG(AQW(1,JW))) $ *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2 SIGUT3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))* $ (AQW(2,JW)*CONJG(AQW(2,JW))) $ *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2 SGUT12=-G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.* $ REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4. $ +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGUT13=G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.* $ REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4. $ +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGUT23=-4*AMWIW*AMZIZ*S/2./(U-AMQ**2)/(T-AMQ**2)/12.* $ REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW))) SIGUT=SIGUT1+SIGUT2+SIGUT3+SGUT12+SGUT13+SGUT23 C SIGTU1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2) $ *((AMWIW**2-T)*(AMZIZ**2-T)+(AMWIW**2-U)*(AMZIZ**2-U))/4. $ +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW) $ *((AMWIW**2-T)*(AMZIZ**2-T)-(AMWIW**2-U)*(AMZIZ**2-U))/4. $ +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2. SIGTU1=2*G**4/3./PROPW*SIGTU1 SIGTU2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))* $ (AQW(1,JW)*CONJG(AQW(1,JW))) $ *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2 SIGTU3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))* $ (AQW(2,JW)*CONJG(AQW(2,JW))) $ *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2 SGTU12=-G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.* $ REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4. $ +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGTU13=G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.* $ REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))* $ (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4. $ +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.) SGTU23=-4*AMWIW*AMZIZ*S/2./(T-AMQ**2)/(U-AMQ**2)/12.* $ REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW))) SIGTU=SIGTU1+SIGTU2+SIGTU3+SGTU12+SGTU13+SGTU23 IF (IWM.EQ.2) THEN SIG=.5*SIGTU*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,JTYPZ,JTYPW) SIG=.5*SIGTU*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,JTYPZ,JTYPW) SIG=.5*SIGUT*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,JTYPZ,JTYPW) SIG=.5*SIGUT*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,JTYPZ,JTYPW) ELSE SIG=.5*SIGUT*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,JTYPZ,JTYPW) SIG=.5*SIGUT*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,JTYPZ,JTYPW) SIG=.5*SIGTU*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,JTYPZ,JTYPW) SIG=.5*SIGTU*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,JTYPZ,JTYPW) END IF 620 CONTINUE 610 CONTINUE C C Chargino pair production C added squark exchange contribution 7/11/97 C DO 700 IW1=1,4 JW1=(IW1+1)/2 AMWIW1=ABS(AMWISS(JW1)) JTYPW1=IW2JS(IW1) IDW1=IDWSS(IW1) DO 710 IW2=1,4 JW2=(IW2+1)/2 AMWIW2=ABS(AMWISS(JW2)) JTYPW2=IW2JS(IW2) IDW2=IDWSS(IW2) IF (.NOT.(GOQ(JTYPW1,1).AND.GOQ(JTYPW2,2))) GO TO 710 CALL TWOKIN(0.,0.,AMWIW1,AMWIW2) IF (X1.GE.1..OR.X2.GE.1.) GO TO 710 E1=SQRT(P(1)**2+AMWIW1**2) E2=SQRT(P(2)**2+AMWIW2**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS DO 720 IQ1=2,11 IFLQ=IS2UD(IQ1) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IQ2=MATCH(IQ1,4) IF (IQ1.EQ.2.OR.IQ1.EQ.3) AMSQK=AMDLSS IF (IQ1.EQ.4.OR.IQ1.EQ.5) AMSQK=AMULSS IF (IQ1.EQ.6.OR.IQ1.EQ.7) AMSQK=AMCLSS IF (IQ1.EQ.8.OR.IQ1.EQ.9) AMSQK=AMSLSS IF (IQ1.EQ.10.OR.IQ1.EQ.11) AMSQK=AMB1SS IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 720 IF (IDW1.EQ.-IDW2) THEN C Convert ISAJET t_hat to particle-particle t_hat IF (IUD(IQ1)*IDW1.GT.0) THEN TPP=U ELSE TPP=T END IF ZZ=(2*TPP-2*AMWIW1**2+S)/SQRT(S*S-4*S*AMWIW1**2) EHAT=SQRT(S)/2. PHAT=SQRT(EHAT**2-AMWIW1**2) XMGG=16.*ESQ*ESQ*(EHAT**2*(1.+ZZ**2)+ $ AMWIW1**2*(1.-ZZ**2))/S*EQ1**2 XMZZ=16*ESQ*ESQ*CTTHW**2*S/((S-AMZ**2)**2+ $ (GAMZ*AMZ)**2)*((XWI(JW1)**2+YWI(JW1)**2)* $ (AL(IFLQ)**2+BE(IFLQ)**2)* $ (EHAT**2*(1.+ZZ**2)+AMWIW1**2*(1.-ZZ**2))-2.* $ YWI(JW1)**2*(AL(IFLQ)**2+ $ BE(IFLQ)**2)*AMWIW1**2-8*XWI(JW1)*YWI(JW1)* $ AL(IFLQ)*BE(IFLQ)*EHAT*PHAT*ZZ) XMGZ=(-EQ1)*(-32.)*ESQ*ESQ*CTTHW*(S-AMZ**2)/ $ ((S-AMZ**2)**2+(GAMZ*AMZ)**2)* $ (AL(IFLQ)*XWI(JW1)*(EHAT**2* $ (1.+ZZ**2)+AMWIW1**2*(1.-ZZ**2))-2* $ BE(IFLQ)*YWI(JW1)*EHAT*PHAT*ZZ) XMUU=ESQ*ESQ*SIN(GAMMAR)**4*S*(EHAT-PHAT*ZZ)**2/ $ SN2THW**2/(EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+ $ AMSQK**2)**2 XMGU=EQ1*4*ESQ*ESQ*SIN(GAMMAR)**2* $ ((EHAT-PHAT*ZZ)**2+AMWIW1**2)/SN2THW/ $ (EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+AMSQK**2) XMZU=4*ESQ*ESQ*CTTHW*SIN(GAMMAR)**2*(S-AMZ**2) $ *(AL(IFLQ)-BE(IFLQ))*S/SN2THW/((S-AMZ**2)**2+ $ (GAMZ*AMZ)**2)*((XWI(JW1)-YWI(JW1))* $ ((EHAT-PHAT*ZZ)**2+AMWIW1**2)+2*YWI(JW1)* $ AMWIW1**2)/(EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+ $ AMSQK**2) XMDD=ESQ*ESQ*SIN(GAMMAL)**4*S*(EHAT+PHAT*ZZ)**2/ $ SN2THW**2/(EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+ $ AMSQK**2)**2 XMGD=-4*EQ1*ESQ*ESQ*SIN(GAMMAL)**2* $ ((EHAT+PHAT*ZZ)**2+AMWIW1**2)/SN2THW/ $ (EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+AMSQK**2) XMZD=-4*ESQ*ESQ*CTTHW*SIN(GAMMAL)**2*(S-AMZ**2) $ *(AL(IFLQ)-BE(IFLQ))*S/SN2THW/((S-AMZ**2)**2+ $ (GAMZ*AMZ)**2)*((XWI(JW1)+YWI(JW1))* $ ((EHAT+PHAT*ZZ)**2+AMWIW1**2)-2*YWI(JW1)* $ AMWIW1**2)/(EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+ $ AMSQK**2) IF (IFLQ.EQ.1) THEN SIG=(XMGG+XMZZ+XMGZ+XMDD+XMGD+XMZD)/12. ELSE SIG=(XMGG+XMZZ+XMGZ+XMUU+XMGU+XMZU)/12. END IF SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG C IF(SIG.LT.0.AND.ABS(ZZ).GT.0.999) SIG=0 CALL SIGFIL(SIG,IQ1,IQ2,JTYPW1,JTYPW2) ELSEIF (IDW1*IDW2.LT.0) THEN PHAT=SQRT(S*S+AMWIW1**4+AMWIW2**4-2*S*AMWIW1**2 $ -2*S*AMWIW2**2-2*AMWIW1**2*AMWIW2**2)/2./SQRT(S) IF (IUD(IQ1)*IDW1.GT.0) THEN TPP=U ELSE TPP=T END IF IF (IDW1.LT.0) THEN AMWI=AMWIW1 ELSE AMWI=AMWIW2 END IF EHAT=SQRT(PHAT**2+AMWI**2) EBM=SQRT(S)/2. ZZ=(TPP-AMWI**2+SQRT(S)*EHAT)/SQRT(S)/PHAT DEL=(AMW2SS**2-AMW1SS**2)/4./EBM XMZZ=4*(CTTHW+TNTHW)**2/((S-AMZ**2)**2+ $ (GAMZ*AMZ)**2)*((X12**2+Y12**2)* $ (AL(IFLQ)**2+BE(IFLQ)**2)* $ (EBM**2+PHAT**2*ZZ**2-DEL**2-SN12*AMWIW1*AMWIW2)+ $ 2*X12**2*SN12*(AL(IFLQ)**2+ BE(IFLQ)**2)*AMWIW1* $ AMWIW2-8*X12*Y12*AL(IFLQ)*BE(IFLQ)*EBM*PHAT*ZZ) XMUU=SIN(GAMMAR)**2*COS(GAMMAR)**2*((EBM-PHAT*ZZ) $ **2-DEL**2)/SN2THW**2/(2*EBM*(EBM-DEL)-2*EBM*PHAT* $ ZZ+AMSQK**2-AMW1SS**2)**2 XMZU=-2*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)* $ (S-AMZ**2)*(AL(IFLQ)-BE(IFLQ))/SN2THW/((S-AMZ**2) $ **2+(GAMZ*AMZ)**2)*((X12-Y12)*((EBM-PHAT*ZZ)**2- $ DEL**2-SN12*AMWIW1*AMWIW2)+2*X12*SN12*AMWIW1* $ AMWIW2)/(2*EBM*(EBM-DEL)-2*EBM*PHAT*ZZ+AMSQK**2 $ -AMW1SS**2) XMDD=SIN(GAMMAL)**2*COS(GAMMAL)**2*((EBM+PHAT*ZZ) $ **2-DEL**2)/SN2THW**2/(2*EBM*(EBM-DEL)+2*EBM*PHAT* $ ZZ+AMSQK**2-AMW1SS**2)**2 XMZD=-2*THX*(CTTHW+TNTHW)*SIN(GAMMAL)*COS(GAMMAL)* $ (S-AMZ**2)*(AL(IFLQ)-BE(IFLQ))/SN2THW/((S-AMZ**2) $ **2+(GAMZ*AMZ)**2)*((X12+Y12)*((EBM+PHAT*ZZ)**2- $ DEL**2+SN12*AMWIW1*AMWIW2)-2*Y12*SN12*AMWIW1* $ AMWIW2)/(2*EBM*(EBM-DEL)+2*EBM*PHAT*ZZ+AMSQK**2 $ -AMW1SS**2) IF (IFLQ.EQ.1) THEN SIG=ESQ*ESQ*(XMZZ+XMDD+XMZD)*S/12. ELSE SIG=ESQ*ESQ*(XMZZ+XMUU+XMZU)*S/12. END IF SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) SIG=.5*SIG CALL SIGFIL(SIG,IQ1,IQ2,JTYPW1,JTYPW2) END IF 720 CONTINUE 710 CONTINUE 700 CONTINUE C C qk qb --> ziss zjss C DO 800 IZ1=1,4 AMZIZ1=ABS(AMZISS(IZ1)) JTYPZ1=IZ2JS(IZ1) DO 810 IZ2=1,4 AMZIZ2=ABS(AMZISS(IZ2)) JTYPZ2=IZ2JS(IZ2) IF(.NOT.(GOQ(JTYPZ1,1).AND.GOQ(JTYPZ2,2))) GO TO 810 CALL TWOKIN(0.,0.,AMZIZ1,AMZIZ2) IF(X1.GE.1..OR.X2.GE.1.) GO TO 810 E1=SQRT(P(1)**2+AMZIZ1**2) E2=SQRT(P(2)**2+AMZIZ2**2) FAC=1./(16.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS WIJ=SQRT(G**2+GP**2)*ZI**(ITHZ(IZ2))*(-ZI)**(ITHZ(IZ1))* $ (ZMIXSS(1,IZ1)*ZMIXSS(1,IZ2)-ZMIXSS(2,IZ1)* $ ZMIXSS(2,IZ2))/4. RSH=SQRT(S) PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 KK=SQRT(S*S+(AMZIZ1**2-AMZIZ2**2)**2-2*S* $ (AMZIZ1**2+AMZIZ2**2))/2./RSH C Sum over initial quarks (no top quarks) DO 820 IQ=2,11 IQ1=IQ IQ2=MATCH(IQ1,4) AMSQL=AMASS(IDQSS(IQ)) AMSQR=AMASS(IDQSS(IQ+12)) PHAT=SQRT(SSXLAM(S,AMZIZ1**2,AMZIZ2**2))/2./RSH EHAT=SQRT(PHAT**2+AMZIZ1**2) ZZ=(T-AMZIZ1**2+RSH*EHAT)/RSH/PHAT IF (IUD(IQ).LT.0) ZZ=-ZZ IFLQ=IS2UD(IQ) SIGLL=AQZ(IFLQ,IZ1)*CONJG(AQZ(IFLQ,IZ1))*AQZ(IFLQ,IZ2)* $ CONJG(AQZ(IFLQ,IZ2))*SSGT(S,AMSQL,ZZ,IZ1,IZ2) SIGRR=BQZ(IFLQ,IZ1)*CONJG(BQZ(IFLQ,IZ1))*BQZ(IFLQ,IZ2)* $ CONJG(BQZ(IFLQ,IZ2))*SSGT(S,AMSQR,ZZ,IZ1,IZ2) SIGZZ=4*ESQ*WIJ*CONJG(WIJ)*(AL(IFLQ)**2+BE(IFLQ)**2)* $ (S*S-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+ $ ITHZ(IZ2)+1)*S*AMZIZ1*AMZIZ2+4*S*KK*KK*ZZ*ZZ)/PROPZ SIGLZ=-SQRT(ESQ)*(AL(IFLQ)-BE(IFLQ))*(S-AMZ**2)/2./ $ PROPZ*(REAL(WIJ*CONJG(AQZ(IFLQ,IZ1))*AQZ(IFLQ,IZ2))* $ SSGST(S,AMSQL,ZZ,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))* $ REAL(WIJ*AQZ(IFLQ,IZ1)*CONJG(AQZ(IFLQ,IZ2)))* $ SSGST(S,AMSQL,-ZZ,IZ1,IZ2)) SIGRZ=-SQRT(ESQ)*(-1.)**(ITHZ(IZ1)+ITHZ(IZ2)+1)* $ (AL(IFLQ)+BE(IFLQ))*(S-AMZ**2)/2./ $ PROPZ*(REAL(WIJ*CONJG(BQZ(IFLQ,IZ1))*BQZ(IFLQ,IZ2))* $ SSGST(S,AMSQR,ZZ,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))* $ REAL(WIJ*BQZ(IFLQ,IZ1)*CONJG(BQZ(IFLQ,IZ2)))* $ SSGST(S,AMSQR,-ZZ,IZ1,IZ2)) SIG=KK*(SIGLL+SIGRR+SIGZZ+SIGLZ+SIGRZ)/3./PHAT C Below factor of 2 for id particles and jettyp switch SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)/2. IF(SIG.LT.0.AND.ABS(ZZ).GT.0.999) SIG=0 CALL SIGFIL(SIG,IQ1,IQ2,JTYPZ1,JTYPZ2) 820 CONTINUE 810 CONTINUE 800 CONTINUE RETURN END +EOD +DECK,SIGTC SUBROUTINE SIGTC C C Compute the integrated technirho cross section C d(sigma)/d(qmw**2)d(yw) = d(sigma)/d(qmw**2)*f(x1)*f(x2)/scm C including W-technirho mixing from EHLQ 6.22 and 6.23 and C elastic resonance in longitudinal WW fusion. C C Use WTYPE for control with C WTYPE = 2 3 4 C rho+ rho- rho0 C C SIGMA = cross section summed over allowed types. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,QSAVE +CDE,WCON +CDE,CONST +CDE,JETLIM +CDE,HCON +CDE,TCPAR C REAL AMQCUR(6),WTHELI(4),FINT(9),X(2) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1) INTEGER MATCHT(4,4) REAL ACOSH,Z,ATANH,AMASS,QMW2,QMZ,EHAT,ANEFF,Q2SAVE,YHAT,EY,AMW, $AMZ,STRUC,STRUCW,WM,ZM,PWWCM,SIG0,S,T,U,FACINV,RATZ,Q1L,Q1R,SIG1, $SIG,QZW INTEGER I,IH,IQ,IW,IQ1,IQ2,IQ3,IQ4,IRHO,LISTW(4) C DATA AMQCUR/.005,.009,.175,1.25,4.50,30./ DATA LISTW/10,80,-80,90/ DATA MATCHT/0,0,0,0, 0,29,0,27, 0,0,29,28, 0,28,27,0/ C C Functions ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.)) ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z)) C C Kinematics (identical to Drell-Yan) C AMQCUR(6)=AMASS(6) QMW2=QMW**2 QTMW=SQRT(QMW2+QTW**2) Q0W=QTMW*COSH(YW) QZW=QTMW*SINH(YW) QW=SQRT(QZW**2+QTW**2) IF(QW.NE.0.) THEN CTHW=QZW/QW STHW=QTW/QW IF(ABS(CTHW).LT.1.) THEN THW=ACOS(CTHW) ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF ELSE CTHW=0. STHW=1. THW=.5*PI ENDIF EHAT=QMW SHAT=QMW**2 QSQ=SHAT ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2)) Q2SAVE=QSQ YHAT=YW EY=EXP(YHAT) X1=EHAT/ECM*EY X2=EHAT/(ECM*EY) C C Initialize C SIGMA=0. NSIGS=0 DO 100 I=1,MXSIGS 100 SIGS(I)=0 C IF(X1.GE.1..OR.X2.GE.1.) RETURN AMW=WMASS(2) AMZ=WMASS(4) C C Compute structure functions C DO 110 IH=1,2 DO 120 IQ=1,13 120 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) DO 130 IQ=14,26 130 QSAVE(IQ,IH)=0. DO 140 IW=2,4 AMW=AMASS(LISTW(IW)) IF(QMW.GT.2.*AMW) THEN QSAVE(25+IW,IH)=STRUCW(X(IH),IW,IDIN(IH))/X(IH) ELSE QSAVE(25+IW,IH)=0. ENDIF 140 CONTINUE 110 CONTINUE C C qk + qb --> technirho0 C IF(.NOT.((GOQ(27,1).AND.GOQ(28,2)).OR.(GOQ(28,1).AND.GOQ(27,2)))) $GO TO 300 WM=WMASS(2) ZM=WMASS(4) IF(QMW.LE.2.*AMW) GO TO 300 PWWCM=.5*SQRT(QMW**2-4.*WM**2) SIG0=PI*ALFA**2/(72.*SIN2W*S)*(2.*PWWCM/QMW)**3*X1*X2*UNITS SIG0=SIG0*TCMRHO**2/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2) C Initial state sum DO 210 IQ1=2,13 IQ2=MATCH(IQ1,4) IF(IQ2.EQ.0) GO TO 210 FACINV=2.*SQRT(SIN2W*(1.-SIN2W)) RATZ=S/(S-ZM**2) Q1L=AQ(IQ1/2,4)*FACINV Q1R=BQ(IQ1/2,4)*FACINV SIG1=.25*SIG0*(1.-RATZ*Q1L/(Q1R*(1.-SIN2W)) $ +RATZ**2*(Q1L**2+Q1R**2)/(4.*(1-SIN2W)**2)) $ *QSAVE(IQ1,1)*QSAVE(IQ2,2) C Final state sum DO 220 IQ3=27,28 IQ4=MATCHT(IQ3-25,4) IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4) ENDIF 220 CONTINUE 210 CONTINUE C C W+ + W- -> technirho0 -> W+ + W- C SIG0=12*PI/PWWCM**2*TCGRHO**2*X1*X2*UNITS $/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2) C Initial state sum DO 230 IQ1=27,28 IQ2=MATCHT(IQ1-25,4) SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2) C Final state sum DO 240 IQ3=27,28 IQ4=MATCHT(IQ3-25,4) IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4) ENDIF 240 CONTINUE 230 CONTINUE C C q + qbar -> technirho+- C 300 IF(.NOT.((GOQ(27,1).AND.GOQ(29,2)).OR.(GOQ(28,1).AND.GOQ(29,2)) $.OR.(GOQ(29,1).AND.GOQ(27,2)).OR.(GOQ(29,1).AND.GOQ(28,2)))) $GO TO 400 WM=WMASS(2) ZM=WMASS(4) IF(QMW.LE.WM+ZM) GO TO 400 PWWCM=SQRT((S-WM**2-ZM**2)**2-4.*WM**2*ZM**2)/(2.*QMW) SIG0=PI*ALFA**2/(144.*SIN2W)*S/(S-WM**2)**2*(2.*PWWCM/QMW)**3 $*X1*X2*UNITS SIG0=SIG0*TCMRHO**2/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2) DO 310 IRHO=2,3 C Initial state sum DO 320 IQ1=2,13 IQ2=MATCH(IQ1,IRHO) IF(IQ2.EQ.0) GO TO 320 SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2) C Final state sum DO 330 IQ3=27,28 IQ4=MATCHT(IQ3-25,IRHO) IF(IQ4.EQ.0) GO TO 330 IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4) ENDIF 330 CONTINUE 320 CONTINUE 310 CONTINUE C C W+- + Z0 -> technirho+- -> W+- + Z0 C SIG0=12*PI/PWWCM**2*TCGRHO**2*X1*X2*UNITS $/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2) DO 340 IRHO=2,3 C Initial state sum DO 350 IQ1=27,29 IQ2=MATCHT(IQ1-25,IRHO) IF(IQ2.EQ.0) GO TO 350 SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2) C Final state sum DO 360 IQ3=27,29 IQ4=MATCHT(IQ3-25,IRHO) IF(IQ4.EQ.0) GO TO 360 IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2) CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4) ENDIF 360 CONTINUE 350 CONTINUE 340 CONTINUE C 400 RETURN END +EOD +DECK,SIGTC2 SUBROUTINE SIGTC2 C C Compute the techni-rho decay distribution cross section C D(SIGMA)/D(QMW**2)D(YW)D(OMEGA) C for the specified jet types. This is trivial but done for C compatibility with Drell-Yan and Higgs. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,CONST +CDE,JETPAR +CDE,JETSIG +CDE,PJETS +CDE,WSIG +CDE,TCPAR C REAL AM12,AM22,ANGFAC,S,T,U EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) C C Angfac is (1-z**2), and is determined in terms of S,T,U. C Note that both rho+- and rho0 are always elastic. AM12=PJETS(5,1)**2 AM22=PJETS(5,2)**2 ANGFAC=4.*(T*U-AM12*AM22)/((S-AM12-AM22)**2-4.*AM12*AM22) C Differential cross section SIGLLQ=SIGEVT*ANGFAC*3./(8.*PI) RETURN END +EOD +DECK,SIGTC3 SUBROUTINE SIGTC3 C C Calculate angular distributions for W decays from technirho: C d(sigma)/d(qmw**2)d(yw)d(omega)d(omega1)d(omega2) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C +CDE,ITAPES +CDE,QCDPAR +CDE,JETPAR +CDE,PJETS +CDE,PRIMAR +CDE,Q1Q2 +CDE,JETSIG +CDE,WSIG +CDE,WWSIG +CDE,WCON +CDE,CONST +CDE,WWPAR +CDE,TCPAR C EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) INTEGER I,K,IDADDR(4),IW(2) REAL T12(3,3),T34(3,3),FR(3,3),FI(3,3),CPHI12(3),SPHI12(3), $CPHI34(3),SPHI34(3),PFCM(5,4),PWCM(5,2),CHWW,SHWW,TMP,PTW1, $CPHIW1,SPHIW1,PW1,CTHW1,STHW1,CHW1,SHW1,SHWI,TH12,PHI12,TH34, $PHI34,AMV,GAMV,QMH,A12,B12,A34,B34,TVV12,TVA12,COS12,SIN12, $TVV34,TVA34,COS34,SIN34,TCPHI,TSPHI,TC2PHI,TS2PHI,F0,F1,TOTAL, $DIFF,T,U,S C IF(NPAIR.NE.4) RETURN C C Reconstruct W-->FF decay angles C C Initialize PFCM and PWCM DO 10 I=1,4 DO 10 K=1,5 PFCM(K,I)=PPAIR(K,I) 10 CONTINUE DO 11 I=1,2 DO 11 K=1,5 PWCM(K,I)=PJETS(K,I) 11 CONTINUE C C Z boost to WW center of mass CHWW=QWJET(4)/QWJET(5) SHWW=QWJET(3)/QWJET(5) DO 20 I=1,4 TMP=CHWW*PFCM(4,I)-SHWW*PFCM(3,I) PFCM(3,I)=-SHWW*PFCM(4,I)+CHWW*PFCM(3,I) PFCM(4,I)=TMP 20 CONTINUE DO 21 I=1,2 TMP=CHWW*PWCM(4,I)-SHWW*PWCM(3,I) PWCM(3,I)=-SHWW*PWCM(4,I)+CHWW*PWCM(3,I) PWCM(4,I)=TMP 21 CONTINUE C C Rotate W1 to +z axis PTW1=SQRT(PWCM(1,1)**2+PWCM(2,1)**2) CPHIW1=PWCM(1,1)/PTW1 SPHIW1=PWCM(2,1)/PTW1 PW1=SQRT(PTW1**2+PWCM(3,1)**2) CTHW1=PWCM(3,1)/PW1 STHW1=PTW1/PW1 C Z rotation DO 30 I=1,4 TMP=CPHIW1*PFCM(1,I)+SPHIW1*PFCM(2,I) PFCM(2,I)=-SPHIW1*PFCM(1,I)+CPHIW1*PFCM(2,I) PFCM(1,I)=TMP 30 CONTINUE C Y rotation DO 31 I=1,4 TMP=CTHW1*PFCM(1,I)-STHW1*PFCM(3,I) PFCM(3,I)=STHW1*PFCM(1,I)+CTHW1*PFCM(3,I) PFCM(1,I)=TMP 31 CONTINUE C C Boost to W rest frames CHW1=PWCM(4,1)/PWCM(5,1) SHW1=PW1/PWCM(5,1) DO 40 I=1,4 IF(I.LE.2) THEN SHWI=SHW1 ELSE SHWI=-SHW1 ENDIF TMP=CHW1*PFCM(4,I)-SHWI*PFCM(3,I) PFCM(3,I)=-SHWI*PFCM(4,I)+CHW1*PFCM(3,I) PFCM(4,I)=TMP 40 CONTINUE C C Compute angles TH12=ACOS(PFCM(3,1)/SQRT(PFCM(1,1)**2+PFCM(2,1)**2+PFCM(3,1)**2)) PHI12=ATAN2(PFCM(2,1),PFCM(1,1)) TH34=ACOS(PFCM(3,3)/SQRT(PFCM(1,3)**2+PFCM(2,3)**2+PFCM(3,3)**2)) PHI34=ATAN2(PFCM(2,3),PFCM(1,3)) C C Compute decay angular distributions. C DO 100 I=1,4 IDADDR(I)=IABS(IDPAIR(I)) IF(IDADDR(I).GE.11) IDADDR(I)=IDADDR(I)-4 100 CONTINUE IW(1)=JETTYP(1)-25 IW(2)=JETTYP(2)-25 C AMV=PJETS(5,1) GAMV=WGAM(IW(1)) QMH=QMW C COUPLINGS A12=AQ(IDADDR(1),IW(1)) B12=BQ(IDADDR(1),IW(1)) A34=AQ(IDADDR(3),IW(2)) B34=BQ(IDADDR(3),IW(2)) C DECAY DISTRIBUTIONS TVV12=8.*PI*ALFA*(A12**2+B12**2) TVA12=16.*PI*ALFA*A12*B12 COS12=COS(TH12) SIN12=SIN(TH12) T12(1,1)=TVV12*SIN12**2 T12(1,2)=TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2 T12(1,3)=-TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2 T12(2,1)=T12(1,2) T12(2,2)=TVV12*(.5+.5*COS12**2)+TVA12*COS12 T12(2,3)=TVV12*.5*SIN12**2 T12(3,1)=T12(1,3) T12(3,2)=T12(2,3) T12(3,3)=TVV12*(.5+.5*COS12**2)-TVA12*COS12 C TVV34=8.*PI*ALFA*(A34**2+B34**2) TVA34=16.*PI*ALFA*A34*B34 COS34=COS(TH34) SIN34=SIN(TH34) T34(1,1)=TVV34*SIN34**2 T34(1,2)=TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2 T34(1,3)=-TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2 T34(2,1)=T34(1,2) T34(2,2)=TVV34*(.5+.5*COS34**2)+TVA34*COS34 T34(2,3)=TVV34*.5*SIN34**2 T34(3,1)=T34(1,3) T34(3,2)=T34(2,3) T34(3,3)=TVV34*(.5+.5*COS34**2)-TVA34*COS34 C CPHI12(1)=1. CPHI12(2)=COS(PHI12) CPHI12(3)=COS(2.*PHI12) SPHI12(1)=0. SPHI12(2)=SIN(PHI12) SPHI12(3)=SIN(2.*PHI12) CPHI34(1)=1. CPHI34(2)=COS(PHI34) CPHI34(3)=COS(2.*PHI34) SPHI34(1)=0. SPHI34(2)=SIN(PHI34) SPHI34(3)=SIN(2.*PHI34) C TCPHI=CPHI12(2)*CPHI34(2)-SPHI12(2)*SPHI34(2) TSPHI=SPHI12(2)*CPHI34(2)+CPHI12(2)*SPHI34(2) TC2PHI=CPHI12(3)*CPHI34(3)-SPHI12(3)*SPHI34(3) TS2PHI=SPHI12(3)*CPHI34(3)+CPHI12(3)*SPHI34(3) C C Pure technirho --> WW. Calculate angular distribution for C decay and multiply by cross section. C F0=.5*QMH**2/AMV**2-1. F1=1. TOTAL=(8.*PI/3.)**2*TVV12*TVV34*(F0**2+2.*F1**2) DIFF=F0**2*T12(1,1)*T34(1,1) $+F0*F1*(2.*T12(1,2)*T34(1,2)+2.*T12(1,3)*T34(1,3))*TCPHI $+F1**2*(T12(2,2)*T34(1,2)+T12(3,3)*T34(3,3) $ +2.*T12(2,3)*T34(2,3)*TC2PHI) WWSIG=SIGLLQ*DIFF/TOTAL RETURN END +EOD +DECK,SIGWH. SUBROUTINE SIGWH C C Calculate d(sigma)/d(pt**2)d(y1)d(y2) for WH and ZH C associated production. C C SIGMA = cross section summed over types allowed by C JETTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4 C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1 C C Extra factor of 1/2 needed for nonidentical final jets. C Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2 C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,CONST +CDE,JETPAR +CDE,JETSIG +CDE,PRIMAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,WCON +CDE,HCON +CDE,XMSSM C REAL X(2) EQUIVALENCE (X(1),X1) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) REAL SIG,S,T,U,FAC,AMW,AMZ,AMW2,AMZ2,E1,E2 REAL QFCN,STRUC,SIGHW REAL PROPZ,PROPW,GV(2),GA(2),AMH,AMH2,GAMW,GAMZ INTEGER IS2UD(25),IQ,IH,I,IQ1,IQ2,IFLQ SAVE IS2UD C C IS2UD: Susy jettype -> u/d code DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/ C Functions QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C IF (GOMSSM) THEN CALL SIGWHS RETURN END IF C Initialize DO 10 I=1,MXSIGS 10 SIGS(I)=0. SIGMA=0. NSIGS=0 C AMW=WMASS(2) AMW2=AMW**2 AMZ=WMASS(4) AMZ2=AMZ**2 AMH=HMASS AMH2=AMH**2 GAMW=WGAM(2) GAMZ=WGAM(4) GV(1)=.25-2*SIN2W/3. GV(2)=-.25+SIN2W/3. GA(1)=-.25 GA(2)=.25 C C WH production via W-* C IF (GOQ(28,1).AND.GOQ(30,2)) THEN CALL TWOKIN(0.,0.,AMW,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 100 E1=SQRT(P(1)**2+AMW**2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(3,1) SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,28,30) SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,28,30) SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,28,30) SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,28,30) 100 CONTINUE END IF C IF (GOQ(30,1).AND.GOQ(28,2)) THEN CALL TWOKIN(0.,0.,AMH,AMW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 110 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMW**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(3,2) SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,30,28) SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,30,28) SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,30,28) SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,30,28) 110 CONTINUE END IF C C C WH production via W+* C IF (GOQ(27,1).AND.GOQ(30,2)) THEN CALL TWOKIN(0.,0.,AMW,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 120 E1=SQRT(P(1)**2+AMW**2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(2,1) SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,27,30) SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,27,30) SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,27,30) SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,27,30) 120 CONTINUE END IF C IF (GOQ(30,1).AND.GOQ(27,2)) THEN CALL TWOKIN(0.,0.,AMH,AMW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 130 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMW**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(2,2) SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,30,27) SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,30,27) SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,30,27) SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,30,27) 130 CONTINUE END IF C C ZH production via Z* C IF (GOQ(29,1).AND.GOQ(30,2)) THEN CALL TWOKIN(0.,0.,AMZ,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 200 E1=SQRT(P(1)**2+AMZ2) E2=SQRT(P(2)**2+AMH2) FAC=1./(3.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 210 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 210 SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)* $ (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,1) SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,29,30) 210 CONTINUE 200 CONTINUE END IF C HZ production via Z* C IF (GOQ(30,1).AND.GOQ(29,2)) THEN CALL TWOKIN(0.,0.,AMH,AMZ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 220 E1=SQRT(P(1)**2+AMH2) E2=SQRT(P(2)**2+AMZ2) FAC=1./(3.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 230 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230 SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)* $ (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,2) SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,30,29) 230 CONTINUE 220 CONTINUE END IF RETURN END +EOD +DECK,SIGWHS. SUBROUTINE SIGWHS C C Calculate d(sigma)/d(pt**2)d(y1)d(y2) for C Wh, WH, Zh, ZH, hA, HA and H+H- production in SUSY C C SIGMA = cross section summed over types allowed by C JETTYPE cards. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4 C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1 C C Extra factor of 1/2 needed for nonidentical final jets. C Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2 C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,CONST +CDE,JETPAR +CDE,JETSIG +CDE,PRIMAR +CDE,Q1Q2 +CDE,QCDPAR +CDE,WCON +CDE,SSPAR C REAL X(2) EQUIVALENCE (X(1),X1) EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT) REAL SIG,S,T,U,FAC,AMW,AMZ,AMW2,AMZ2,E1,E2,EQ1 REAL QFCN,STRUC,SIGHW,SCFAC,BETA,SINW,COS2W REAL PROPZ,PROPW,GV(2),GA(2),AMH,GAMW,GAMZ INTEGER IS2UD(25),IQ,IH,I,IQ1,IQ2,IFLQ SAVE IS2UD C C IS2UD: Susy jettype -> u/d code DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/ C Functions QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C C Initialize DO 10 I=1,MXSIGS 10 SIGS(I)=0. SIGMA=0. NSIGS=0 C BETA=ATAN(1./RV2V1) AMW=WMASS(2) AMW2=AMW**2 AMZ=WMASS(4) AMZ2=AMZ**2 GAMW=WGAM(2) GAMZ=WGAM(4) GV(1)=.25-2*SIN2W/3. GV(2)=-.25+SIN2W/3. GA(1)=-.25 GA(2)=.25 SINW=SQRT(SIN2W) THW=ASIN(SINW) COS2W=COS(2*THW) DO IH=81,82 IF (IH.EQ.81) THEN SCFAC=SIN(ALFAH+BETA)**2 AMH=AMHL ELSE SCFAC=COS(ALFAH+BETA)**2 AMH=AMHH END IF C C Wh, WH production via W-* C IF (GOQ(79,1).AND.GOQ(IH,2)) THEN CALL TWOKIN(0.,0.,AMW,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 100 E1=SQRT(P(1)**2+AMW**2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(3,1)*SCFAC SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,79,IH) SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,79,IH) SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,79,IH) SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,79,IH) 100 CONTINUE END IF C IF (GOQ(IH,1).AND.GOQ(79,2)) THEN CALL TWOKIN(0.,0.,AMH,AMW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 110 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMW**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(3,2)*SCFAC SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2) CALL SIGFIL(SIG,3,4,IH,79) SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2) CALL SIGFIL(SIG,4,3,IH,79) SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2) CALL SIGFIL(SIG,9,6,IH,79) SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2) CALL SIGFIL(SIG,6,9,IH,79) 110 CONTINUE END IF C C C Wh, WH production via W+* C IF (GOQ(78,1).AND.GOQ(IH,2)) THEN CALL TWOKIN(0.,0.,AMW,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 120 E1=SQRT(P(1)**2+AMW**2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(2,1)*SCFAC SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,78,IH) SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,78,IH) SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,78,IH) SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,78,IH) 120 CONTINUE END IF C IF (GOQ(IH,1).AND.GOQ(78,2)) THEN CALL TWOKIN(0.,0.,AMH,AMW) IF(X1.GE.1..OR.X2.GE.1.) GO TO 130 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMW**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPW=(S-AMW**2)**2+AMW**2*GAMW**2 SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/ $ PROPW*TBRWW(2,2)*SCFAC SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2) CALL SIGFIL(SIG,2,5,IH,78) SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2) CALL SIGFIL(SIG,5,2,IH,78) SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2) CALL SIGFIL(SIG,8,7,IH,78) SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2) CALL SIGFIL(SIG,7,8,IH,78) 130 CONTINUE END IF C C Zh, ZH production via Z* C IF (GOQ(80,1).AND.GOQ(IH,2)) THEN CALL TWOKIN(0.,0.,AMZ,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 200 E1=SQRT(P(1)**2+AMZ2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(3.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 210 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 210 SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)* $ (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,1)*SCFAC SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,80,IH) 210 CONTINUE 200 CONTINUE END IF C hZ, HZ production via Z* C IF (GOQ(IH,1).AND.GOQ(80,2)) THEN CALL TWOKIN(0.,0.,AMH,AMZ) IF(X1.GE.1..OR.X2.GE.1.) GO TO 220 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMZ2) FAC=1./(3.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 230 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230 SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)* $ (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,2)*SCFAC SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IH,80) 230 CONTINUE 220 CONTINUE END IF C C Next, do Ah and AH production C IF (GOQ(83,1).AND.GOQ(IH,2)) THEN CALL TWOKIN(0.,0.,AMHA,AMH) IF(X1.GE.1..OR.X2.GE.1.) GO TO 240 E1=SQRT(P(1)**2+AMHA**2) E2=SQRT(P(2)**2+AMH**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 250 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 250 SIG=GF**2*AMZ**4*(GV(IFLQ)**2+GA(IFLQ)**2)* $ ((AMHA**2+U-T-AMH**2)*(AMHA**2+T-U-AMH**2)- $ S*(2*AMHA**2+2*AMH**2-S))/PROPZ*SCFAC SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,83,IH) 250 CONTINUE 240 CONTINUE END IF IF (GOQ(IH,1).AND.GOQ(83,2)) THEN CALL TWOKIN(0.,0.,AMH,AMHA) IF(X1.GE.1..OR.X2.GE.1.) GO TO 260 E1=SQRT(P(1)**2+AMH**2) E2=SQRT(P(2)**2+AMHA**2) FAC=1./(12.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 270 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 270 SIG=GF**2*AMZ**4*(GV(IFLQ)**2+GA(IFLQ)**2)* $ ((AMHA**2+U-T-AMH**2)*(AMHA**2+T-U-AMH**2)- $ S*(2*AMHA**2+2*AMH**2-S))/PROPZ*SCFAC SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,IH,83) 270 CONTINUE 260 CONTINUE END IF END DO C C Next, do H+H- production C IF (GOQ(84,1).AND.GOQ(85,2)) THEN CALL TWOKIN(0.,0.,AMHC,AMHC) IF(X1.GE.1..OR.X2.GE.1.) GO TO 300 E1=SQRT(P(1)**2+AMHC**2) E2=SQRT(P(2)**2+AMHC**2) FAC=1./(96.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 310 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 310 SIG=((4*PI*ALFA)**2*EQ1**2/S/S+32*PI*ALFA*EQ1*GF*AMZ**2* $ COS2W*GV(IFLQ)*(S-AMZ**2)/S/PROPZ/SQRT2+8*GF**2* $ AMZ**4*COS2W**2*(GV(IFLQ)**2+GA(IFLQ)**2)/PROPZ)* $ ((U-T)*(T-U)-S*(4*AMHC**2-S)) SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,84,85) 310 CONTINUE 300 CONTINUE END IF IF (GOQ(85,1).AND.GOQ(84,2)) THEN CALL TWOKIN(0.,0.,AMHC,AMHC) IF(X1.GE.1..OR.X2.GE.1.) GO TO 320 E1=SQRT(P(1)**2+AMHC**2) E2=SQRT(P(2)**2+AMHC**2) FAC=1./(96.*PI*S**2) FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2 DO 330 IQ1=2,11 IFLQ=IS2UD(IQ1) IQ2=MATCH(IQ1,4) IF (IFLQ.EQ.1) THEN EQ1=2./3. ELSE EQ1=-1./3. END IF IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 330 SIG=((4*PI*ALFA)**2*EQ1**2/S/S+32*PI*ALFA*EQ1*GF*AMZ**2* $ COS2W*GV(IFLQ)*(S-AMZ**2)/S/PROPZ/SQRT2+8*GF**2* $ AMZ**4*COS2W**2*(GV(IFLQ)**2+GA(IFLQ)**2)/PROPZ)* $ ((U-T)*(T-U)-S*(4*AMHC**2-S)) SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2) CALL SIGFIL(SIG,IQ1,IQ2,85,84) 330 CONTINUE 320 CONTINUE END IF RETURN END +EOD +DECK,SIGWW. SUBROUTINE SIGWW C C Calculate D(SIGMA)/D(PT**2)D(Y1)D(Y2) for QK+QB-->W+W C summed over W types allowed on JETTYPE cards and C including branching ratio implied by WMODE cards. C C SIGMA = cross section summed over quark types allowed by C JETTYPE card. C SIGS(I) = partial cross section for I1 + I2 --> I3 + I4. C INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1 C using JETTYPE code. C C Cross sections from Brown and Mikaelian, C Phys Rev D19, 922, D20, 1164. C Include extra factor of 1/2 for double counting. C C Double precision needed for 32-bit machines. C C Ver. 6.22: Modified to used W + GM decay distributions from C Cortes, Hagiwara, and Herzog, NP B278, 26 (1986) C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,QCDPAR. +CDE,JETPAR. +CDE,PRIMAR. +CDE,Q1Q2. +CDE,JETSIG. +CDE,CONST. +CDE,QSAVE. +CDE,WCON. +CDE,WWPAR. C DIMENSION X(2),LISTW(4),QSGN(6) EQUIVALENCE (X(1),X1) EQUIVALENCE (S,SWW),(T,TWW),(U,UWW) +SELF,IF=SINGLE. REAL S,T,U,TX,UX,TT,UU $,WWA,WWI,WWE,WZA,WZI,WZE,TERM $,GA,GI,GE,GJ,GZ +SELF,IF=DOUBLE. DOUBLE PRECISION S,T,U,TX,UX,TT,UU $,WWA,WWI,WWE,WZA,WZI,WZE,TERM $,GA,GI,GE,GJ,GZ +SELF. REAL WM2S,ZM2S,X,STRUC,FJAC,SGN,QSGN,SIG,FACTOR,EQ3(12) INTEGER I,IH,IQ,IW1,IW2,JW,JZ,IW,IQ1,IQ2,JG,LISTW,IFOUR INTEGER IFLI,IFLJ LOGICAL LQK1 C DATA LISTW/10,80,-80,90/ DATA QSGN/1.,-1.,-1.,1.,-1.,1./ DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./ C C Functions for W+W- WWA(S,T,U)=(U*T/WM2**2-1.)*(.25-WM2/S+3.*(WM2/S)**2)+S/WM2-4. WWI(S,T,U)=(U*T/WM2**2-1.)*(.25-.5*WM2/S-WM2**2/(S*T)) $+S/WM2-2.+2.*WM2/T WWE(S,T,U)=(U*T/WM2**2-1.)*(.25+(WM2/T)**2)+S/WM2 C Functions for W+-Z0 WZA(S,T,U)=(U*T/(WM2*ZM2)-1.)*(.25-(WM2+ZM2)/(2.*S) $+((WM2+ZM2)**2+8.*WM2*ZM2)/(4.*S**2)) $+(WM2+ZM2)/(WM2*ZM2)*(.5*S-WM2-ZM2+(WM2-ZM2)**2/(2.*S)) WZI(S,T,U)=.25*(U*T/(WM2*ZM2)-1.)*(1.-(WM2+ZM2)/S $-4.*WM2*ZM2/(S*T)) $+(WM2+ZM2)/(2.*WM2*ZM2)*(S-WM2-ZM2+2.*WM2*ZM2/T) WZE(S,T,U)=.25*(U*T/(WM2*ZM2)-1.)+.5*S*(WM2+ZM2)/(WM2*ZM2) C C Initialize DO 10 I=1,MXSIGS 10 SIGS(I)=0. SIGMA=0. NSIGS=0 C C Convention is that even for double precision single C precision mass is exact. WM2=WMASS(2) WM2=WM2**2 ZM2=WMASS(4) ZM2=ZM2**2 C Also need single precision mass**2. WM2S=WM2 ZM2S=ZM2 C C W+ W- pairs C IF(.NOT.((GOQ(2,1).AND.GOQ(3,2)).OR.(GOQ(3,1).AND.GOQ(2,2)))) $GO TO 200 CALL WWKIN(WMASS(2),WMASS(2)) IF(X1.GE.1..OR.X2.GE.1.) GO TO 200 DO 110 IH=1,2 DO 110 IQ=2,9 110 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) FJAC=S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+WM2S)*(P(2)**2+WM2S)) FJAC=.5*FJAC C Sum over jet1 = W+ and jet2 = W+. C Swap t and u in latter case. DO 120 IW1=2,3 IW2=5-IW1 IF(.NOT.(GOQ(IW1,1).AND.GOQ(IW2,2))) GO TO 120 IF(IW1.EQ.3) GO TO 121 TX=T UX=U GO TO 122 121 TX=U UX=T C C Sum over quarks, swapping t and u for negative charge. 122 DO 130 IQ=1,4 GA=2.*(AQDP(IQ,1)+EZDP*AQDP(IQ,4)*S/(S-ZM2))**2 $+2.*(EZDP*BQDP(IQ,4)*S/(S-ZM2))**2 GI=8.*(AQDP(IQ,1)+EZDP*(AQDP(IQ,4)+BQDP(IQ,4))*S/(S-ZM2)) $*(AQDP(IQ,2))**2 GE=16.*(AQDP(IQ,2))**4 SGN=QSGN(IQ) IF(SGN.LT.0.) GO TO 131 TT=TX UU=UX GO TO 132 131 TT=UX UU=TX 132 SIG=QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC*TBRWW(IW1,1)*TBRWW(IW2,2) $*(GA*WWA(S,TT,UU)-SGN*GI*WWI(S,TT,UU)+GE*WWE(S,TT,UU)) CALL SIGFIL(SIG,2*IQ,2*IQ+1,IW1,IW2) SIG=QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC*TBRWW(IW1,1)*TBRWW(IW2,2) $*(GA*WWA(S,UU,TT)-SGN*GI*WWI(S,UU,TT)+GE*WWE(S,UU,TT)) CALL SIGFIL(SIG,2*IQ+1,2*IQ,IW1,IW2) 130 CONTINUE 120 CONTINUE C C Z0 Z0 pairs C 200 IF(.NOT.(GOQ(4,1).AND.GOQ(4,2))) GO TO 300 CALL WWKIN(WMASS(4),WMASS(4)) IF(X1.GE.1..OR.X2.GE.1.) RETURN DO 210 IH=1,2 DO 210 IQ=2,9 210 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C Jacobean -- including factor of 1/2 for identical particles. FJAC=.5*S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+ZM2S)*(P(2)**2+ZM2S)) DO 220 IQ=1,4 GZ=2.*(AQDP(IQ,4)**4+BQDP(IQ,4)**4 $+6.*AQDP(IQ,4)**2*BQDP(IQ,4)**2) FACTOR=(T/U+U/T+4.*ZM2*S/(T*U)-ZM2**2*(1./T**2+1./U**2)) FACTOR=FACTOR*FJAC*GZ*TBRWW(4,1)*TBRWW(4,2) SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2) CALL SIGFIL(SIG,2*IQ,2*IQ+1,4,4) SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2) CALL SIGFIL(SIG,2*IQ+1,2*IQ,4,4) 220 CONTINUE C C W+- Z0 pairs C C JW and JZ are W+- and Z0 jet numbers. 300 DO 310 JW=1,2 JZ=3-JW IF(.NOT.((GOQ(2,JW).OR.GOQ(3,JW)).AND.GOQ(4,JZ))) GO TO 310 C C Must swap t and u if JW=2. IF(JW.EQ.1) THEN CALL WWKIN(WMASS(2),WMASS(4)) TX=T UX=U FJAC=S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) FJAC=.5*FJAC FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+WM2S)*(P(2)**2+ZM2S)) ELSE CALL WWKIN(WMASS(4),WMASS(2)) TX=U UX=T FJAC=S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) FJAC=.5*FJAC FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+ZM2S)*(P(2)**2+WM2S)) ENDIF IF(X1.GE.1..OR.X2.GE.1.) GO TO 310 DO 320 IH=1,2 DO 320 IQ=1,9 320 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C C Sum over W+ and W- DO 340 IW=2,3 IF(IW.EQ.2) THEN SGN=+1 ELSE SGN=+1 ENDIF C C Sum over quarks, swapping t and u as needed. DO 350 IQ1=2,9 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 350 IQ=IQ1/2 IF(2*IQ.EQ.IQ1) THEN LQK1=.TRUE. ELSE LQK1=.FALSE. ENDIF IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN TT=TX UU=UX IFLI=IQ1/2 IFLJ=IQ2/2 ELSE TT=UX UU=TX IFLI=IQ2/2 IFLJ=IQ1/2 ENDIF C GA=AQDP(IQ,IW)*EZDP*S/(S-WM2) GI=AQDP(IQ,IW)*(AQDP(IFLI,4)+BQDP(IFLI,4)) GJ=AQDP(IQ,IW)*(AQDP(IFLJ,4)+BQDP(IFLJ,4)) TERM=GA**2*WZA(S,TT,UU) TERM=TERM+2.*GA*SGN*(-GJ*WZI(S,TT,UU)+GI*WZI(S,UU,TT)) TERM=TERM+(GI-GJ)**2*WZE(S,TT,UU) TERM=TERM+GI**2*(UU*TT-WM2*ZM2)/UU**2 $ +2.*GI*GJ*S*(WM2+ZM2)/(TT*UU)+GJ**2*(UU*TT-WM2*ZM2)/TT**2 TERM=TERM*4.*FJAC*QSAVE(IQ1,1)*QSAVE(IQ2,2) TERM=TERM*TBRWW(IW,JW)*TBRWW(4,JZ) SIG=TERM IF(JW.EQ.1) THEN CALL SIGFIL(SIG,IQ1,IQ2,IW,4) ELSE CALL SIGFIL(SIG,IQ1,IQ2,4,IW) ENDIF 350 CONTINUE 340 CONTINUE 310 CONTINUE C C W+- GM pairs. C 400 DO 410 JW=1,2 JG=3-JW IF(.NOT.((GOQ(2,JW).OR.GOQ(3,JW)).AND.GOQ(1,JG))) GO TO 410 C C Must swap t and u if JW=2. IF(JW.EQ.1) THEN CALL WWKIN(WMASS(2),0.) TX=T UX=U FJAC=S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/S**2 FJAC=.5*FJAC FJAC=FJAC*P(1)/SQRT(P(1)**2+WM2S) ELSE CALL WWKIN(0.,WMASS(2)) TX=U UX=T FJAC=S/SCM*UNITS FJAC=FJAC*PI*ALFA**2/S**2 FJAC=.5*FJAC FJAC=FJAC*P(2)/SQRT(P(2)**2+WM2S) ENDIF C IF(X1.GE.1..OR.X2.GE.1.) GO TO 410 DO 420 IH=1,2 DO 420 IQ=1,9 420 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) C C Sum over W+ and W- DO 440 IW=2,3 C C Sum over quarks, swapping t and u as needed. DO 450 IQ1=2,9 IQ2=MATCH(IQ1,IW) IF(IQ2.EQ.0) GO TO 450 IQ=IQ1/2 IF(2*IQ.EQ.IQ1) THEN LQK1=.TRUE. ELSE LQK1=.FALSE. ENDIF IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN TT=TX UU=UX ELSE TT=UX UU=TX ENDIF C SIG=TBRWW(IW,JW)/(6.*SIN2W)*(-1./3.+UU/(TT+UU))**2 $ *(UU**2+TT**2+2.*S*WM2)/(TT*UU) SIG=SIG*FJAC*QSAVE(IQ1,1)*QSAVE(IQ2,2) IF(JW.EQ.1) CALL SIGFIL(SIG,IQ1,IQ2,IW,1) IF(JW.EQ.2) CALL SIGFIL(SIG,IQ1,IQ2,1,IW) 450 CONTINUE 440 CONTINUE 410 CONTINUE C C Z0 GM pairs C IF (GOQ(4,1).AND.GOQ(1,2)) THEN CALL WWKIN(WMASS(4),0.) IF(X1.GE.1..OR.X2.GE.1.) GO TO 500 DO 510 IH=1,2 DO 510 IQ=2,9 510 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) FJAC=S/SCM*P(1)/SQRT(P(1)**2+ZM2S)*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) DO 520 IQ=1,4 GZ=AQDP(IQ,4)**2+(AQDP(IQ,4)-BQDP(IQ,4))**2 FACTOR=(S**2+ZM2**2)/2./T/U+1. FACTOR=(EQ3(IQ)/3.)**2*FACTOR*FJAC*GZ*TBRWW(4,1) SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2) CALL SIGFIL(SIG,2*IQ,2*IQ+1,4,1) SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2) CALL SIGFIL(SIG,2*IQ+1,2*IQ,4,1) 520 CONTINUE 500 CONTINUE END IF C IF (GOQ(1,1).AND.GOQ(4,2)) THEN CALL WWKIN(0.,WMASS(4)) IF(X1.GE.1..OR.X2.GE.1.) GO TO 600 DO 610 IH=1,2 DO 610 IQ=2,9 610 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) FJAC=S/SCM*P(2)/SQRT(P(2)**2+ZM2S)*UNITS FJAC=FJAC*PI*ALFA**2/(3.*S**2) DO 620 IQ=1,4 GZ=AQDP(IQ,4)**2+(AQDP(IQ,4)-BQDP(IQ,4))**2 FACTOR=(S**2+ZM2**2)/2./T/U+1. FACTOR=(EQ3(IQ)/3.)**2*FACTOR*FJAC*GZ*TBRWW(4,2) SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2) CALL SIGFIL(SIG,2*IQ,2*IQ+1,1,4) SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2) CALL SIGFIL(SIG,2*IQ+1,2*IQ,1,4) 620 CONTINUE 600 CONTINUE END IF C RETURN END +EOD +DECK,SIGWW2. SUBROUTINE SIGWW2 C C Calculate WPAIR decay distribution C D(SIGMA)/D(PT**2)D(Y1)D(Y2)D(OMEGA1)D(OMEGA2) C for modes selected in WPAIR. C C Also fix the initial parton types to those selected. C C Cross sections from SCHOONSCHIP (1980) neglecting W width C and quark masses. Hence use zero-mass vectors PZERO from C WPAIR to define kinematics. C QK(P1) + QB(P2) --> W1(P3) + W2(P4) C W1(P3) --> QK(Q1) + QB(Q2) C W2(P4) --> QK(Q3) + QB(Q4) C S=(P3+P4)**2, T=(P3-P1)**2, U=(P3-P2)**2 C S1=(Q1+P4)**2, T1=(Q1-P1)**2, U1=(Q1-P2)**2 C S3=(Q3+P3)**2, T3=(Q3-P2)**2, U3=(Q3-P1)**2 C S13=(Q1+Q3)**2 C Note that the W+- final couplings have been set equal to 1. C in the SCHOONSCHIP formulas and must be restored. C C Need double precision for 32-bit machines. C C Ver. 5.35 - correct symmetrization for DN DB -> W+ W-. C Ver. 6.22 - use W + GM decay distributions from C Cortes, Hagiwara, and Herzog, NP B278, 26 (1986) C +SELF,IF=IMPNONE. IMPLICIT NONE +SELF. +CDE,ITAPES +CDE,QCDPAR. +CDE,JETPAR. +CDE,PRIMAR. +CDE,Q1Q2. +CDE,CONST. +CDE,QSAVE. +CDE,WCON. +CDE,PJETS. +CDE,PINITS +CDE,WWSIG. +CDE,WWPAR. C DIMENSION P1(5),P2(5),QSGN(6),PP1(4),PP2(4) EQUIVALENCE (S,SWW),(T,TWW),(U,UWW) EQUIVALENCE (P1(1),P1WW(1)),(P2(1),P2WW(1)) C Double precision kinematics for 32-bit. +SELF,IF=SINGLE. REAL S,T,U,T1,U1,T3,U3,P1,P2 1,TX,UX,TT,UU,TT1,UU1,TT3,UU3,PP1,PP2 REAL TERM,WWSS,WWST,WWTT,ZZALL,WZSS,WZST,WZSU,WZTU 1,WGSS,WGST,WGSU,WGTU +SELF,IF=DOUBLE. DOUBLE PRECISION S,T,U,T1,U1,T3,U3,P1,P2 1,TX,UX,TT,UU,TT1,UU1,TT3,UU3,PP1,PP2 DOUBLE PRECISION TERM,WWSS,WWST,WWTT,ZZALL,WZSS,WZST,WZSU,WZTU 1,WGSS,WGST,WGSU,WGTU +SELF. REAL P3IS3,P3IS4,FJAC,AMW1,AMW2,GAM1,GAM2,SGN,QSGN,AMASS3 REAL P1DQ2,P2DQ1 REAL A1,B1,A2,B2,ES,SMS,SMSZG,EQ3(12) REAL Q(5),QB(5),KK(5),E(5),EB(5) INTEGER K,JQ1,JQ3,JW1,JW2,IW1,IW2,IQ1,IQ2,IQ,ISWAPQ,JW,JZ,ISGN INTEGER IFLI,IFLJ,JG,IL,IW LOGICAL LQK1 C DATA QSGN/1.,-1.,-1.,1.,-1.,1./ DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./ C C Entry C ES=4*PI*ALFA WWSIG=0. IF(IDJETS(1).EQ.10.OR.IDJETS(2).EQ.10) GO TO 2 C Normal case IF((IDJETS(1).EQ.80.AND.IDJETS(2).EQ.-80).OR. $(IDJETS(1).EQ.90.AND.IDJETS(2).EQ.90).OR. $(IABS(IDJETS(1)).EQ.80.AND.IDJETS(2).EQ.90)) THEN DO 10 K=1,4 P3(K)=P3WW(K) Q1(K)=PZERO(K,1) Q3(K)=PZERO(K,3) 10 CONTINUE P3IS3=1. P3IS4=0. JQ1=1 JQ3=3 JW1=1 JW2=2 TX=T UX=U C Crossed case ELSE DO 20 K=1,4 P3(K)=P4WW(K) Q1(K)=PZERO(K,3) Q3(K)=PZERO(K,1) 20 CONTINUE P3IS3=0. P3IS4=1. JQ1=3 JQ3=1 JW1=2 JW2=1 TX=U UX=T ENDIF C Variables T1=-2.*(Q1(4)*P1(4)-Q1(1)*P1(1)-Q1(2)*P1(2)-Q1(3)*P1(3)) U1=-2.*(Q1(4)*P2(4)-Q1(1)*P2(1)-Q1(2)*P2(2)-Q1(3)*P2(3)) T3=-2.*(Q3(4)*P2(4)-Q3(1)*P2(1)-Q3(2)*P2(2)-Q3(3)*P2(3)) U3=-2.*(Q3(4)*P1(4)-Q3(1)*P1(1)-Q3(2)*P1(2)-Q3(3)*P1(3)) S13=2.*(Q1(4)*Q3(4)-Q1(1)*Q3(1)-Q1(2)*Q3(2)-Q1(3)*Q3(3)) C Jacobean for 4-body cross section in terms of squared C matrix exement in narrow resonance approximation-- C 1/((P**2-M**2)**2+M**2*GAM**2)=1/(2*M*GAM)*DELTA(P**2-M**2) FJAC=S/SCM*UNITS FJAC=FJAC*ALFA**4/(256.*PI*3.*S**2) AMW1=PJETS(5,1) AMW2=PJETS(5,2) GAM1=WGAM(JETTYP(1)) GAM2=WGAM(JETTYP(2)) FJAC=FJAC/(AMW1*GAM1*AMW2*GAM2) FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+AMW1**2)*(P(2)**2+AMW2**2)) C Color factor IF(IABS(IDPAIR(1)).LT.10) FJAC=3.*FJAC IF(IABS(IDPAIR(3)).LT.10) FJAC=3.*FJAC C C W+ W- pair decays C Standard order is UP + UB --> W+ + W- C IF(.NOT.((JETTYP(1).EQ.2.AND.JETTYP(2).EQ.3).OR.(JETTYP(1).EQ.3 1.AND.JETTYP(2).EQ.2))) GO TO 200 FJAC=.5*FJAC*AQ(2,2)**4 C C Select W+ W- OR W- W+, swapping T and U for latter. IW1=JETTYP(1) IW2=JETTYP(2) C C Select quarks IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 CQ=AQDP(IQ,2)**2 CV=AQDP(IQ,1)/S+EZDP*AQDP(IQ,4)/(S-ZM2) CA=EZDP*BQDP(IQ,4)/(S-ZM2) SGN=QSGN(IQ) ISWAPQ=1 IF(SGN.LT.0.) ISWAPQ=-1 IF(ISWAPQ.GT.0) THEN TT=TX UU=UX TT1=T1 UU1=U1 TT3=T3 UU3=U3 DO 122 K=1,4 PP1(K)=P1(K) PP2(K)=P2(K) P3(K)=P3IS3*P3WW(K)+P3IS4*P4WW(K) Q1(K)=PZERO(K,JQ1) Q3(K)=PZERO(K,JQ3) 122 CONTINUE ELSE TT=UX UU=TX TT1=U3 UU1=T3 TT3=U1 UU3=T1 DO 123 K=1,4 PP1(K)=P1(K) PP2(K)=P2(K) P3(K)=P3IS4*P3WW(K)+P3IS3*P4WW(K) Q1(K)=PZERO(K,JQ3) Q3(K)=PZERO(K,JQ1) 123 CONTINUE ENDIF C IF(IQ1.EQ.2*IQ) THEN TERM=WWTT(TT,UU,TT1,UU1,TT3,UU3) TERM=TERM-SGN*WWST(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2) TERM=TERM+WWSS(TT,UU,TT1,UU1,TT3,UU3) WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC ELSE TERM=WWTT(UU,TT,UU1,TT1,UU3,TT3) TERM=TERM-SGN*WWST(UU,TT,UU1,TT1,UU3,TT3,PP2,PP1) TERM=TERM+WWSS(UU,TT,UU1,TT1,UU3,TT3) WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC ENDIF C RETURN C C Z0 Z0 pair decays C Standard order is UP + UB --> Z0 + Z0 C 200 IF(.NOT.(JETTYP(1).EQ.4.AND.JETTYP(2).EQ.4)) GO TO 300 FJAC=.5*FJAC C C Select quarks IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 CV=AQDP(IQ,4)**2+BQDP(IQ,4)**2 CA=2.*AQDP(IQ,4)*BQDP(IQ,4) CV1=AQDP(JQWW(1),4)**2+BQDP(JQWW(1),4)**2 CA1=2.*AQDP(JQWW(1),4)*BQDP(JQWW(1),4) CV3=AQDP(JQWW(2),4)**2+BQDP(JQWW(2),4)**2 CA3=2.*AQDP(JQWW(2),4)*BQDP(JQWW(2),4) C TERM=ZZALL(TX,UX,T1,U1,T3,U3,P1,P2) IF(INITYP(1).EQ.2*IQ) THEN WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC ELSE WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC ENDIF C RETURN C C W+- Z0 pair decays C Standard order is DN + UB --> W- + Z0 C 300 JW=JW1 JZ=JW2 ISGN=-ISIGN(1,IDJETS(JW)) SGN=ISGN CV3=AQDP(JQWW(JZ),4)**2+BQDP(JQWW(JZ),4)**2 CA3=2.*AQDP(JQWW(JZ),4)*BQDP(JQWW(JZ),4) FJAC=.5*FJAC*AQ(1,2)**2 C C Select quarks. Formulas are for DN UB --> W- Z0. C Use symmetry for other cases. IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 C Find whether IQ1 should be fermion or antifermion. IF(IQ1.EQ.2*(IQ1/2)) THEN ISWAPQ=+1 IFLI=IQ1/2 IFLJ=IQ2/2 ELSE ISWAPQ=-1 IFLI=IQ2/2 IFLJ=IQ1/2 ENDIF C CS=AQDP(IQ,JETTYP(JW))*EZDP/(S-WM2) CT=AQDP(IQ,JETTYP(JW))*(AQDP(IFLJ,4)+BQDP(IFLJ,4)) CU=AQDP(IQ,JETTYP(JW))*(AQDP(IFLI,4)+BQDP(IFLI,4)) C C SWAP T AND U AS NEEDED IF(ISWAPQ*ISGN.GT.0) THEN TT=TX UU=UX TT1=T1 UU1=U1 TT3=T3 UU3=U3 DO 321 K=1,4 PP1(K)=P1(K) PP2(K)=P2(K) 321 CONTINUE ELSE TT=UX UU=TX TT1=U1 UU1=T1 TT3=U3 UU3=T3 DO 323 K=1,4 PP1(K)=P2(K) PP2(K)=P1(K) 323 CONTINUE ENDIF C TERM=WZSS(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2) TERM=TERM-SGN*WZST(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2) TERM=TERM-SGN*WZSU(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2) TERM=TERM+WZTU(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2) WWSIG=TERM*QSAVE(IQ1,1)*QSAVE(IQ2,2)*FJAC C RETURN C C Do Z+gamma or W+gamma 3-body subprocesses C 2 CONTINUE C C Z+gamma C Standard order is UP + UB --> Z0 + gamma C IF(.NOT.(JETTYP(1).EQ.4.AND.JETTYP(2).EQ.1)) GO TO 505 FJAC=S/SCM*P(1)/SQRT(P(1)**2+WMASS(4)**2)*UNITS C C Select quarks IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 A1=-AQ(IQ,4) B1=BQ(IQ,4) A2=-AQ(JQWW(1),4) B2=BQ(JQWW(1),4) DO K=1,5 Q(K)=SNGL(P1WW(K)) QB(K)=SNGL(P2WW(K)) KK(K)=SNGL(P4WW(K)) E(K)=SNGL(PZERO(K,1)) EB(K)=SNGL(PZERO(K,2)) END DO C IF(INITYP(1).EQ.2*IQ) THEN SMS=SMSZG(Q,QB,KK,E,EB,A1,B1,A2,B2) TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2 WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC/2. ELSE SMS=SMSZG(QB,Q,KK,E,EB,A1,B1,A2,B2) TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2 WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC/2. ENDIF 505 IF(.NOT.(JETTYP(1).EQ.1.AND.JETTYP(2).EQ.4)) GO TO 509 FJAC=S/SCM*P(2)/SQRT(P(2)**2+WMASS(4)**2)*UNITS C C Select quarks IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 A1=-AQ(IQ,4) B1=BQ(IQ,4) A2=-AQ(JQWW(2),4) B2=BQ(JQWW(2),4) DO K=1,5 Q(K)=SNGL(P1WW(K)) QB(K)=SNGL(P2WW(K)) KK(K)=SNGL(P3WW(K)) E(K)=SNGL(PZERO(K,1)) EB(K)=SNGL(PZERO(K,2)) END DO C IF(INITYP(1).EQ.2*IQ) THEN SMS=SMSZG(Q,QB,KK,E,EB,A1,B1,A2,B2) TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2 WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC/2. ELSE SMS=SMSZG(QB,Q,KK,E,EB,A1,B1,A2,B2) TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2 WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC/2. ENDIF C W+- GM pair decays C Standard order is DN + UB --> W- + GM C C Swap if W is jet 2 509 IF (ABS(IDJETS(1)).EQ.80.OR.ABS(IDJETS(2)).EQ.80) THEN IF(IDJETS(2).EQ.10) THEN DO 510 K=1,4 P3(K)=P3WW(K) Q1(K)=PZERO(K,1) 510 CONTINUE AMASS3=PJETS(5,1) JW=1 JG=2 TX=T UX=U ELSE DO 520 K=1,4 P3(K)=P4WW(K) Q1(K)=PZERO(K,1) 520 CONTINUE AMASS3=PJETS(5,2) JW=2 JG=1 TX=U UX=T ENDIF IF(IDJETS(JW).EQ.80) THEN IW=2 ELSE IW=3 ENDIF C T1=-2.*(Q1(4)*P1(4)-Q1(1)*P1(1)-Q1(2)*P1(2)-Q1(3)*P1(3)) U1=-2.*(Q1(4)*P2(4)-Q1(1)*P2(1)-Q1(2)*P2(2)-Q1(3)*P2(3)) C Jacobean FJAC=S/SCM*UNITS FJAC=FJAC*P(JW)/SQRT(P(JW)**2+WM2) C Sum over quarks. Formulas are for DN UB --> W- GM. C Use symmetry for other cases. IQ1=INITYP(1) IQ2=INITYP(2) IQ=IQ1/2 IF(2*IQ.EQ.IQ1) THEN LQK1=.TRUE. ELSE LQK1=.FALSE. ENDIF C Swap t and u as necessary IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN TT=TX UU=UX TT1=T1 UU1=U1 ELSE TT=UX UU=TX TT1=U1 UU1=T1 ENDIF C Lepton or quark pointer IL=IABS(IDPAIR(1)) IF(IL.GT.6) IL=IL-4 C C Matrix element - properly crossed variables. C Remember PZERO(K,1) is always the fermion. IF(LQK1) THEN P1DQ2=P1(4)*PZERO(4,2)-P1(1)*PZERO(1,2)-P1(2)*PZERO(2,2) $ -P1(3)*PZERO(3,2) P2DQ1=P2(4)*PZERO(4,1)-P2(1)*PZERO(1,1)-P2(2)*PZERO(2,1) $ -P2(3)*PZERO(3,1) ELSE P1DQ2=P2(4)*PZERO(4,2)-P2(1)*PZERO(1,2)-P2(2)*PZERO(2,2) $ -P2(3)*PZERO(3,2) P2DQ1=P1(4)*PZERO(4,1)-P1(1)*PZERO(1,1)-P1(2)*PZERO(2,1) $ -P1(3)*PZERO(3,1) ENDIF TERM=ALFA**2/(8.*SIN2W*S**2)*TBRWW(IW,JW)*RBRWW(IL,IW,JW) $*(-1./3.+UU/(TT+UU))**2/(TT*UU)*(4.*P2DQ1**2+4.*P1DQ2**2) WWSIG=TERM*QSAVE(IQ1,1)*QSAVE(IQ2,2)*FJAC END IF C RETURN END +EOD +DECK,SMSZG FUNCTION SMSZG(Q,QB,K,E,EB,AQ,BQ,AE,BE) IMPLICIT NONE C C This does squared matrix element for q+qb -> Z+gamma C where Z-> e+eb C I have factored out 128*e^6*Q_q^2*|D_Z(z^2)| from C the expression. Also 1/12 from spin/color ave. is out. C REAL Q(5),QB(5),K(5),E(5),EB(5),AQ,BQ,AE,BE,SMSZG REAL M1S,M2S,M12 REAL EDQ,EBDK,EBDQ,EDK,QBDK,EDQB,EBDQB,QDK,QDQB EDQ=E(4)*Q(4)-E(1)*Q(1)-E(2)*Q(2)-E(3)*Q(3) EBDK=EB(4)*K(4)-EB(1)*K(1)-EB(2)*K(2)-EB(3)*K(3) EBDQ=EB(4)*Q(4)-EB(1)*Q(1)-EB(2)*Q(2)-EB(3)*Q(3) EDK=E(4)*K(4)-E(1)*K(1)-E(2)*K(2)-E(3)*K(3) QBDK=QB(4)*K(4)-QB(1)*K(1)-QB(2)*K(2)-QB(3)*K(3) EDQB=E(4)*QB(4)-E(1)*QB(1)-E(2)*QB(2)-E(3)*QB(3) EBDQB=EB(4)*QB(4)-EB(1)*QB(1)-EB(2)*QB(2)-EB(3)*QB(3) QDK=Q(4)*K(4)-Q(1)*K(1)-Q(2)*K(2)-Q(3)*K(3) QDQB=Q(4)*QB(4)-Q(1)*QB(1)-Q(2)*QB(2)-Q(3)*QB(3) M1S=(((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*EDQ*EBDK+ $((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*EBDQ*EDK)/ $4./QBDK M2S=(((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*EDQB*EBDK+ $((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*EBDQB*EDK)/ $4./QDK M12=(2*(AQ**2+BQ**2)*(AE**2+BE**2)*(EDQ*EBDQ*QBDK+EDQB*EBDQB*QDK) $+((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*(2*EDQ*EBDQB*QDQB+ $EDQ*EBDK*QDQB-EDK*EBDQB*QDQB+EDQ*EBDQB*QDK-EDQ*EBDQB*QBDK)+ $((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*(2*EDQB*EBDQ*QDQB- $EDQB*EBDK*QDQB+EDK*EBDQ*QDQB+EDQB*EBDQ*QDK-EDQB*EBDQ*QBDK))/ $4./QBDK/QDK SMSZG=M1S+M2S+M12 RETURN END +EOD +DECK,SORTTF,IF=NOCERN. SUBROUTINE SORTTF(A,INDEX,N1) C======================================================================= C Given real array and corresponding index INDEX, find new C INDEX for which A is sorted into ascending order. C C From CERN PROGLIB# M101 C======================================================================= DIMENSION A(N1),INDEX(N1) C N = N1 DO 3 I1=2,N I3 = I1 I33 = INDEX(I3) AI = A(I33) 1 I2 = I3/2 IF (I2) 3,3,2 2 I22 = INDEX(I2) IF (AI.LE.A (I22)) GO TO 3 INDEX (I3) = I22 I3 = I2 GO TO 1 3 INDEX (I3) = I33 4 I3 = INDEX (N) INDEX (N) = INDEX (1) AI = A(I3) N = N-1 IF (N-1) 12,12,5 5 I1 = 1 6 I2 = I1 + I1 IF (I2.LE.N) I22= INDEX(I2) IF (I2-N) 7,9,11 7 I222 = INDEX (I2+1) IF (A(I22)-A(I222)) 8,9,9 8 I2 = I2+1 I22 = I222 9 IF (AI-A(I22)) 10,11,11 10 INDEX(I1) = I22 I1 = I2 GO TO 6 11 INDEX (I1) = I3 GO TO 4 12 INDEX (1) = I3 RETURN END +EOD +DECK,SPLINE. SUBROUTINE SPLINE(X,C,N,IBCBEG,IBCEND) C********************************************************************** C* Computes the coefficient of a cubic interpolating spline. The X(i),* C* i=1,...,N, are the knots or x-values of data points; C(1,i) are * C* the corresponding y-values. N is the number of data points (>3!). * C* IBCBEG = 0 means that the slope at X(1) is unknown, in which case * C* it is determined from requiring a smooth 3rd derivative at x(2); * C* IBCBEG = 1 means that the slope is known, in which case it has to * C* be stored in C(1,2). IBCEND has the same meaning for the end of * C* x-region; if IBCEND = 1, the slope is to be stored in C(2,N). The * C* routine then computes the coefficients C(l,i) of the i-th spline, * C* written in the form * C* f_i(x) = C(1,i) + h_i C(2,i) + h_i^2 C(3,i) + h_i^3 C(4,i), where * C* h_i = x - X(I). * C Modified from contributed subroutine by M. Drees, 1/14/99 C********************************************************************** +SELF,IF=IMPNONE IMPLICIT NONE +SELF INTEGER N,IBCBEG,IBCEND,I,L,M,J REAL C(4,N),X(N),G,DTAU,DIVDF1,DIVDF3 C L = N - 1 DO 10 M = 2, N C(3,M) = X(M) - X(M-1) 10 C(4,M) = (C(1,M) - C(1,M-1))/C(3,M) C First slope unknown IF(IBCBEG.EQ.0) THEN C(4,1) = C(3,3) C(3,1) = C(3,2) + C(3,3) C(2,1) = ( (C(3,2)+2.0*C(3,1))*C(4,2)*C(3,3) + & C(3,2)**2*C(4,3) )/C(3,1) C First slope already known ELSE C(4,1) = 1.0 C(3,1) = 0.0 ENDIF C Forward pass of Gauss elimination DO 20 M = 2, L G = -C(3,M+1)/C(4,M-1) C(2,M) = G*C(2,M-1) + 3.0*(C(3,M)*C(4,M+1)+C(3,M+1)*C(4,M)) 20 C(4,M) = G*C(3,M-1) + 2.0*(C(3,M)+C(3,M+1)) IF(IBCEND.EQ.0) THEN G = C(3,N-1) + C(3,N) C(2,N) = ( (C(3,N)+2.0*G)*C(4,N)*C(3,N-1) + & C(3,N)**2*(C(1,N-1)-C(1,N-2))/C(3,N-1) )/G G = -G/C(4,N-1) C(4,N) = (G+1.0)*C(3,N-1) + C(4,N) C(2,N) = ( G*C(2,N-1) + C(2,N) )/C(4,N) ENDIF C Back substitution DO 30 J = L,1,-1 30 C(2,J) = ( C(2,J) - C(3,J)*C(2,J+1) )/C(4,J) C Computation of coefficients DO 40 I = 2,N DTAU = C(3,I) DIVDF1 = (C(1,I)-C(1,I-1))/DTAU DIVDF3 = C(2,I-1) + C(2,I) - 2.0*DIVDF1 C(3,I-1) = ( DIVDF1 - C(2,I-1) - DIVDF3 ) / DTAU 40 C(4,I-1) = DIVDF3/DTAU/DTAU C RETURN END +EOD +DECK,SSFEL. FUNCTION SSFEL(X,INIT) C*********************************************************************** C* Computes the electron spectrum as a convolution of the beam- and * C* bremsstrahlung-spectra, including leading-log summation for the lat-* C* ter (in one-loop order), and Peskin's approximate expression for the* C* former. X is the e energy in units of the nominal beam energy, and * C* BETA is 2 alpha_em / pi (log s/me^2 - 1). If more than 99.5% of all * C* electrons are in the delta-peak, beamstrahlung is ignored. Other- * C* wise, beamstrahlung is included. In the latter case, the complete * C* spectrum is computed at the first call (with INIT=1), and fitted in * C* a cubic spline; in later calls (with INIT=0), only the spline is * C* used. This reduces the necessary amount of CPU time considerably. * C* This subroutine needs the programs BEAMEL, SIMAU8, and SPLINE. * C*********************************************************************** +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,EEPAR +CDE,BREMBM C REAL X,SSFEL INTEGER INIT REAL Y,XLMM,XL,GAM,RE,XKAPPA,NUCL,NUGAM,NGAM,DC, $DX,TAU(100),C(4,100),XM,Z,RES,SSXINT,Y2,H,S,ESTRUC,Y1 INTEGER I SAVE DC,NGAM,C,TAU EXTERNAL FBRBM C IF(INIT.NE.0) THEN C Compute delta function contribution Y=UPSLON XLMM=SIGZ XL = XLMM*1.E12/.197327 GAM = EB/5.11E-4 RE = 1./(137.*5.11E-4) XKAPPA = 2./(3.*Y) NUCL = 2.5*Y/(SQRT(3.)*137.**2*GAM*RE) NUGAM = NUCL/SQRT(1.+Y**.6666666) NGAM=sqrt(3.)*NUGAM*XL DC = EXP(-NGAM/2.) SSFEL=0. C No initialization needed if >.995 included in delta peak IF(DC.GT..995) RETURN C *** Computation of 'knots' *** DX = .05 DO 100 I = 1, 19 100 TAU(I) = FLOAT(I-1)*DX DO 110 I = 1, 9 110 TAU(19+I) = .9 + FLOAT(I)*1.E-2 DO 120 I = 1, 5 120 TAU(28+I) = .99 + FLOAT(I)*1.E-3 DO 121 I = 1, 12 121 TAU(33+I) = .995 + FLOAT(I)*2.5E-4 DO 130 I = 1, 20 130 TAU(45+I) = .998 + FLOAT(I)*1.E-4 C *** Computation of corresponding y-values (electron densities) *** XM = TAU(65) DO 140 I = 1,65 Z = TAU(I) XMIN = Z RES=SSXINT(Z,FBRBM,XM) 140 C(1,I) = RES +DC*ESTRUC(Z,QSQBM) C *** Computation of derivative at zero *** Z = 1.E-5 XMIN = Z RES=SSXINT(Z,FBRBM,XM) Y1 = RES + DC*ESTRUC(Z,QSQBM) Z = 1.E-4 XMIN = Z RES=SSXINT(Z,FBRBM,XM) Y2 = RES + DC*ESTRUC(Z,QSQBM) C(1,2) = (Y2-Y1)/(1.E-4 - 1.E-5) 147 CALL SPLINE(TAU,C,65,1,0) RETURN ENDIF IF(X.GT..999999) THEN Z = .999999 ELSE Z = X ENDIF DC = EXP(-NGAM/2.) IF(DC.GT..995) THEN SSFEL = DC*ESTRUC(Z,QSQBM) RETURN ENDIF DO 2 I = 1, 64 2 IF(Z.LT.TAU(I+1)) GOTO 3 3 H = Z - TAU(I) S = C(1,I) + H * ( C(2,I) + H*(C(3,I)+H*C(4,I)) ) SSFEL = S RETURN END +EOD +DECK,SSGST REAL FUNCTION SSGST(S,AMSQ,Z,I,J) C----------------------------------------------------------------------- C Function for Sig(qqbar->z_i + z_j C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,SSSM +CDE,SSPAR REAL S,AMSQ,K,Z,MZI,MZJ,RS,TP,BT INTEGER I,J,ITHI,ITHJ C MZI=ABS(AMZISS(I)) MZJ=ABS(AMZISS(J)) IF (AMZISS(I).LT.0.) THEN ITHI=1 ELSE ITHI=0 END IF IF (AMZISS(J).LT.0.) THEN ITHJ=1 ELSE ITHJ=0 END IF RS=SQRT(S) K=SQRT(S*S+(MZI**2-MZJ**2)**2-2*S*(MZI**2+MZJ**2))/ $ 2./RS TP=S*S-(MZI**2-MZJ**2)**2-4*K*S**1.5*Z+4*K*K*S*Z*Z+ $ 4*(-1.)**(ITHI+ITHJ+1)*MZI*MZJ*S BT=(S-MZI**2-MZJ**2)/2.-RS*K*Z+AMSQ**2 SSGST=TP/BT RETURN END +EOD +DECK,SSGT REAL FUNCTION SSGT(S,AMSQ,Z,I,J) C----------------------------------------------------------------------- C Function for Sig(qqbar->z_i + z_j C----------------------------------------------------------------------- +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,SSSM +CDE,SSPAR REAL S,AMSQ,K,Z,MZI,MZJ,RS,TPP,TPM,BTP,BTM INTEGER I,J,ITHI,ITHJ C MZI=ABS(AMZISS(I)) MZJ=ABS(AMZISS(J)) IF (AMZISS(I).LT.0.) THEN ITHI=1 ELSE ITHI=0 END IF IF (AMZISS(J).LT.0.) THEN ITHJ=1 ELSE ITHJ=0 END IF RS=SQRT(S) K=SQRT(S*S+(MZI**2-MZJ**2)**2-2*S*(MZI**2+MZJ**2))/ $ 2./RS TPP=S*S-(MZI**2-MZJ**2)**2-4*K*S**1.5*Z+4*K*K*S*Z*Z TPM=S*S-(MZI**2-MZJ**2)**2+4*K*S**1.5*Z+4*K*K*S*Z*Z BTP=(S-MZI**2-MZJ**2)/2.-RS*K*Z+AMSQ**2 BTM=(S-MZI**2-MZJ**2)/2.+RS*K*Z+AMSQ**2 SSGT=(TPP/BTP**2+TPM/BTM**2-8*(-1.)**(ITHI+ITHJ)* $ MZI*MZJ*S/BTM/BTP)/16. RETURN END +EOD +DECK,STRUC. FUNCTION STRUC(X,QSQ,IQ,IH) C C Compute structure functions X*F(X,QSQ) C ISTRUC=1,2 Deleted C ISTRUC=3 Eichten, Hinchliffe, Lane, and Quigg (1984) C solution 1 (obsolete) C ISTRUC=4 Duke and Owens, Phys. Rev. D30, 49. C solution 1 (obsolete) C ISTRUC=5 CTEQ Collaboration, Phys. Lett. 304B, 159 C fit CTEQ2L (lowest order QCD) C ISTRUC=6 CTEQ Collaboration, Phys. Rev. D51, 4763 (1995) C fit CTEQ3L (lowest order QCD) C ISTRUC=7 CTEQ fit CTEQ5L, hep-ph/9903282. C ISTRUC=-999 PDFLIB interface. Parameters are passed by call C to PDFSET in READIN. C Quark types-- C IQ=1 2 3 4 5 6 7 8 9 10 11 12 13 C GL UP UB DN DB ST SB CH CB BT BB TP TB C Hadron types-- C IH=+1120 -1120 +1220 -1220 C P AP N AN C C For IBM compatibility require STRUC > SFMIN = 1.E-10 C Ver. 7.23: Simplify type mapping and fix PDF error for pbar C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR C E1STRC contains all the coefficients for Eichten, etal, C solution 1. It is equivalenced to arrays for the 16 sets of C coefficients. DIMENSION E1STRC(6,6,16),E1POW(8),IE1FIT(13) DIMENSION E1UPHI(6,6),E1DNHI(6,6),E1UBHI(6,6),E1GLHI(6,6), $E1STHI(6,6),E1CHHI(6,6),E1BTHI(6,6),E1TPHI(6,6) DIMENSION E1UPLO(6,6),E1DNLO(6,6),E1UBLO(6,6),E1GLLO(6,6), $E1STLO(6,6),E1CHLO(6,6),E1BTLO(6,6),E1TPLO(6,6) EQUIVALENCE (E1UPHI(1,1),E1STRC(1,1,1)) EQUIVALENCE (E1DNHI(1,1),E1STRC(1,1,2)) EQUIVALENCE (E1UBHI(1,1),E1STRC(1,1,3)) EQUIVALENCE (E1GLHI(1,1),E1STRC(1,1,4)) EQUIVALENCE (E1STHI(1,1),E1STRC(1,1,5)) EQUIVALENCE (E1CHHI(1,1),E1STRC(1,1,6)) EQUIVALENCE (E1BTHI(1,1),E1STRC(1,1,7)) EQUIVALENCE (E1TPHI(1,1),E1STRC(1,1,8)) EQUIVALENCE (E1UPLO(1,1),E1STRC(1,1,9)) EQUIVALENCE (E1DNLO(1,1),E1STRC(1,1,10)) EQUIVALENCE (E1UBLO(1,1),E1STRC(1,1,11)) EQUIVALENCE (E1GLLO(1,1),E1STRC(1,1,12)) EQUIVALENCE (E1STLO(1,1),E1STRC(1,1,13)) EQUIVALENCE (E1CHLO(1,1),E1STRC(1,1,14)) EQUIVALENCE (E1BTLO(1,1),E1STRC(1,1,15)) EQUIVALENCE (E1TPLO(1,1),E1STRC(1,1,16)) DIMENSION CHEBX(6),CHEBQ(6) C REAL X,QSQ,STRUC REAL BETA,CHEB1,CHEB2,CHEB3,CHEB4,CHEB5,AMASS,E1POW,FD,CHEBX, $E1STRC,E1UPHI,CHEBQ,AD,ETA3,GUD,ETA2,ETA4,FUD,AUD,GD,E1GLLO, $E1UBLO,E1DNLO,E1STLO,E1TPLO,E1BTLO,E1CHLO,E1UPLO,E1GLHI,E1UBHI, $E1DNHI,E1STHI,E1TPHI,E1BTHI,ETA1,T,TMAX,TMIN,AMQ,Q2MIN,W2,W1, $SFMIN,T1,A1,A0,SS,B1,C2,B2,A2,S,X1,TERM,E1CHHI,Q2,GAMMA INTEGER IQ,IH INTEGER IE1FIT,IFIT,IFIT2,JX,JQ,ISHFT,IIQ C CTEQ declarations REAL A3,A4,A5,SBL,QI,Q,SB,SB2,SB3 INTEGER IFL INTEGER IQPB(13),IQN(13),IQNB(13) +SELF,IF=SINGLE REAL SEA,VAL,P012,P34,P5 +SELF,IF=DOUBLE DOUBLE PRECISION SEA,VAL,P012,P34,P5 +SELF C CTEQ5L quantities DOUBLE PRECISION X5L,Q5L,CTEQ5L,SUM5L,RAT5L C PDFLIB declarations +SELF,IF=PDFLIB,IF=SINGLE REAL DX,DSCALE,DXPDF(-6:6) +SELF,IF=PDFLIB,IF=DOUBLE DOUBLE PRECISION DX,DSCALE,DXPDF(-6:6) +SELF,IF=PDFLIB INTEGER IQMAP(13) DATA IQMAP/0,2,-2,1,-1,3,-3,4,-4,5,-5,6,-6/ +SELF C C Map pbar, n, nbar types to p type DATA IQPB/1,3,2,5,4,7,6,9,8,11,10,13,12/ DATA IQN /1,4,5,2,3,6,7,8,9,10,11,12,13/ DATA IQNB/1,5,4,3,2,7,6,9,8,11,10,13,12/ C C Eichten etal solution 1 constants C corrected coefficients from Ian Hinchliffe, 3 June 1986. DATA E1UPHI/ $ 0.76772, -0.20874, -0.33026, -0.02517, -0.01570, -0.00010, $ -0.53259, -0.26612, 0.32007, 0.11918, 0.02434, 0.00762, $ 0.21618, 0.18812, -0.08375, -0.06515, -0.01743, -0.00504, $ -0.09211, -0.09952, 0.01373, 0.02506, 0.00877, 0.00255, $ 0.03670, 0.04409, 0.00096, -0.00796, -0.00342, -0.00105, $ -0.01549, -0.02026, -0.00306, 0.00222, 0.00124, 0.00041/ DATA E1DNHI/ $ 0.38130, -0.08090, -0.16336, -0.02185, -0.00843, -0.00062, $ -0.29475, -0.14348, 0.16650, 0.06638, 0.01473, 0.00408, $ 0.12518, 0.10422, -0.04722, -0.03683, -0.01038, -0.00286, $ -0.05478, -0.05678, 0.00890, 0.01484, 0.00534, 0.00152, $ 0.02220, 0.02567, -0.00003, -0.00497, -0.00216, -0.00065, $ -0.00953, -0.01204, -0.00151, 0.00151, 0.00083, 0.00027/ DATA E1UBHI/ $ 0.06870, -0.06861, 0.02973, -0.00540, 0.00378, -0.00097, $ -0.01802, 0.00014, 0.00649, -0.00854, 0.00122, -0.00175, $ -0.00465, 0.00148, -0.00593, 0.00060, -0.00103, -0.00008, $ 0.00644, 0.00257, 0.00283, 0.00115, 0.00071, 0.00033, $ -0.00393, -0.00254, -0.00116, -0.00077, -0.00036, -0.00019, $ 0.00234, 0.00193, 0.00053, 0.00037, 0.00016, 0.00009/ DATA E1GLHI/ $ 0.94819, -0.95779, 0.10085, -0.10510, 0.03456, -0.03054, $ -0.96265, 0.53790, 0.33684, -0.09525, 0.01488, -0.02051, $ 0.43004, -0.08306, -0.33719, 0.04902, -0.00916, 0.01041, $ -0.19249, -0.01790, 0.21830, 0.00749, 0.00414, -0.00186, $ 0.08183, 0.01926, -0.10718, -0.01944, -0.00277, -0.00052, $ -0.03884, -0.01234, 0.05410, 0.01879, 0.00335, 0.00104/ DATA E1STHI/ $ 0.04968, -0.04173, 0.02102, -0.00327, 0.00324, -0.00067, $ -0.00615, -0.01294, 0.00674, -0.00689, 0.00090, -0.00151, $ -0.00858, 0.00505, -0.00490, -0.00016, -0.00094, -0.00015, $ 0.00784, 0.00151, 0.00222, 0.00140, 0.00070, 0.00035, $ -0.00441, -0.00222, -0.00089, -0.00085, -0.00036, -0.00020, $ 0.00252, 0.00184, 0.00041, 0.00039, 0.00016, 0.00009/ DATA E1CHHI/ $ 0.00927, -0.01817, 0.00959, -0.00639, 0.00169, -0.00154, $ 0.00571, -0.01188, 0.00609, -0.00465, 0.00124, -0.00131, $ -0.00396, 0.00710, -0.00359, 0.00184, -0.00039, 0.00034, $ 0.00112, -0.00196, 0.00112, -0.00048, 0.00010, -0.00004, $ 0.00004, -0.00003, -0.00018, 0.00009, -0.00005, -0.00002, $ -0.00042, 0.00073, -0.00016, 0.00005, 0.00005, 0.00005/ DATA E1BTHI/ $ 0.00901, -0.01401, 0.00715, -0.00413, 0.00126, -0.00104, $ 0.00628, -0.00932, 0.00478, -0.00289, 0.00091, -0.00082, $ -0.00293, 0.00409, -0.00189, 0.00076, -0.00023, 0.00014, $ 0.00039, -0.00120, 0.00044, -0.00025, 0.00002, -0.00002, $ 0.00026, 0.00014, -0.00008, 0.00010, 0.00001, 0.00001, $ -0.00026, 0.00032, 0.00001, -0.00001, 0.00001, -0.00001/ DATA E1TPHI/ $ 0.00441, -0.00748, 0.00377, -0.00258, 0.00073, -0.00071, $ 0.00384, -0.00605, 0.00303, -0.00203, 0.00058, -0.00059, $ -0.00088, 0.00166, -0.00075, 0.00047, -0.00010, 0.00010, $ -0.00008, -0.00015, 0.00012, -0.00009, 0.00003, 0.00000, $ 0.00013, -0.00022, -0.00002, -0.00002, -0.00002, -0.00002, $ -0.00007, 0.00019, -0.00004, 0.00002, 0.00000, 0.00000/ DATA E1UPLO/ $ 0.23946, 0.29055, 0.09778, 0.02149, 0.00344, 0.00050, $ 0.01751, -0.00609, -0.02687, -0.01916, -0.00797, -0.00275, $ -0.00576, -0.00504, 0.00108, 0.00249, 0.00153, 0.00075, $ 0.00174, 0.00196, 0.00030, -0.00034, -0.00029, -0.00018, $ -0.00053, -0.00064, -0.00017, 0.00004, 0.00006, 0.00004, $ 0.00017, 0.00022, 0.00008, 0.00001, -0.00001, -0.00001/ DATA E1DNLO/ $ 0.12613, 0.13542, 0.03958, 0.00824, 0.00166, 0.00045, $ 0.00389, -0.01159, -0.01625, -0.00961, -0.00371, -0.00126, $ -0.00191, -0.00056, 0.00159, 0.00159, 0.00084, 0.00039, $ 0.00064, 0.00049, -0.00015, -0.00029, -0.00018, -0.00010, $ -0.00020, -0.00019, 0.00000, 0.00006, 0.00004, 0.00003, $ 0.00007, 0.00008, 0.00002, -0.00001, -0.00001, -0.00001/ DATA E1UBLO/ $ 1.01386, -1.10585, 0.33739, -0.07444, 0.00885, -0.00087, $ 0.92334, -1.28541, 0.44755, -0.09786, 0.01419, -0.00112, $ 0.04888, -0.12708, 0.08606, -0.02608, 0.00478, -0.00060, $ -0.02691, 0.04887, -0.01771, 0.00162, 0.00025, -0.00006, $ 0.00704, -0.01113, 0.00159, 0.00070, -0.00020, 0.00000, $ -0.00171, 0.00229, 0.00038, -0.00035, 0.00004, 0.00001/ DATA E1GLLO/ $ 29.47734,-39.02468, 14.63570, -3.33516, 0.50538, -0.05915, $ 25.58960,-39.54527, 16.61420, -4.29861, 0.69036, -0.08243, $ -1.66291, 1.17624, 1.11844, -0.70986, 0.19481, -0.02404, $ -0.21679, 0.81705, -0.71688, 0.18507, -0.01924, -0.00325, $ 0.20880, -0.43547, 0.22391, -0.02446, -0.00362, 0.00191, $ -0.09097, 0.16009, -0.05681, -0.00250, 0.00258, -0.00047/ DATA E1STLO/ $ 0.92351, -1.08483, 0.34642, -0.07210, 0.00914, -0.00091, $ 0.93146, -1.27376, 0.45122, -0.09775, 0.01380, -0.00131, $ 0.04739, -0.12960, 0.08482, -0.02642, 0.00476, -0.00057, $ -0.02653, 0.04953, -0.01735, 0.00175, 0.00028, -0.00006, $ 0.00694, -0.01132, 0.00148, 0.00065, -0.00021, 0.00000, $ -0.00168, 0.00234, 0.00042, -0.00034, 0.00005, 0.00001/ DATA E1CHLO/ $ 0.80983, -1.04168, 0.33980, -0.06824, 0.00876, -0.00090, $ 0.89606, -1.21708, 0.43386, -0.09287, 0.01304, -0.00129, $ 0.03058, -0.10402, 0.07604, -0.02415, 0.00460, -0.00050, $ -0.02451, 0.04432, -0.01651, 0.00143, 0.00012, -0.00010, $ 0.01122, -0.01457, 0.00268, 0.00058, -0.00012, 0.00003, $ -0.00773, 0.00733, -0.00076, -0.00024, 0.00001, 0.00000/ DATA E1BTLO/ $ 0.80288, -1.07532, 0.37920, -0.07843, 0.01007, -0.00109, $ 0.79033, -1.09887, 0.41532, -0.09301, 0.01317, -0.00141, $ -0.01704, -0.01130, 0.02882, -0.01341, 0.00304, -0.00036, $ -0.00072, 0.00723, -0.00516, 0.00108, -0.00005, -0.00004, $ 0.00305, -0.00461, 0.00166, -0.00013, -0.00001, 0.00001, $ -0.00436, 0.00523, -0.00161, 0.00020, -0.00002, 0.00000/ DATA E1TPLO/ $ 0.66233, -0.92481, 0.35193, -0.07930, 0.01110, -0.00118, $ 0.63797, -0.90619, 0.35816, -0.08479, 0.01265, -0.00139, $ -0.02581, 0.02125, 0.00419, -0.00498, 0.00149, -0.00021, $ 0.00071, 0.00053, -0.00127, 0.00039, -0.00005, -0.00001, $ 0.00385, -0.00506, 0.00186, -0.00035, 0.00004, 0.00000, $ -0.00353, 0.00446, -0.00150, 0.00027, -0.00003, 0.00000/ C E1POW gives powers of (1-x). C IE1FIT points to fit for each value of IQ. DATA E1POW/3.,4.,7.,5.,7.,7.,7.,7./ DATA IE1FIT/4,1,3,2,3,5,5,6,6,7,7,8,8/ C Minimum value for STRUC DATA SFMIN/1.E-10/ C BETA(W1,W2)=GAMMA(W1)*GAMMA(W2)/GAMMA(W1+W2) C Chebyshev polynomials CHEB1(X)=X CHEB2(X)=2.*X**2-1. CHEB3(X)=X*(-3.+4.*X**2) CHEB4(X)=1.+X**2*(-8.+8.*X**2) CHEB5(X)=X*(5.+X**2*(-20.+16.*X**2)) C C Entry -- check for unphysical X C IF(X.LE.0..OR.X.GE..9999) THEN STRUC=0. GO TO 9999 ENDIF C C Determine equivalent quark type IIQ for proton C IF(IH.EQ.1120) THEN IIQ=IQ ELSEIF(IH.EQ.-1120) THEN IIQ=IQPB(IQ) ELSEIF(IH.EQ.1220) THEN IIQ=IQN(IQ) ELSEIF(IH.EQ.-1220) THEN IIQ=IQNB(IQ) ELSE C This should never happen STRUC=0 RETURN ENDIF C C Select structure function fit. C IF(ISTRUC.EQ.7) GO TO 4000 IF(ISTRUC.EQ.6) GO TO 3100 IF(ISTRUC.EQ.5) GO TO 3000 IF(ISTRUC.EQ.4) GO TO 2000 IF(ISTRUC.EQ.3) GO TO 1000 +SELF,IF=PDFLIB IF(ISTRUC.EQ.-999) GO TO 9000 +SELF STRUC=0. GO TO 9999 C C Calculate Eichten etal structure fcn for type IIQ C 1000 STRUC=0. Q2=QSQ IF(Q2.LT.5.) Q2=5. T=ALOG(Q2/ALAM2) TMAX=ALOG(1.E8/ALAM2) IF(IIQ.GT.9) GO TO 1001 Q2MIN=5. GO TO 1002 1001 AMQ=AMASS(IIQ/2) Q2MIN=4.*AMQ**2/(1.-X) IF(Q2.LT.Q2MIN) GO TO 9999 1002 TMIN=ALOG(Q2MIN/ALAM2) T1=(2.*T-(TMAX+TMIN))/(TMAX-TMIN) CHEBQ(1)=1. CHEBQ(2)=CHEB1(T1) CHEBQ(3)=CHEB2(T1) CHEBQ(4)=CHEB3(T1) CHEBQ(5)=CHEB4(T1) CHEBQ(6)=CHEB5(T1) C x.gt.0.1 IF(X.LT.0.1) GO TO 1010 X1=(2.*X-1.1)/.9 ISHFT=0 GO TO 1020 C x.lt.0.1 1010 X1=(2.*ALOG(X)+11.51293)/6.90776 ISHFT=8 C IFIT is pointer for Eichten quark type. C IFIT2 is pointer for function -- shifted by 8 for x<0.1 1020 IFIT=IE1FIT(IIQ) IFIT2=IFIT+ISHFT CHEBX(1)=1. CHEBX(2)=CHEB1(X1) CHEBX(3)=CHEB2(X1) CHEBX(4)=CHEB3(X1) CHEBX(5)=CHEB4(X1) CHEBX(6)=CHEB5(X1) TERM=0. DO 1030 JQ=1,6 DO 1030 JX=1,6 1030 TERM=TERM+E1STRC(JX,JQ,IFIT2)*CHEBQ(JQ)*CHEBX(JX) TERM=TERM*(1.-X)**E1POW(IFIT) STRUC=ABS(TERM) IF(IFIT.GT.2) GO TO 9999 C Add sea term for valence quarks TERM=0. DO 1040 JQ=1,6 DO 1040 JX=1,6 1040 TERM=TERM+E1STRC(JX,JQ,3+ISHFT)*CHEBQ(JQ)*CHEBX(JX) TERM=TERM*(1.-X)**E1POW(3) STRUC=STRUC+ABS(TERM) GO TO 9999 C C Calculate Duke-Owens structure function for type IIQ. C 2000 STRUC=0. Q2=QSQ IF(Q2.LT.4.) Q2=4. S=ALOG(ALOG(Q2/ALAM2)/ALOG(4./ALAM2)) SS=S*S C x*f(x) for gl IF(IIQ.EQ.1) THEN A0=1.56-1.71*S+.638*SS A1=-0.949*S+.325*SS B1=6.+1.44*S-1.05*SS A2=9.-7.19*S+.255*SS B2=-16.5*S+10.9*SS C2=15.3*S-10.1*SS STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3) C x*f(x) for up,ub,dn,db,st,sb ELSEIF(IIQ.LE.7) THEN A0=1.265-1.132*S+.293*SS A1=-.372*S-.029*SS B1=8.05+1.59*S-.153*SS A2=6.31*S-.273*SS B2=-10.5*S-3.17*SS C2=14.7*S+9.80*SS STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3)/6. IF(IIQ.EQ.2.OR.IIQ.EQ.4) THEN ETA1=.419+.004*S-.007*SS ETA2=3.46+.724*S-.066*SS GUD=4.40-4.86*S+1.33*SS ETA3=.763-.237*S+.026*SS ETA4=4.00+.627*S-.019*SS GD=-.421*S+.033*SS AUD=3./(BETA(ETA1,ETA2+1.)*(1.+GUD*ETA1/(ETA1+ETA2+1.))) FUD=AUD*X**ETA1*(1.-X)**ETA2*(1.+GUD*X) AD=1./(BETA(ETA3,ETA4+1.)*(1.+GD*ETA3/(ETA3+ETA4+1.))) FD=AD*X**ETA3*(1.-X)**ETA4*(1.+GD*X) IF(IIQ.EQ.2) STRUC=STRUC+FUD-FD IF(IIQ.EQ.4) STRUC=STRUC+FD ENDIF C x*f(x) for ch,cb ELSEIF(IIQ.LE.9) THEN A0=.135*S-.0075*SS A1=-.036-.222*S-.058*SS B1=6.35+3.26*S-.909*SS A2=-3.03*S+1.50*SS B2=17.4*S-11.3*SS C2=-17.9*S+15.6*SS STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3) C x*f(x)=0 for bt,bb,tp,tb ELSE STRUC=0. ENDIF GO TO 9999 C C Calculate CTEQ2L distribution for type IIQ C 3000 STRUC=0 IFL=IIQ/2 C Set up thresholds Q=SQRT(QSQ) IF(IFL.LE.4) THEN QI=1.6 ELSEIF(IFL.EQ.5) THEN QI=5.0 ELSEIF(IFL.EQ.6) THEN QI=180 ELSE RETURN ENDIF IF(Q.LT.QI) THEN Q=QI IF(IFL.GE.4) GO TO 9999 ENDIF C Hard code lambda=0.190 SBL=LOG(Q/0.190)/LOG(QI/0.190) SB=LOG (SBL) SB2=SB*SB SB3=SB2*SB C Calculate sea part IF(IFL.EQ.0) THEN A0=EXP(-0.6510E+00-0.1128E+01*SB-0.6239E-01*SB2-0.8838E-01*SB3) A1=-0.2590E+00+0.1822E+00*SB-0.2682E+00*SB2+0.9422E-01*SB3 A2= 0.4607E+01+0.7792E+00*SB+0.8937E+00*SB2-0.5553E+00*SB3 A3= 0.1627E+02-0.1114E+02*SB+0.4928E+01*SB2-0.1715E+01*SB3 A4= 0.1236E+01+0.1945E+00*SB-0.3297E+00*SB2+0.6489E-01*SB3 A5= 0.0000E+00+0.3346E+01*SB-0.2337E+01*SB2+0.7850E+00*SB3 ELSEIF(IFL.EQ.1) THEN A0=EXP(-0.1508E+01-0.5560E+00*SB-0.3523E+00*SB2+0.6562E-01*SB3) A1=-0.3223E+00+0.2095E-01*SB-0.2049E-02*SB2-0.3475E-01*SB3 A2= 0.9469E+01-0.3923E+01*SB+0.4333E+01*SB2-0.1654E+01*SB3 A3= 0.1646E+02-0.1082E+02*SB+0.8941E+01*SB2-0.5494E+01*SB3 A4= 0.2908E+01+0.2162E+01*SB-0.3233E+01*SB2+0.1267E+01*SB3 A5=-0.5819E+00+0.3914E+00*SB+0.6460E+00*SB2-0.3239E+00*SB3 ELSEIF(IFL.EQ.2) THEN A0=EXP(-0.1951E+01-0.3435E+01*SB+0.3424E+01*SB2-0.1249E+01*SB3) A1=-0.2942E+00+0.4408E+00*SB-0.5453E+00*SB2+0.1552E+00*SB3 A2= 0.9782E+01-0.3454E+01*SB+0.4510E+01*SB2-0.1649E+01*SB3 A3= 0.4999E+02-0.1993E+02*SB-0.2039E+01*SB2+0.5694E+00*SB3 A4= 0.1938E+01-0.1351E+01*SB+0.1386E+01*SB2-0.5324E+00*SB3 A5=-0.2410E+00+0.3434E+01*SB-0.3334E+01*SB2+0.1067E+01*SB3 ELSEIF(IFL.EQ.3) THEN A0=EXP(-0.1804E+01-0.4381E+01*SB-0.3699E+00*SB2+0.3878E+00*SB3) A1=-0.1000E-02-0.9334E+00*SB+0.7156E+00*SB2-0.2029E+00*SB3 A2= 0.6896E+01+0.2462E+01*SB-0.2885E+01*SB2+0.8701E+00*SB3 A3= 0.0000E+00+0.5589E+01*SB+0.1047E+02*SB2+0.3000E+02*SB3 A4= 0.1000E-02-0.5600E-02*SB+0.5618E-02*SB2+0.6598E-02*SB3 A5= 0.0000E+00-0.3151E+01*SB+0.4025E+01*SB2-0.1232E+01*SB3 ELSEIF(IFL.EQ.4) THEN A0=SB**0.7860E+00*EXP(-0.5041E+01-0.3357E+00*SB-0.4718E+00*SB2) A1=-0.4989E+00+0.9571E+00*SB-0.1359E+01*SB2+0.5384E+00*SB3 A2= 0.5986E+01-0.8541E+01*SB+0.1274E+02*SB2-0.5275E+01*SB3 A3= 0.8121E+01-0.1753E+02*SB+0.2194E+02*SB2-0.8538E+01*SB3 A4= 0.9290E-01-0.4390E+00*SB+0.6162E+00*SB2-0.2231E+00*SB3 A5=-0.1257E+01+0.5677E+01*SB-0.5977E+01*SB2+0.2387E+01*SB3 ELSEIF(IFL.EQ.5) THEN A0=SB**0.4537E+00*EXP(-0.3269E+01-0.5398E+01*SB+0.2893E+01*SB2) A1=-0.1977E+00-0.4126E+00*SB+0.7058E+00*SB2-0.4038E+00*SB3 A2= 0.4522E+01+0.6167E-01*SB-0.1849E+00*SB2+0.7345E+00*SB3 A3=-0.1003E+01+0.1531E+01*SB+0.4515E+01*SB2-0.4368E+01*SB3 A4= 0.3579E-01+0.1919E+00*SB-0.7268E+00*SB2+0.5192E+00*SB3 A5= 0.5129E+00+0.2447E+01*SB-0.1989E+01*SB2+0.7529E+00*SB3 ELSEIF(IFL.EQ.6) THEN A0=SB**0.7178E+00*EXP(-0.7327E+01+0.2277E+01*SB+0.3913E+01*SB2) A1=-0.9842E-01-0.2362E+01*SB+0.8851E+01*SB2-0.7208E+01*SB3 A2= 0.5552E+01-0.8935E+01*SB+0.2676E+02*SB2-0.1344E+02*SB3 A3= 0.1593E+01-0.3505E+01*SB-0.1234E+01*SB2-0.1867E+02*SB3 A4=-0.1723E+00+0.1530E+01*SB+0.2323E+01*SB2-0.9344E+01*SB3 A5= 0.2081E+01+0.1939E+01*SB-0.3273E+01*SB2+0.9935E+01*SB3 ENDIF P012=A0*(X**A1)*((1.-X)**A2) P34=(1.+A3*(X**A4)) P5=(LOG(1.+1./X))**A5 SEA=P012*P34*P5 C Add valence part IF(IIQ.NE.2.AND.IIQ.NE.4) THEN STRUC=SEA GO TO 9999 ELSEIF(IIQ.EQ.2) THEN A0=EXP(-0.1806E+01-0.6672E-01*SB-0.2605E+00*SB2+0.2341E-01*SB3) A1= 0.1750E+00+0.3872E-01*SB-0.2189E-01*SB2+0.1415E-01*SB3 A2= 0.3322E+01+0.7786E+00*SB-0.2902E+00*SB2+0.1517E+00*SB3 A3= 0.4414E+02-0.1987E+02*SB+0.2597E+01*SB2+0.2670E+01*SB3 A4= 0.9610E+00-0.2864E+00*SB-0.5524E-01*SB2+0.6229E-01*SB3 A5= 0.0000E+00+0.2658E+00*SB-0.4728E-02*SB2+0.6048E-01*SB3 ELSEIF(IIQ.EQ.4) THEN A0=EXP( 0.8000E-01+0.7364E+00*SB-0.2714E+01*SB2+0.1311E+01*SB3) A1= 0.4930E+00-0.2001E+00*SB+0.5784E+00*SB2-0.2915E+00*SB3 A2= 0.3001E+01+0.3538E+01*SB-0.6155E+01*SB2+0.3083E+01*SB3 A3=-0.1000E+01+0.3871E+01*SB-0.8334E+01*SB2+0.4219E+01*SB3 A4= 0.2986E+01+0.1597E+01*SB-0.3368E+01*SB2+0.1644E+01*SB3 A5= 0.0000E+00-0.9256E+00*SB+0.3570E+01*SB2-0.1777E+01*SB3 ENDIF P012=A0*(X**A1)*((1.-X)**A2) P34=(1.+A3*(X**A4)) P5=(LOG(1.+1./X))**A5 VAL=P012*P34*P5 STRUC=VAL+SEA GO TO 9999 C C Calculate CTEQ3L distribution for type IIQ C 3100 STRUC=0 IFL=IIQ/2 C Set up thresholds Q=SQRT(QSQ) IF(IFL.LE.4) THEN QI=1.6 ELSEIF(IFL.EQ.5) THEN QI=5.0 ELSEIF(IFL.EQ.6) THEN QI=180 ELSE RETURN ENDIF IF(Q.LT.QI) THEN Q=QI IF(IFL.GE.4) GO TO 9999 ENDIF C Hard code lambda=0.177 SBL=LOG(Q/0.177)/LOG(QI/0.177) SB=LOG (SBL) SB2=SB*SB SB3=SB2*SB C Calculate sea part IF(IFL.EQ.0) THEN A0=Exp(-0.7631E+00-0.7241E+00*SB -0.1170E+01*SB2+0.5343E+00*SB3) A1=-0.3573E+00+0.3469E+00*SB -0.3396E+00*SB2+0.9188E-01*SB3 A2= 0.5604E+01+0.7458E+00*SB -0.5082E+00*SB2+0.1844E+00*SB3 A3= 0.1549E+02-0.1809E+02*SB +0.1162E+02*SB2-0.3483E+01*SB3 A4= 0.9881E+00+0.1364E+00*SB -0.4421E+00*SB2+0.2051E+00*SB3 A5=-0.9505E-01+0.3259E+01*SB -0.1547E+01*SB2+0.2918E+00*SB3 ELSEIF(IFL.EQ.1) THEN A0=Exp(-0.2740E+01-0.7987E-01*SB -0.9015E+00*SB2-0.9872E-01*SB3) A1=-0.3909E+00+0.1244E+00*SB -0.4487E-01*SB2+0.1277E-01*SB3 A2= 0.9163E+01+0.2823E+00*SB -0.7720E+00*SB2-0.9360E-02*SB3 A3= 0.1080E+02-0.3915E+01*SB -0.1153E+01*SB2+0.2649E+01*SB3 A4= 0.9894E+00-0.1647E+00*SB -0.9426E-02*SB2+0.2945E-02*SB3 A5=-0.3395E+00+0.6998E+00*SB +0.7000E+00*SB2-0.6730E-01*SB3 ELSEIF(IFL.EQ.2) THEN A0=Exp(-0.2449E+01-0.3513E+01*SB +0.4529E+01*SB2-0.2031E+01*SB3) A1=-0.4050E+00+0.3411E+00*SB -0.3669E+00*SB2+0.1109E+00*SB3 A2= 0.7470E+01-0.2982E+01*SB +0.5503E+01*SB2-0.2419E+01*SB3 A3= 0.1503E+02+0.1638E+01*SB -0.8772E+01*SB2+0.3852E+01*SB3 A4= 0.1137E+01-0.1006E+01*SB +0.1485E+01*SB2-0.6389E+00*SB3 A5=-0.5299E+00+0.3160E+01*SB -0.3104E+01*SB2+0.1219E+01*SB3 ELSEIF(IFL.EQ.3) THEN A0=Exp(-0.3640E+01+0.1250E+01*SB -0.2914E+01*SB2+0.8390E+00*SB3) A1=-0.3595E+00-0.5259E-01*SB +0.3122E+00*SB2-0.1642E+00*SB3 A2= 0.7305E+01+0.9727E+00*SB -0.9788E+00*SB2-0.5193E-01*SB3 A3= 0.1198E+02-0.1799E+02*SB +0.2614E+02*SB2-0.1091E+02*SB3 A4= 0.9882E+00-0.6101E+00*SB +0.9737E+00*SB2-0.4935E+00*SB3 A5=-0.1186E+00-0.3231E+00*SB +0.3074E+01*SB2-0.1274E+01*SB3 ELSEIF(IFL.EQ.4) THEN A0=SB**0.1122E+01*Exp(-0.3718E+01-0.1335E+01*SB +0.1651E-01*SB2) A1=-0.4719E+00+0.7509E+00*SB -0.8420E+00*SB2+0.2901E+00*SB3 A2= 0.6194E+01-0.1641E+01*SB +0.4907E+01*SB2-0.2523E+01*SB3 A3= 0.4426E+01-0.4270E+01*SB +0.6581E+01*SB2-0.3474E+01*SB3 A4= 0.2683E+00+0.9876E+00*SB -0.7612E+00*SB2+0.1780E+00*SB3 A5=-0.4547E+00+0.4410E+01*SB -0.3712E+01*SB2+0.1245E+01*SB3 ELSEIF(IFL.EQ.5) THEN A0=SB**0.9838E+00*Exp(-0.2548E+01-0.7660E+01*SB +0.3702E+01*SB2) A1=-0.3122E+00-0.2120E+00*SB +0.5716E+00*SB2-0.3773E+00*SB3 A2= 0.6257E+01-0.8214E-01*SB -0.2537E+01*SB2+0.2981E+01*SB3 A3=-0.6723E+00+0.2131E+01*SB +0.9599E+01*SB2-0.7910E+01*SB3 A4= 0.9169E-01+0.4295E-01*SB -0.5017E+00*SB2+0.3811E+00*SB3 A5= 0.2402E+00+0.2656E+01*SB -0.1586E+01*SB2+0.2880E+00*SB3 ELSEIF(IFL.EQ.6) THEN A0=SB**0.1001E+01*Exp(-0.6934E+01+0.3050E+01*SB -0.6943E+00*SB2) A1=-0.1713E+00-0.5167E+00*SB +0.1241E+01*SB2-0.1703E+01*SB3 A2= 0.6169E+01+0.3023E+01*SB -0.1972E+02*SB2+0.1069E+02*SB3 A3= 0.4439E+01-0.1746E+02*SB +0.1225E+02*SB2+0.8350E+00*SB3 A4= 0.5458E+00-0.4586E+00*SB +0.9089E+00*SB2-0.4049E+00*SB3 A5= 0.3207E+01-0.3362E+01*SB +0.5877E+01*SB2-0.7659E+01*SB3 ENDIF P012=A0*(X**A1)*((1.-X)**A2) P34=(1.+A3*(X**A4)) P5=(LOG(1.+1./X))**A5 SEA=P012*P34*P5 C Add valence part IF(IIQ.NE.2.AND.IIQ.NE.4) THEN STRUC=SEA GO TO 9999 ELSEIF(IIQ.EQ.2) THEN A0=Exp( 0.1907E+00+0.4205E-01*SB +0.2752E+00*SB2-0.3171E+00*SB3) A1= 0.4611E+00+0.2331E-01*SB -0.3403E-01*SB2+0.3174E-01*SB3 A2= 0.3504E+01+0.5739E+00*SB +0.2676E+00*SB2-0.1553E+00*SB3 A3= 0.7452E+01-0.6742E+01*SB +0.2849E+01*SB2-0.1964E+00*SB3 A4= 0.1116E+01-0.3435E+00*SB +0.2865E+00*SB2-0.1288E+00*SB3 A5= 0.6659E-01+0.2714E+00*SB -0.2688E+00*SB2+0.2763E+00*SB3 ELSEIF(IIQ.EQ.4) THEN A0=Exp( 0.1141E+00+0.4764E+00*SB -0.1745E+01*SB2+0.7728E+00*SB3) A1= 0.4275E+00-0.1290E+00*SB +0.3609E+00*SB2-0.1689E+00*SB3 A2= 0.3000E+01+0.2946E+01*SB -0.4117E+01*SB2+0.1989E+01*SB3 A3=-0.1302E+01+0.2322E+01*SB -0.4258E+01*SB2+0.2109E+01*SB3 A4= 0.2586E+01-0.1920E+00*SB -0.3754E+00*SB2+0.2731E+00*SB3 A5=-0.2251E+00-0.5374E+00*SB +0.2245E+01*SB2-0.1034E+01*SB3 ENDIF P012=A0*(X**A1)*((1.-X)**A2) P34=(1.+A3*(X**A4)) P5=(LOG(1.+1./X))**A5 VAL=P012*P34*P5 STRUC=VAL+SEA GO TO 9999 C C Calculate CTEQ5L distribution for type IIQ C Uses auxiliary function CTEQ5L by Pumplin to do real work C 4000 CONTINUE Q5L=SQRT(QSQ) X5L=X IFL=IIQ/2 IF(IFL.GE.3.OR.2*IFL.NE.IIQ) IFL=-IFL IF(IFL.EQ.-1) THEN SUM5L=CTEQ5L(-1,X5L,Q5L) RAT5L=CTEQ5L(-2,X5L,Q5L) STRUC=X5L*SUM5L/(1.D0+RAT5L) ELSEIF(IFL.EQ.-2) THEN SUM5L=CTEQ5L(-1,X5L,Q5L) RAT5L=CTEQ5L(-2,X5L,Q5L) STRUC=X5L*SUM5L*RAT5L/(1.D0+RAT5L) ELSEIF(IFL.GE.-5.AND.IFL.LE.5) THEN STRUC=X5L*CTEQ5L(IFL,X5L,Q5L) ELSE STRUC=0 ENDIF GO TO 9999 C C Calculate PDFLIB distributions and return one for type IIQ. C +SELF,IF=PDFLIB 9000 CONTINUE DX=X DSCALE=DSQRT(DBLE(QSQ)) CALL PFTOPDG(DX,DSCALE,DXPDF) STRUC=DXPDF(IQMAP(IIQ)) +SELF C C Require minimum value for STRUC C 9999 IF(STRUC.LT.SFMIN) STRUC=SFMIN RETURN END +EOD +DECK,STRUCW FUNCTION STRUCW(XW,IW,IH) C C LONGITUDINAL W STRUCTURE FUNCTIONS CALCULATED BY CONVOLUTION C OF EHLQ STRUCTURE FUNCTIONS AT Q**2=AMW**2 WITH F(W/Q) FROM C DAWSON, N.P. B249, 42 (1985). C IW = 1 2 3 4 C GM W+ W- Z0 C WARNING: DEFAULT VALUES ONLY FOR LAMBDA, SIN2W, ETC. C +SELF,IF=DOUBLE. DOUBLE PRECISION X,XLOG +SELF. C FOLLOWING CONSTANTS ARE (CV**2+CA**2)/(4*PI**2) DATA CVAW/2.701E-3/,CVAZUU/1.017E-3/,CVAZDD/1.298E-3/ C C STATEMENT FUNCTIONS CALCULATED BY INTEGRATING EACH TERM IN C EHLQ PARAMETERIZATION USING SMP 1.5.0. C C FROM STRUCW2.EX FUVAL(X) = 5.769575427 - 10.13681547*X + 3.042561145*XLOG - $ 0.2798411214*(1./X) - 0.3404284678*(XLOG/X) + 8.296794608*(X**2) $ - 6.017283047*(X**3) + 3.548706099*(X**4) - 1.560232679*(X**5) $ + 0.4342326806*(X**6) - 0.05513649922*(X**7) C FDVAL(X) = 2.533753356 - 4.57001915*X + 0.9589133982*XLOG - $ 0.307417692*(1./X) - 0.1793690733*(XLOG/X) + 4.566485508*(X**2) $ - 3.937617129*(X**3) + 2.773480477*(X**4) - 1.540248513*(X**5) $ + 0.6183097947*(X**6) - 0.1542126064*(X**7) + $ 0.0174859553*(X**8) C FUSEA(X) = -5.503869566 + 15.20985662*X - 5.166205929*XLOG - $ 1.728208206*(1./X) - 0.4215945253*(XLOG/X) - 18.82164974*(X**2) $ + 24.27679709*(X**3) - 27.22445715*(X**4) + 24.98752188*(X**5) $ - 18.12394891*(X**6) + 10.06144542*(X**7) - 4.106763252*(X**8) $ + 1.15847115*(X**9) - 0.2014529514*(X**10) + $ 0.01625760301*(X**11) C FDSEA(X) = -5.478593775 + 15.1097528*X - 5.581750835*XLOG - $ 1.987547927*(1./X) - 0.4944113864*(XLOG/X) - 17.23528157*(X**2) $ + 20.59071315*(X**3) - 21.48775889*(X**4) + 18.40750425*(X**5) $ - 12.46901771*(X**6) + 6.45303238*(X**7) - 2.445316084*(X**8) + $ 0.6363027326*(X**9) - 0.1011660335*(X**10) + $ 0.007376682094*(X**11) C GUVAL1(X) = 6.650062246 + 1.480836233*X - 3.536793901*XLOG - $ 5.08758928*(1./X) - 2.458893299*(XLOG/X) - $ 0.4159265541*(XLOG**2/X) - 0.03949356966*(XLOG**3/X) - $ 0.002175877338*(XLOG**4/X) - 6.382577207E-5*(XLOG**5/X) - $ 7.324244818E-7*(XLOG**6/X) + 0.575121435*(X*XLOG) + $ 0.09704190061*(X*XLOG**2) + 791./90953.*(X *XLOG**3) GUVAL2(X) = $ 3.962955366E-4*(X*XLOG**4) + 6.591820335E-6*(X *XLOG**5) - $ 0.07706665525*(X**2*XLOG) - 0.01260088982*(X**2*XLOG**2) - $ 0.001080476729*(X**2*XLOG**3) - 4.647425231E-5*(X**2*XLOG**4) - $ 7.324244829E-7*(X**2*XLOG**5) - 0.2027508558*(X**2) - $ 0.6721633358*(XLOG**2) - 0.07339139987*(XLOG**3) - $ 0.004744695259*(XLOG**4) - 1.651100349E-4*XLOG**5 - $ 2.197273446E-6*XLOG**6 C GDVAL1(X) = 2.403815112 + 1.359504335*X - 2.144999226*XLOG - $ 2.357471591*(1./X) - 1.13339787*(XLOG/X) - $ 0.2003574358*(XLOG**2/X) - 0.02221455952*(XLOG**3/X) - $ 0.001601991722*(XLOG**4/X) - 6.878677010E-5*(XLOG**5/X) - $ 1.323789434E-6*(XLOG**6/X) + 0.4984901703*(X*XLOG) + $ 0.09080940556*(X*XLOG**2) + 0.01045471879*(X *XLOG**3) GDVAL2(X) = $ 7.339489291E-4*(X*XLOG**4) + 2.382820980E-5*(X *XLOG**5) - $ 0.1348586553*(X**2*XLOG) - 0.02441501092*(X**2*XLOG**2) - $ 0.002734669503*(X**2*XLOG**3) - 1.807502877E-4*(X**2*XLOG**4) - $ 5.295157736E-6*(X**2*XLOG**5) + 0.01826324487*(X**3*XLOG) + $ 0.003291926818*(X**3*XLOG**2) + 3.636001057E-4*(X**3*XLOG**3) + $ 2.342115438E-5*(X**3*XLOG**4) + 6.618947159E-7*(X**3*XLOG**5) - $ 0.3679347826*(X**2) + 0.04985470259*(X**3) - $ 0.3928663839*(XLOG**2) - 0.04732954832*(XLOG**3) - $ 0.003974205548*( XLOG**4) - 2.116051876E-4*XLOG**5 - $ 5.295157736E-6*XLOG**6 C GUSEA1(X) = -0.8251281831 + 1.555766474*X - 0.476618796*XLOG - $ 0.157877015*(1./X) + 0.3273497735*(XLOG/X) + $ 0.1184829659*(XLOG**2/X) + 0.01147973292*(XLOG**3/X) + $ 0.001370332595*(XLOG**4/X) + 4.084139287E-5*(XLOG**5/X) + $ 2.284079310E-6*(XLOG**6/X) - 1.681676555*(X*XLOG) + $ 0.01771802464*(X*XLOG**2) - 0.04546554244*(X *XLOG**3) - $ 3.454606694E-4*(X*XLOG**4) - 1.438969965E-4*(X *XLOG**5) + $ 0.8875664376*(X**2*XLOG) + 0.04051742981*(X**2 *XLOG**2) GUSEA2(X) = $ 0.0254151271*(X**2*XLOG**3) + 4.583985126E-4*(X**2*XLOG**4) + $ 7.994277584E-5*(X**2*XLOG**5) - 0.4492144518*(X**3*XLOG) - $ 0.02965496152*(X**3*XLOG**2) - 0.01288679853*(X**3*XLOG**3) - $ 2.791634921E-4*(X**3*XLOG**4) - 3.997138792E-5*(X**3*XLOG**5) + $ 0.1638328221*(X**4*XLOG) + 0.01250393016*(X**4*XLOG**2) + $ 0.004685172364*(X**4*XLOG**3) + 1.100919901E-4*(X**4*XLOG**4) + $ 1.438969967E-5*(X**4*XLOG**5) - 0.0367848506*(X**5*XLOG) - $ 0.003035305139*(X**5*XLOG**2) - 0.001048416117*(X**5*XLOG**3) - $ 2.579726667E-5*(X**5*XLOG**4) - 3.197711036E-6*(X**5*XLOG**5) + $ 0.003783780648*(X**6*XLOG) + 3.278296157E-4*(X**6*XLOG**2) + $ 1.075296502E-4*(X**6*XLOG**3) + 2.725601849E-6*(X**6*XLOG**4) GUSEA3(X) = $ 3.262970444E-7*(X**6*XLOG**5) - 0.2259054436*(X**2) + $ 0.003364712414*(X**3) + 0.01992787001*(X**4) - 0.007399430903* $ (X**5) + 9.652150086E-4*X**6 + 0.554652844*(XLOG**2) + $ 0.011217842*(XLOG**3) + 0.007692743973*(XLOG**4) + $ 9.402708800E-5*XLOG**5 + 1.598855517E-5*XLOG**6 C GDSEA1(X) = -0.9201807217 + 2.243479849*X - 0.899698589*XLOG - $ 0.3970657521*(1./X) + 0.2818290666*(XLOG/X) + $ 0.120664241*(XLOG**2/X) + 0.01043451714 *(XLOG**3/X) + $ 0.001191246128*(XLOG**4/X) + 3.001102810E-5*(XLOG**5/X) + $ 2.039937816E-6*(XLOG**6/X) - 1.787863927*(X*XLOG) + $ 826./63247.*(X*XLOG**2) - 0.04263009293*(X*XLOG**3) + $ 3.087205491E-5*( X*XLOG**4) - 1.285160824E-4*(X*XLOG**5) + $ 0.9517638436*(X**2*XLOG) + 0.04047432532*(X**2*XLOG**2) + $ 0.02332032497*(X**2*XLOG**3) + 2.208416029E-4*(X**2*XLOG**4) GDSEA2(X) = $ 7.139782355E-5*(X**2*XLOG**5) - 0.4816526149*(X**3*XLOG) - $ 0.02893293689*(X**3*XLOG**2) - 0.01172595961*(X**3*XLOG**3) - $ 1.550444419E-4*(X**3*XLOG**4) - 3.569891178E-5*(X**3*XLOG**5) + $ 0.1755025883*(X**4*XLOG) + 0.01209064681*(X**4*XLOG**2) + $ 0.004244259809*(X**4*XLOG**3) + 6.438373778E-5*(X**4*XLOG**4) + $ 1.285160826E-5*(X**4*XLOG**5) - 0.03937044174*(X**5*XLOG) - $ 0.002920614679*(X**5*XLOG**2) - 9.471446970E-4*(X**5*XLOG**3) - $ 1.549746135E-5*(X**5*XLOG**4) - 2.855912944E-6*(X**5*XLOG**5) GDSEA3(X) = $ 0.004046756409*(X**6*XLOG) + 3.144555106E-4*(X**6*XLOG**2) + $ 9.696129739E-5*(X**6*XLOG**3) + 1.664636351E-6*(X**6*XLOG**4) + $ 2.914196881E-7*(X**6*XLOG**5) - 0.5703745807*(X**2) + $ 0.1676594704*(X**3) - 0.03765961644*(X**4) + $ 0.005180399826*(X**5) - 3.032419889E-4*X**6 + $ 0.5916013402*(XLOG**2) + 0.0113078292*(XLOG**3) + $ 0.007094724813*( XLOG**4) + 3.872242009E-5*XLOG**5 + $ 1.427956471E-5*XLOG**6 C EUVAL(X) = -3.398748694 + 0.6266420937*(1./X) EDVAL(X) = -1.300464877 + 0.2267175031*(1./X) EUSEA(X) = -0.4281951222 + 0.0600001177*(1./X) EDSEA(X) = -0.5744690066 + 0.08143317382*(1./X) C C ENTRY C IF(XW.LE.0..OR.XW.GE.1.) THEN STRUCW=0. RETURN ENDIF X=XW XLOG=LOG(X) C IIW=IW IF(IH.EQ.-1120) THEN IF(IW.EQ.2) IIW=3 IF(IW.EQ.3) IIW=2 ELSEIF(IH.EQ.1220) THEN IF(IW.EQ.2) IIW=3 IF(IW.EQ.3) IIW=2 ENDIF C IF(XW.GT..1) GO TO 1000 C C STRUCW = XW*F(XW) FOR IIW=W+ IN PROTON, XW<.1 IF(IIW.EQ.2) THEN G1=GUVAL1(X) G1=G1+GUVAL2(X) G2=GUSEA1(X) G2=G2+GUSEA2(X) G2=G2+GUSEA3(X) G3=GDSEA1(X) G3=G3+GDSEA2(X) G3=G3+GDSEA3(X) SUM=G1+G2+G3+EUVAL(X)+EUSEA(X)+EDSEA(X) STRUCW=X*CVAW*SUM C STRUCW = XW*F(XW) FOR IIW=W- IN PROTON, XW<.1 ELSEIF(IIW.EQ.3) THEN G1=GDVAL1(X) G1=G1+GDVAL2(X) G2=GDSEA1(X) G2=G2+GDSEA2(X) G2=G2+GDSEA3(X) G3=GUSEA1(X) G3=G3+GUSEA2(X) G3=G3+GUSEA3(X) SUM=G1+G2+G3+EDVAL(X)+EDSEA(X)+EUSEA(X) STRUCW=X*CVAW*SUM C STRUCW=XW*F(XW) FOR IIW=Z0 IN PROTON, XW<.1 ELSEIF(IIW.EQ.4) THEN G1=GUVAL1(X) G1=G1+GUVAL2(X) G2=GUSEA1(X) G2=G2+GUSEA2(X) G2=G2+GUSEA3(X) SUMU=G1+2.*G2+EUVAL(X)+2.*EUSEA(X) G1=GDVAL1(X) G1=G1+GDVAL2(X) G2=GDSEA1(X) G2=G2+GDSEA2(X) G2=G2+GDSEA3(X) SUMD=G1+2.*G2+EDVAL(X)+2.*EDSEA(X) STRUCW=X*(CVAZUU*SUMU+CVAZDD*SUMD) ENDIF IF(STRUCW.LT.0.) STRUCW=0. RETURN C 1000 CONTINUE C C STRUCW=XW*F(XW) FOR IIW=W+ IN PROTON, XW>.1 IF(IIW.EQ.2) THEN F1=FUVAL(X) F2=FUSEA(X) F3=FDSEA(X) SUM=F1+F2+F3 STRUCW=X*CVAW*SUM C STRUCW=XW*F(XW) FOR IIW=W- IN PROTON, XW>.1 ELSEIF(IIW.EQ.3) THEN F1=FDVAL(X) F2=FDSEA(X) F3=FUSEA(X) SUM=F1+F2+F3 STRUCW=X*CVAW*SUM C STRUCW=XW*F(XW) FOR IIW=Z0 IN PROTON, XW>.1 ELSEIF(IIW.EQ.4) THEN F1=FUVAL(X) F2=FUSEA(X) SUMU=F1+2.*F2 F1=FDVAL(X) F2=FDSEA(X) SUMD=F1+2.*F2 STRUCW=X*(CVAZUU*SUMU+CVAZDD*SUMD) ENDIF IF(STRUCW.LT.0.) STRUCW=0. RETURN END +EOD +DECK,SZJJ1 REAL*8 FUNCTION SZJJ1(P1, P2, P3, P4, P5,IM1,IM2) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/avg over colors C and helicities C for the point in phase space P1,P2,P3,P4,... C for process : q(im1) q~(im1) -> z q(im2) q~(im2) C with Madgraph codes IM1 != IM2 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM1,IM2 C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ1 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ1 = 0D0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ1(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1,IM2) SZJJ1 = SZJJ1 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ1 = SZJJ1 / 4D0 END +EOD +DECK,SZJJ2 REAL*8 FUNCTION SZJJ2(P1, P2, P3, P4, P5, IM) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/ave over colors C for the point in phase space P1,P2,P3,P4,P5 C and helicity NHEL(1)... C for the process: g g -> z q(im) qb(im) C with Madgraph code IM C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ2 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ2 = 0D0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ2(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) SZJJ2 = SZJJ2 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ2 = SZJJ2 / 4D0 END +EOD +DECK,SZJJ3 REAL*8 FUNCTION SZJJ3(P1, P2, P3, P4, P5, IM) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/ave over colors C for the point in phase space P1,P2,P3,P4,P5 C and helicity NHEL(1)... C for the process: q(im) qb(im) -> z g g C with Madgraph code IM C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ3 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ3 = 0D0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ3(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) SZJJ3 = SZJJ3 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ3 = SZJJ3 / 4D0 END +EOD +DECK,SZJJ4 REAL*8 FUNCTION SZJJ4(P1, P2, P3, P4, P5,IM) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/ave over colors C for the point in phase space P1,P2,P3,P4,P5 C and helicity NHEL(1)... C for the process: q(im) qb(im) -> z q(im) qb(im) C with Madgraph code IM C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ4 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ4 = 0D0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ4(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) SZJJ4 = SZJJ4 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ4 = SZJJ4 / 4D0 END +EOD +DECK,SZJJ5 REAL*8 FUNCTION SZJJ5(P1, P2, P3, P4, P5, IM1, IM2) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/avg over colors C and helicities C for the point in phase space p1,p2,p3,p4,... C C for process : q(im1) q(im2) -> z q(im1) q(im2) C with Madgraph codes IM1 != IM2 C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM1,IM2 C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ5 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ5 = 0d0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ5(P1, P2, P3, P4, P5,NHEL(1,IHEL), IM1,IM2) SZJJ5 = SZJJ5 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ5 = SZJJ5 / 4D0 END +EOD +DECK,SZJJ6 REAL*8 FUNCTION SZJJ6(P1, P2, P3, P4, P5, IM1) C C Function generated by Madgraph + hand coding C Returns amplitude squared summed/avg over colors C and helicities C for the point in phase space p1,p2,p3,p4,... C C for process : q(im1) q(im1) -> z q(im1) q(im1) C IMPLICIT NONE C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM1 C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ6 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ6 = 0d0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ6(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1) SZJJ6 = SZJJ6 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ6 = SZJJ6 / 4D0 END +EOD +DECK,SZJJ7 REAL*8 FUNCTION SZJJ7(P1, P2, P3, P4, P5, IM1) C C Function generated by Madgraph C Returns amplitude squared summed/avg over colors C and helicities C for the point in phase space p1,p2,p3,p4,... C C for process : g q(im1) -> z g q(im1) C +SELF,IF=IMPNONE IMPLICIT NONE +SELF C C CONSTANTS C INTEGER NEXTERNAL, NCOMB PARAMETER (NEXTERNAL=5, NCOMB= 48) C C ARGUMENTS C REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3) INTEGER IM1 C C LOCAL VARIABLES C INTEGER NHEL(NEXTERNAL,NCOMB),NTRY REAL*8 T REAL*8 ZJJ7 INTEGER IHEL LOGICAL GOODHEL(NCOMB) DATA GOODHEL/NCOMB*.FALSE./ DATA NTRY/0/ DATA (NHEL(IHEL, 1),IHEL=1,5) / -1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 2),IHEL=1,5) / -1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 3),IHEL=1,5) / -1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 4),IHEL=1,5) / -1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 5),IHEL=1,5) / -1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 6),IHEL=1,5) / -1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 7),IHEL=1,5) / -1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 8),IHEL=1,5) / -1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 9),IHEL=1,5) / -1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 13),IHEL=1,5) / -1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 14),IHEL=1,5) / -1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 15),IHEL=1,5) / -1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 16),IHEL=1,5) / -1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 17),IHEL=1,5) / -1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 18),IHEL=1,5) / -1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 19),IHEL=1,5) / -1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 20),IHEL=1,5) / -1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 21),IHEL=1,5) / -1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 22),IHEL=1,5) / -1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 23),IHEL=1,5) / -1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 24),IHEL=1,5) / -1, 1, 1, 1, 1/ DATA (NHEL(IHEL, 25),IHEL=1,5) / 1, -1, -1, -1, -1/ DATA (NHEL(IHEL, 26),IHEL=1,5) / 1, -1, -1, -1, 1/ DATA (NHEL(IHEL, 27),IHEL=1,5) / 1, -1, -1, 1, -1/ DATA (NHEL(IHEL, 28),IHEL=1,5) / 1, -1, -1, 1, 1/ DATA (NHEL(IHEL, 29),IHEL=1,5) / 1, -1, 0, -1, -1/ DATA (NHEL(IHEL, 30),IHEL=1,5) / 1, -1, 0, -1, 1/ DATA (NHEL(IHEL, 31),IHEL=1,5) / 1, -1, 0, 1, -1/ DATA (NHEL(IHEL, 32),IHEL=1,5) / 1, -1, 0, 1, 1/ DATA (NHEL(IHEL, 33),IHEL=1,5) / 1, -1, 1, -1, -1/ DATA (NHEL(IHEL, 34),IHEL=1,5) / 1, -1, 1, -1, 1/ DATA (NHEL(IHEL, 35),IHEL=1,5) / 1, -1, 1, 1, -1/ DATA (NHEL(IHEL, 36),IHEL=1,5) / 1, -1, 1, 1, 1/ DATA (NHEL(IHEL, 37),IHEL=1,5) / 1, 1, -1, -1, -1/ DATA (NHEL(IHEL, 38),IHEL=1,5) / 1, 1, -1, -1, 1/ DATA (NHEL(IHEL, 39),IHEL=1,5) / 1, 1, -1, 1, -1/ DATA (NHEL(IHEL, 40),IHEL=1,5) / 1, 1, -1, 1, 1/ DATA (NHEL(IHEL, 41),IHEL=1,5) / 1, 1, 0, -1, -1/ DATA (NHEL(IHEL, 42),IHEL=1,5) / 1, 1, 0, -1, 1/ DATA (NHEL(IHEL, 43),IHEL=1,5) / 1, 1, 0, 1, -1/ DATA (NHEL(IHEL, 44),IHEL=1,5) / 1, 1, 0, 1, 1/ DATA (NHEL(IHEL, 45),IHEL=1,5) / 1, 1, 1, -1, -1/ DATA (NHEL(IHEL, 46),IHEL=1,5) / 1, 1, 1, -1, 1/ DATA (NHEL(IHEL, 47),IHEL=1,5) / 1, 1, 1, 1, -1/ DATA (NHEL(IHEL, 48),IHEL=1,5) / 1, 1, 1, 1, 1/ C ---------- C BEGIN CODE C ---------- SZJJ7 = 0d0 NTRY=NTRY+1 DO IHEL=1,NCOMB IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN T=ZJJ7(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1) SZJJ7 = SZJJ7 + T IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN GOODHEL(IHEL)=.TRUE. ENDIF ENDIF ENDDO SZJJ7 = SZJJ7 / 4D0 END +EOD +DECK,TIMER. SUBROUTINE TIMER(IT) C C CALL SYSTEM CPU CLOCK -- MACHINE DEPENDENT. C IT=1 FOR RUN START TIME. C IT=2 FOR RUN STOP TIME. C +CDE,ITAPES +CDE,TIMES DIMENSION TIMES(2) EQUIVALENCE (TIMES(1),TIME1) DIMENSION TTT(2) +SELF,IF=VAX. INTEGER CPUTIM(2),ITMLST(4),NHSEC EXTERNAL JPI$_CPUTIM +SELF. C C DEFAULT IS TO RETURN ZERO. TNOW=0. +SELF,IF=CDC,IF=NOCERN. C SECOND GIVES CPU TIME ON CDC. CALL SECOND(TNOW) +SELF,IF=ETA,IF=NOCERN. C SECOND GIVES CPU TIME ON ETA. TNOW=SECOND() +SELF,IF=IBMRT,IF=NOCERN. C MCLOCK GIVES CPU TIME ON IBM RS/6000. TNOW=FLOAT(MCLOCK())/60. +SELF,IF=SGI,IF=NOCERN. C ETIME GIVES CPU TIME ON SILICON GRAPHICS. TNOW=ETIME(TTT) +SELF,IF=SUN,IF=NOCERN. C ETIME GIVES CPU TIME ON SUN. TNOW=ETIME(TTT) +SELF,IF=VAX,IF=NOCERN. C VAX HAS NO FORTRAN FUNCTION FOR CPU TIME. C FOLLOWING PROVIDED BY T. KILLIAN ITMLST(1)=ISHFT(%LOC(JPI$_CPUTIM),16)+4 ITMLST(2)=%LOC(NHSEC) ITMLST(3)=0 ITMLST(4)=0 CALL SYS$GETJPI(,,,ITMLST,,,) TNOW=.01*NHSEC +SELF,IF=CERN. CALL TIMEST(1.E7) CALL TIMEX(TNOW) +SELF. TIMES(IT)=TNOW RETURN END +EOD +DECK,TWOJET. SUBROUTINE TWOJET C C Driving routine to generate initial parameters for jets, C assuming zero initial transverse momentum, ie PT(1)=PT(2). C C Parameters are PT,YJ,PHI with P,YJ,XJ as dependent variables, C where YJ=RAPIDITY, XJ=Feynman X. C All parameters are stored in COMMON/JETPAR/. C Cross section is called from NOGOOD. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,IDRUN +CDE,ITAPES +CDE,KEYS +CDE,MBPAR +CDE,PJETS +CDE,PINITS +CDE,JETLIM +CDE,PTPAR +CDE,JETPAR +CDE,PRIMAR +CDE,PARTCL +CDE,CONST +CDE,JETSIG +CDE,TOTALS +CDE,ISLOOP +CDE,SSTYPE +CDE,XMSSM C REAL ACOSH,XXX,WTFCN,PPP,RANF,SIGN,SGN,AMQ1,AMASS,AMQ2 REAL PPLUS,PMINUS,PSUM3,PSUM4,PPL,PMN,SQ1,SQ2,ROOT,P1PL,P1MN REAL P2PL,P2MN,AMI1,AMI2 INTEGER NREJ,I,II,IS,IFL1,IFL2 REAL X(2) EQUIVALENCE (X(1),X1) LOGICAL NOGOOD LOGICAL YGENJ INTEGER LISTJ(17),LISTW(4),LISTSS(85),LISTSM(30) C C SUSY IDENT codes from /SSTYPE/. (Fortran 77 allows - signs C in parameter statements but not data statements.) INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1, $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2, $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2 PARAMETER (MSUPL=-ISUPL) PARAMETER (MSDNL=-ISDNL) PARAMETER (MSSTL=-ISSTL) PARAMETER (MSCHL=-ISCHL) PARAMETER (MSBT1=-ISBT1) PARAMETER (MSTP1=-ISTP1) PARAMETER (MSUPR=-ISUPR) PARAMETER (MSDNR=-ISDNR) PARAMETER (MSSTR=-ISSTR) PARAMETER (MSCHR=-ISCHR) PARAMETER (MSBT2=-ISBT2) PARAMETER (MSTP2=-ISTP2) PARAMETER (MSW1=-ISW1) PARAMETER (MSW2=-ISW2) PARAMETER (MSNEL=-ISNEL) PARAMETER (MSEL=-ISEL) PARAMETER (MSNML=-ISNML) PARAMETER (MSMUL=-ISMUL) PARAMETER (MSNTL=-ISNTL) PARAMETER (MSTAU1=-ISTAU1) PARAMETER (MSER=-ISER) PARAMETER (MSMUR=-ISMUR) PARAMETER (MSTAU2=-ISTAU2) C DATA LISTSS/ISGL, $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1, $ISTP1,MSTP1, $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2, $ISTP2,MSTP2, $ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4, $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,ISNTL,MSNTL, $ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,ISTAU2,MSTAU2, $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13, $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/ DATA LISTSM/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13, $14,-14,15,-15,16,-16,10,80,-80,90,81/ DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,7,-7,8,-8/ DATA LISTW/10,80,-80,90/ C Inverse hyperbolic cosine function ACOSH(XXX)=ALOG(XXX+SQRT(XXX**2-1.)) WTFCN(PPP)=2.*PPP*PTGEN2*PTGEN3*PPP**((PTGEN3-1.)/PTGEN3) C C Initialize C NPTCL=0 PHI(1)=PHIMIN(1)+(PHIMAX(1)-PHIMIN(1))*RANF() PHI(2)=AMOD(PHI(1)+PI,2.*PI) NREJ=-1 SIGMA=0. WT=1. IF(.NOT.FIXPT(2)) GOTO 101 FIXPT(1)=.TRUE. PT(1)=PT(2) 101 CONTINUE IF(FIXPT(1)) GOTO 400 DO 110 I=1,2 IF(FIXP(I)) GOTO 200 IF(FIXXJ(I)) GOTO 300 110 CONTINUE C C Genetate PT and YJ with no variables fixed C 111 NREJ=NREJ+1 IF(NREJ.GT.NTRIES) GO TO 910 SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN) NKINPT=NKINPT+1 SIGMA=0. WT=1. C Generate PT with a power law distribution PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3 PT(2)=PT(1) SIGMAX=PTFUN1*PT(1)**PTFUN2 C GENERATE FLAT IN YJ, CALCULATE CORRESPONDING TH DO 115 I=1,2 IF(FIXYJ(I)) GOTO 115 IF(.NOT.YGENJ(I)) GOTO 111 115 CONTINUE DO 116 I=1,2 P(I)=PT(I)/STH(I) IF(P(I).LT.PMIN(I).OR.P(I).GT.PMAX(I)) GOTO 111 XJ(I)=P(I)*CTH(I)/HALFE IF(XJ(I).LT.XJMIN(I).OR.XJ(I).GT.XJMAX(I)) GOTO 111 116 CONTINUE WT=WT*WTFCN(PT(1)) IF(NOGOOD(1)) GOTO 111 SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN) NKEEP=NKEEP+1 GO TO 500 C C Generate PT and YJ fixing P C 200 CONTINUE II=3-I 211 NREJ=NREJ+1 IF(NREJ.GT.NTRIES) GO TO 910 NKINPT=NKINPT+1 WT=0. IF(FIXYJ(I)) GOTO 212 C Generate PT with a power law distribution PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3 SIGMAX=PTFUN1*PT(1)**PTFUN2 PT(2)=PT(1) C Given PT, TH is fixed except for a sign STH(I)=PT(I)/P(I) SIGN=1.0 IF(RANF().GT.0.5) SIGN=-1.0 CTH(I)=SIGN*SQRT(1.-STH(I)**2) TH(I)=ATAN2(STH(I),CTH(I)) YJ(I)=-ALOG(TAN(TH(I)/2.)) IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GOTO 211 GOTO 213 212 PT(1)=P(I)*STH(I) 213 CONTINUE XJ(I)=P(I)*CTH(I)/HALFE IF(XJ(I).LT.XJMIN(I).OR.XJ(I).GT.XJMAX(I)) GOTO 211 IF(FIXP(II)) GOTO 220 IF(FIXXJ(II)) GOTO 230 IF(FIXYJ(II)) GOTO 215 IF(.NOT.YGENJ(II)) GOTO 211 215 CONTINUE P(II)=PT(II)/STH(II) IF(P(II).LT.PMIN(II).OR.P(II).GT.PMAX(II)) GOTO 211 XJ(II)=P(II)*CTH(II)/HALFE IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 211 GOTO 250 220 STH(II)=PT(II)/P(II) SGN=1.0 IF(RANF().GT.0.5) SGN=-1.0 CTH(II)=SGN*SQRT(1.-STH(II)**2) TH(II)=ATAN2(STH(II),CTH(II)) YJ(II)=-ALOG(TAN(TH(II)/2.)) IF(YJ(II).LT.YJMIN(II).OR.YJ(II).GT.YJMAX(II)) GOTO 211 XJ(II)=P(II)*CTH(II)/HALFE IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 211 GOTO 250 230 TH(II)=ATAN2(PT(II),XJ(II)*HALFE) YJ(II)=-ALOG(TAN(TH(II)/2.)) IF(YJ(II).LT.YJMIN(II).OR.YJ(II).GT.YJMAX(II)) GOTO 211 CTH(II)=COS(TH(II)) STH(II)=SIN(TH(II)) 250 CONTINUE IF(NOGOOD(1)) GOTO 211 NKEEP=NKEEP+1 GO TO 500 C C Generate PT and YJ at fixed XJ C 300 CONTINUE II=3-I 311 NREJ=NREJ+1 IF(NREJ.GT.NTRIES) GO TO 910 NKINPT=NKINPT+1 WT=0. C Generate PT with a power law distribution PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3 SIGMAX=PTFUN1*PT(1)**PTFUN2 PT(2)=PT(1) TH(I)=ATAN2(PT(I),XJ(I)*HALFE) YJ(I)=-ALOG(TAN(TH(I)/2.)) IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GOTO 311 CTH(I)=COS(TH(I)) STH(I)=SIN(TH(I)) P(I)=PT(I)/STH(I) IF(FIXYJ(II)) GOTO 315 IF(FIXP(II)) GOTO 314 YJ(II)=YJMIN(II)+(YJMAX(II)-YJMIN(II))*RANF() TH(II)=2.*ATAN(EXP(-YJ(II))) CTH(II)=COS(TH(II)) STH(II)=SIN(TH(II)) GOTO 315 314 CONTINUE STH(II)=PT(II)/P(II) CTH(II)=SQRT(1.-STH(II)**2) IF(RANF().GT.0.5) CTH(II)=-CTH(II) TH(II)=ATAN2(STH(II),CTH(II)) YJ(II)=-ALOG(TAN(TH(II)/2.)) 315 CONTINUE P(II)=PT(II)/STH(II) XJ(II)=P(II)*CTH(II)/HALFE IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 311 IF(NOGOOD(1)) GOTO 311 NKEEP=NKEEP+1 GO TO 500 C C Generate YJ at fixed PT C 400 CONTINUE PT(2)=PT(1) 411 NREJ=NREJ+1 IF(NREJ.GT.NTRIES) GO TO 910 NKINPT=NKINPT+1 WT=0. DO 415 I=1,2 IF(FIXYJ(I)) GOTO 415 IF(FIXP(I)) GOTO 413 IF(.NOT.YGENJ(I)) GO TO 411 GOTO 414 413 CONTINUE IS=1 IF(RANF().GT.0.5) IS=2 CTH(I)=CTHS(IS,I) TH(I)=THS(IS,I) YJ(I)=YJS(IS,I) 414 CONTINUE P(I)=PT(I)/STH(I) XJ(I)=P(I)*CTH(I)/HALFE 415 CONTINUE IF(NOGOOD(1)) GOTO 411 NKEEP=NKEEP+1 C C Reset /JETPAR/ C 500 CONTINUE IF(KEYS(1)) THEN IFL1=LISTJ(JETTYP(1)) IFL2=LISTJ(JETTYP(2)) AMQ1=AMASS(IFL1) AMQ2=AMASS(IFL2) AMI1=AMASS(LISTJ(INITYP(1))) AMI2=AMASS(LISTJ(INITYP(2))) CALL TWOKIN(AMI1,AMI2,AMQ1,AMQ2) ELSEIF(KEYS(5).OR.(KEYS(10).AND.GOMSSM)) THEN IFL1=LISTSS(JETTYP(1)) IFL2=LISTSS(JETTYP(2)) AMQ1=AMASS(IFL1) AMQ2=AMASS(IFL2) CALL TWOKIN(0.,0.,AMQ1,AMQ2) ELSEIF(KEYS(6)) THEN IFL1=LISTW(JETTYP(1)) IFL2=LISTW(JETTYP(2)) AMQ1=AMASS(IFL1) AMQ2=AMASS(IFL2) CALL TWOKIN(0.,0.,AMQ1,AMQ2) ELSEIF(KEYS(8)) THEN IF(JETTYP(1).LE.13) THEN IFL1=LISTJ(JETTYP(1)) ELSE IFL1=10 ENDIF IF(JETTYP(2).LE.13) THEN IFL2=LISTJ(JETTYP(2)) ELSE IFL2=10 ENDIF AMQ1=AMASS(IFL1) AMQ2=AMASS(IFL2) CALL TWOKIN(0.,0.,AMQ1,AMQ2) ELSEIF(KEYS(10).AND.(.NOT.GOMSSM)) THEN IFL1=LISTSM(JETTYP(1)) IFL2=LISTSM(JETTYP(2)) AMQ1=AMASS(IFL1) AMQ2=AMASS(IFL2) CALL TWOKIN(0.,0.,AMQ1,AMQ2) ENDIF C C Set PBEAM and PJETS C PBEAM(1)=(1.-X1)*HALFE PBEAM(2)=(1.-X2)*HALFE DO 501 I=1,2 PJETS(3,I)=P(I)*CTH(I) PJETS(1,I)=PT(I)*COS(PHI(I)) PJETS(2,I)=PT(I)*SIN(PHI(I)) IF(KEYS(1)) THEN IDJETS(I)=LISTJ(JETTYP(I)) ELSEIF(KEYS(5).OR.(KEYS(10).AND.GOMSSM)) THEN IDJETS(I)=LISTSS(JETTYP(I)) ELSEIF(KEYS(6)) THEN IDJETS(I)=LISTW(JETTYP(I)) ELSEIF(KEYS(8)) THEN IDJETS(1)=IFL1 IDJETS(2)=IFL2 ELSEIF(KEYS(10)) THEN IDJETS(I)=LISTSM(JETTYP(I)) ENDIF PJETS(5,I)=AMASS(IDJETS(I)) PJETS(4,I)=SQRT(P(I)**2+PJETS(5,I)**2) 501 CONTINUE C C Set PINITS C DO 600 I=1,2 IDINIT(I)=LISTJ(INITYP(I)) PINITS(5,I)=AMASS(IDINIT(I)) PPLUS=X(I)*ECM PMINUS=PINITS(5,I)**2/PPLUS PINITS(4,I)=.5*(PPLUS+PMINUS) PINITS(3,I)=.5*(PPLUS-PMINUS)*(3-2*I) PINITS(2,I)=0. PINITS(1,I)=0. 600 CONTINUE C Calculate PINITS exactly. PSUM3=PJETS(3,1)+PJETS(3,2) PSUM4=PJETS(4,1)+PJETS(4,2) IF(PSUM3.GT.0.) THEN PPL=PSUM4+PSUM3 PMN=SHAT/PPL ELSE PMN=PSUM4-PSUM3 PPL=SHAT/PMN ENDIF SQ1=PINITS(5,1)**2 SQ2=PINITS(5,2)**2 ROOT=SQRT((PPL*PMN-SQ1-SQ2)**2-4.*SQ1*SQ2) P1PL=(PPL*PMN+SQ1-SQ2+ROOT)/(2.*PMN) P1MN=SQ1/P1PL P2MN=(PPL*PMN+SQ2-SQ1+ROOT)/(2.*PPL) P2PL=SQ2/P2MN PINITS(4,1)=.5*(P1PL+P1MN) PINITS(3,1)=.5*(P1PL-P1MN) PINITS(4,2)=.5*(P2PL+P2MN) PINITS(3,2)=.5*(P2PL-P2MN) RETURN C C Error C 910 CALL PRTEVT(0) WRITE(ITLIS,1000) NREJ 1000 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN', $' EVENT. CHECK LIMITS OR INCREASE NTRIES.') STOP 99 END +EOD +DECK,TWOKIN. SUBROUTINE TWOKIN(AMI1,AMI2,AM1,AM2) C C Given P,PT,TH,PHI, and initial and final masses AMI1, AMI2, C AM1,AM2, set X1, X2, SHAT, etc. C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,PRIMAR +CDE,JETPAR +CDE,QCDPAR +CDE,CONST C REAL AMI1,AMI2,AM1,AM2,P1PL,P1MN,P2PL,P2MN,E1,E2,PPL,PMN, $ PI1PL,PI1MN,PI2PL,PI2MN,ANEFF,AMASS,ALAMFN C E1=SQRT(P(1)**2+AM1**2) E2=SQRT(P(2)**2+AM2**2) C C For 32-bit machines must use large and small components C carefully, with pbig*psmall = pt**2+am**2. C IF(CTH(1).GT.0.) THEN P1PL=E1+P(1)*CTH(1) P1MN=(PT(1)**2+AM1**2)/P1PL ELSE P1MN=E1-P(1)*CTH(1) P1PL=(PT(1)**2+AM1**2)/P1MN ENDIF IF(CTH(2).GT.0.) THEN P2PL=E2+P(2)*CTH(2) P2MN=(PT(2)**2+AM2**2)/P2PL ELSE P2MN=E2-P(2)*CTH(2) P2PL=(PT(2)**2+AM2**2)/P2MN ENDIF C C Initial light cone momenta. Not symmetric if AMI1 /= AMI2. C PPL=P1PL+P2PL PMN=P1MN+P2MN SHAT=PPL*PMN ALAMFN=SQRT((SHAT-AMI1**2-AMI2**2)**2-4.*(AMI1*AMI2)**2) PI1PL=(SHAT+AMI1**2-AMI2**2+ALAMFN)/(2.*PMN) PI1MN=AMI1**2/PI1PL PI2MN=(SHAT+AMI2**2-AMI1**2+ALAMFN)/(2.*PPL) PI2PL=AMI2**2/PI2MN X1=PI1PL/ECM X2=PI2MN/ECM C C t=(p1-pi1)**2, u=(p1-pi2)**2 C THAT=AM1**2+AMI1**2-P1PL*PI1MN-P1MN*PI1PL UHAT=AM1**2+AMI2**2-P1PL*PI2MN-P1MN*PI2PL C C Q**2 variable from Field, Fox, Wolfram C QSQ=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2) QSQ=AMAX1(QSQ,(AM1+AM2)**2) ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2) ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2)) RETURN END +EOD +DECK,VISAJE CHARACTER*40 FUNCTION VISAJE() +CDE,IDRUN VISAJE = ' ISAJET V7.83 31-JUL-2012 18:59:07' IDVER = 783 RETURN END +EOD +DECK,WHIGGS. SUBROUTINE WHIGGS C C Finish generation of whiggs events started bY TWOJET. C Select W decay modes as allowed by WMODE1, WMODE2. C Generate W decay angles and put vectors in PPAIR. C C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR. +CDE,JETPAR. +CDE,PRIMAR. +CDE,Q1Q2. +CDE,JETSIG. +CDE,CONST. +CDE,QSAVE. +CDE,WCON. +CDE,PJETS. +CDE,PINITS +CDE,KEYS +CDE,HCON +CDE,WWPAR +CDE,XMSSM C DIMENSION X(2),LIST(25),P1WCM(4),P2WCM(4),P1LAB(4),P2LAB(4) 1,PBOOST(4) EQUIVALENCE (X(1),X1) DIMENSION JWWTYP(2) REAL GVQ(2),GAQ(2),GVL(2),GAL(2) REAL X,RND,RANF,CBRWW,AMASS,AM0,AM1,AM2, $E1CM,E2CM,P12CM,CTHCM,STHCM,PHICM,CPHICM,SPHICM,P1WCM,P2WCM, $PBOOST,P1LAB,P2LAB,ZHSIG,ZHMAX INTEGER JWWTYP,JET,JWT,JQ,IQ1,IQ2,LIST,NREJ,NJ0,K REAL BRANCH(12),SUMBR,BETAWH,GAMWH,PZWHCM,CTHD,WHSIG INTEGER IDABS,IDABS1,IDABSJ,IDIABS C DATA LIST/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ C GVQ(1)=.25-2*SIN2W/3. GVQ(2)=-.25+SIN2W/3. GAQ(1)=-.25 GAQ(2)=.25 GVL(1)=.25 GVL(2)=-.25+SIN2W GAL(1)=-.25 GAL(2)=.25 NPAIR=0 IF(KEYS(10).AND..NOT.GOMSSM) THEN JWWTYP(1)=JETTYP(1)-25 JWWTYP(2)=JETTYP(2)-25 ELSEIF(KEYS(10).AND.GOMSSM) THEN JWWTYP(1)=JETTYP(1)-76 JWWTYP(2)=JETTYP(2)-76 ENDIF C C Select W decay modes and put in /JETSET/. First particle C is always the fermion. DO 200 JET=1,2 IDABS=IABS(IDJETS(JET)) IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 200 RND=RANF() JWT=JWWTYP(JET) C Must only consider allowed decays for this mass SUMBR=0. DO 201 JQ=1,12 IQ1=2*JQ IQ2=MATCH(IQ1,JWT) IF(IQ2.EQ.0) THEN BRANCH(JQ)=0. GO TO 201 ENDIF AM1=AMASS(LIST(IQ1)) AM2=AMASS(LIST(IQ2)) IF(AM1+AM2.LT.PJETS(5,JET)) THEN BRANCH(JQ)=RBRWW(JQ,JWT,JET) SUMBR=SUMBR+BRANCH(JQ) ELSE BRANCH(JQ)=0. ENDIF 201 CONTINUE IF(SUMBR.LE.0.) GO TO 998 DO 202 JQ=1,12 202 BRANCH(JQ)=BRANCH(JQ)/SUMBR C CBRWW=0. DO 210 JQ=1,12 CBRWW=CBRWW+BRANCH(JQ) IF(RND.GT.CBRWW) GO TO 210 IQ1=2*JQ IQ2=MATCH(IQ1,JWT) IDPAIR(NPAIR+1)=LIST(IQ1) IDPAIR(NPAIR+2)=LIST(IQ2) PPAIR(5,NPAIR+1)=AMASS(LIST(IQ1)) PPAIR(5,NPAIR+2)=AMASS(LIST(IQ2)) JPAIR(NPAIR+1)=JET JPAIR(NPAIR+2)=JET NPAIR=NPAIR+2 JQWW(JET)=JQ GO TO 200 210 CONTINUE 200 CONTINUE C C Generate decay uniformly in angle and put in PPAIR. C Will check cross section later. C NREJ=0 300 NJ0=2 DO 310 JET=1,2 IDABS=IABS(IDJETS(JET)) IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 310 C Construct W com momenta. IDABSJ=IDABS AM0=PJETS(5,JET) AM1=PPAIR(5,NJ0-1) AM2=PPAIR(5,NJ0) E1CM=(AM0**2+AM1**2-AM2**2)/(2.*AM0) E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0) P12CM=(AM0**2-AM1**2-AM2**2)**2-4.*(AM1*AM2)**2 P12CM=SQRT(P12CM)/(2.*AM0) CTHCM=2.*RANF()-1. STHCM=SQRT(1.-CTHCM**2) PHICM=2.*PI*RANF() CPHICM=COS(PHICM) SPHICM=SIN(PHICM) P1WCM(1)=P12CM*STHCM*CPHICM P2WCM(1)=-P1WCM(1) P1WCM(2)=P12CM*STHCM*SPHICM P2WCM(2)=-P1WCM(2) P1WCM(3)=P12CM*CTHCM P2WCM(3)=-P1WCM(3) P1WCM(4)=E1CM P2WCM(4)=E2CM C Boost to lab frame. DO 320 K=1,3 320 PBOOST(K)=-PJETS(K,JET) PBOOST(4)=PJETS(4,JET) CALL LBOOST(PBOOST,1,P1WCM,P1LAB) CALL LBOOST(PBOOST,1,P2WCM,P2LAB) DO 330 K=1,4 PPAIR(K,NJ0-1)=P1LAB(K) PPAIR(K,NJ0)=P2LAB(K) 330 CONTINUE NJ0=NJ0+2 310 CONTINUE C C Impose simple (1+-cos(theta))**2 decay distribution for WH C Must use P1 in WH CoM frame IF (IDABSJ.NE.80.AND.IDABSJ.NE.90) GO TO 400 BETAWH=(PJETS(3,1)+PJETS(3,2))/(PJETS(4,1)+PJETS(4,2)) GAMWH=1./SQRT(1.-BETAWH**2) PZWHCM=GAMWH*(P1LAB(3)-BETAWH*P1LAB(4)) CTHD=PZWHCM/SQRT(P1LAB(1)**2+P1LAB(2)**2+PZWHCM**2) IF (IDINIT(1).LT.0) CTHD=-CTHD IDIABS=IABS(IDINIT(1)) IDABS1=IABS(IDPAIR(1)) IF (IDABSJ.EQ.80) THEN WHSIG=(1.+CTHD)**2 IF(WHSIG.GT.4*RANF()) GO TO 400 END IF IF (IDABSJ.EQ.90) THEN IF (IDIABS.EQ.1.OR.IDIABS.EQ.4) THEN IF (IDABS1.EQ.1.OR.IDABS1.EQ.4) THEN ZHSIG=(GVQ(1)**2+GAQ(1)**2)**2*(1.+CTHD**2) $ +8*GVQ(1)*GAQ(1)*GVQ(1)*GAQ(1)*CTHD ZHMAX=2*(GVQ(1)**2+GAQ(1)**2)**2 $ +8*GVQ(1)*GAQ(1)*GVQ(1)*GAQ(1) ELSEIF (IDABS1.EQ.2.OR.IDABS1.EQ.3.OR.IDABS1.EQ.5) THEN ZHSIG=(GVQ(1)**2+GAQ(1))*(GVQ(2)**2+GAQ(2)**2)*(1.+CTHD**2) $ +8*GVQ(1)*GAQ(1)*GVQ(2)*GAQ(2)*CTHD ZHMAX=(GVQ(1)**2+GAQ(1))*(GVQ(2)**2+GAQ(2)**2)*2 $ +8*GVQ(1)*GAQ(1)*GVQ(2)*GAQ(2) ELSEIF (IDABS1.EQ.11.OR.IDABS1.EQ.13.OR.IDABS1.EQ.15) THEN ZHSIG=(GVQ(1)**2+GAQ(1))*(GVL(1)**2+GAL(1)**2)*(1.+CTHD**2) $ +8*GVQ(1)*GAQ(1)*GVL(1)*GAL(1)*CTHD ZHMAX=(GVQ(1)**2+GAQ(1))*(GVL(1)**2+GAL(1)**2)*2 $ +8*GVQ(1)*GAQ(1)*GVL(1)*GAL(1) ELSEIF (IDABS1.EQ.12.OR.IDABS1.EQ.14.OR.IDABS1.EQ.16) THEN ZHSIG=(GVQ(1)**2+GAQ(1))*(GVL(2)**2+GAL(2)**2)*(1.+CTHD**2) $ +8*GVQ(1)*GAQ(1)*GVL(2)*GAL(2)*CTHD ZHMAX=(GVQ(1)**2+GAQ(1))*(GVL(2)**2+GAL(2)**2)*2 $ +8*GVQ(1)*GAQ(1)*GVL(2)*GAL(2) END IF ELSE IF (IDIABS.EQ.2.OR.IDIABS.EQ.3.OR.IDIABS.EQ.5) THEN IF (IDABS1.EQ.1.OR.IDABS1.EQ.4) THEN ZHSIG=(GVQ(2)**2+GAQ(2)**2)**2*(1.+CTHD**2) $ +8*GVQ(2)*GAQ(2)*GVQ(1)*GAQ(1)*CTHD ZHMAX=(GVQ(2)**2+GAQ(2)**2)**2*2 $ +8*GVQ(2)*GAQ(2)*GVQ(1)*GAQ(1) ELSEIF (IDABS1.EQ.2.OR.IDABS1.EQ.3.OR.IDABS1.EQ.5) THEN ZHSIG=(GVQ(2)**2+GAQ(2))*(GVQ(2)**2+GAQ(2)**2)*(1.+CTHD**2) $ +8*GVQ(2)*GAQ(2)*GVQ(2)*GAQ(2)*CTHD ZHMAX=(GVQ(2)**2+GAQ(2))*(GVQ(2)**2+GAQ(2)**2)*2 $ +8*GVQ(2)*GAQ(2)*GVQ(2)*GAQ(2) ELSEIF (IDABS1.EQ.11.OR.IDABS1.EQ.13.OR.IDABS1.EQ.15) THEN ZHSIG=(GVQ(2)**2+GAQ(2))*(GVL(1)**2+GAL(1)**2)*(1.+CTHD**2) $ +8*GVQ(2)*GAQ(2)*GVL(1)*GAL(1)*CTHD ZHMAX=(GVQ(2)**2+GAQ(2))*(GVL(1)**2+GAL(1)**2)*2 $ +8*GVQ(2)*GAQ(2)*GVL(1)*GAL(1) ELSEIF (IDABS1.EQ.12.OR.IDABS1.EQ.14.OR.IDABS1.EQ.16) THEN ZHSIG=(GVQ(2)**2+GAQ(2))*(GVL(2)**2+GAL(2)**2)*(1.+CTHD**2) $ +8*GVQ(2)*GAQ(2)*GVL(2)*GAL(2)*CTHD ZHMAX=(GVQ(2)**2+GAQ(2))*(GVL(2)**2+GAL(2)**2)*2 $ +8*GVQ(2)*GAQ(2)*GVL(2)*GAL(2) END IF END IF IF(ZHSIG.GT.RANF()*ZHMAX) GO TO 400 END IF NREJ=NREJ+1 IF(NREJ.LT.NTRIES) GO TO 300 GO TO 999 C C Good event C 400 CONTINUE RETURN C 999 CALL PRTEVT(0) WRITE(ITLIS,9991) NREJ 9991 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE ', 1'A GOOD WHIGGS EVENT.'/' CHECK LIMITS OR INCREASE NTRIES.') STOP 99 998 CALL PRTEVT(0) WRITE(ITLIS,9981) JET 9981 FORMAT(//' ERROR IN WHIGGS ... NO DECAY POSSIBLE FOR JET',I3) STOP 99 END +EOD +DECK,WPAIR. SUBROUTINE WPAIR C C Finish generation of wpair events started bY TWOJET. C Select W decay modes as allowed by WMODE1, WMODE2. C Generate W decay angles and put vectors in PPAIR. C C Also generate massless decay vectors PZERO for matrix C element -- double precision for 32-bit machines. C C Ver 6.26: Check kinematics for W -> ff decay, since Z0 from C Higgs decay can be virtual. C Ver. 6.30: Added check in loop 201. C Ver. 7.14: Add MSSM Higgs hooks C +SELF,IF=IMPNONE IMPLICIT NONE +SELF +CDE,ITAPES +CDE,QCDPAR. +CDE,JETPAR. +CDE,PRIMAR. +CDE,Q1Q2. +CDE,JETSIG. +CDE,WWSIG. +CDE,WWPAR. +CDE,CONST. +CDE,QSAVE. +CDE,WCON. +CDE,PJETS. +CDE,PINITS +CDE,KEYS +CDE,WSIG +CDE,HCON +CDE,XMSSM C DIMENSION X(2),LIST(25),P1WCM(4),P2WCM(4),P1LAB(4),P2LAB(4) $,P1CM0(4),P2CM0(4),P1LAB0(4),P2LAB0(4) 1,PBOOST(4) EQUIVALENCE (X(1),X1) DIMENSION PWW(5,2) EQUIVALENCE (PWW(1,1),P3WW(1)) DIMENSION JWWTYP(2),THWFF(2),PHIWFF(2) +SELF,IF=SINGLE REAL P1CM0,P2CM0,DPHI,DCTH,DSTH,DAM0,PWW,BOOST +SELF,IF=DOUBLE. DOUBLE PRECISION P1CM0,P2CM0,DPHI,DCTH,DSTH,DAM0,PWW,BOOST +SELF. REAL AMWW1,AMWW2,X,STRUC,STRUCW,RND,RANF,CBRWW,AMASS,AM0,AM1,AM2, $E1CM,E2CM,P12CM,CTHCM,STHCM,PHICM,CPHICM,SPHICM,P1WCM,P2WCM, $PBOOST,P1LAB,P2LAB,AFX,SGWWMX,P1LAB0,P2LAB0,THWFF,PHIWFF INTEGER IH,IQ,JWWTYP,JET,JWT,JQ,IQ1,IQ2,LIST,NREJ,NJ0,K REAL BRANCH(12),SUMBR INTEGER IDABS,IDABS1,IDABS2 C DATA LIST/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6, $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/ C C Initialize for given W type. AMWW1=PJETS(5,1) AMWW2=PJETS(5,2) CALL WWKIN(AMWW1,AMWW2) NPAIR=0 C C Calculate and save structure functions. DO 120 IH=1,2 DO 121 IQ=1,13 121 QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH) DO 122 IQ=14,26 122 QSAVE(IQ,IH)=0. IF(KEYS(7).OR.KEYS(9)) THEN DO 123 IQ=27,29 123 QSAVE(IQ,IH)=STRUCW(X(IH),IQ-25,IDIN(IH))/X(IH) ENDIF 120 CONTINUE C JWWTYP points to W types 1,2,3,4 IF(KEYS(6)) THEN JWWTYP(1)=JETTYP(1) JWWTYP(2)=JETTYP(2) ELSEIF((KEYS(7).AND..NOT.GOMSSM).OR.KEYS(9)) THEN JWWTYP(1)=JETTYP(1)-25 JWWTYP(2)=JETTYP(2)-25 ELSEIF(KEYS(7).AND.GOMSSM) THEN JWWTYP(1)=JETTYP(1)-76 JWWTYP(2)=JETTYP(2)-76 ENDIF C C Select W decay modes and put in /JETSET/. First particle C is always the fermion. DO 200 JET=1,2 IDABS=IABS(IDJETS(JET)) IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 200 RND=RANF() JWT=JWWTYP(JET) C Must only consider allowed decays for this mass SUMBR=0. DO 201 JQ=1,12 IQ1=2*JQ IQ2=MATCH(IQ1,JWT) IF(IQ2.EQ.0) THEN BRANCH(JQ)=0. GO TO 201 ENDIF AM1=AMASS(LIST(IQ1)) AM2=AMASS(LIST(IQ2)) IF(AM1+AM2.LT.PJETS(5,JET)) THEN BRANCH(JQ)=RBRWW(JQ,JWT,JET) SUMBR=SUMBR+BRANCH(JQ) ELSE BRANCH(JQ)=0. ENDIF 201 CONTINUE IF(SUMBR.LE.0.) GO TO 998 DO 202 JQ=1,12 202 BRANCH(JQ)=BRANCH(JQ)/SUMBR C CBRWW=0. DO 210 JQ=1,12 CBRWW=CBRWW+BRANCH(JQ) IF(RND.GT.CBRWW) GO TO 210 IQ1=2*JQ IQ2=MATCH(IQ1,JWT) IDPAIR(NPAIR+1)=LIST(IQ1) IDPAIR(NPAIR+2)=LIST(IQ2) PPAIR(5,NPAIR+1)=AMASS(LIST(IQ1)) PPAIR(5,NPAIR+2)=AMASS(LIST(IQ2)) JPAIR(NPAIR+1)=JET JPAIR(NPAIR+2)=JET NPAIR=NPAIR+2 JQWW(JET)=JQ GO TO 200 210 CONTINUE 200 CONTINUE C C Generate decay uniformly in angle and put in PPAIR. C Will check cross section later. C NREJ=0 300 NJ0=2 DO 310 JET=1,2 IDABS=IABS(IDJETS(JET)) IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 310 C Construct W com momenta. AM0=PJETS(5,JET) AM1=PPAIR(5,NJ0-1) AM2=PPAIR(5,NJ0) E1CM=(AM0**2+AM1**2-AM2**2)/(2.*AM0) E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0) P12CM=(AM0**2-AM1**2-AM2**2)**2-4.*(AM1*AM2)**2 P12CM=SQRT(P12CM)/(2.*AM0) CTHCM=2.*RANF()-1. STHCM=SQRT(1.-CTHCM**2) PHICM=2.*PI*RANF() CPHICM=COS(PHICM) SPHICM=SIN(PHICM) P1WCM(1)=P12CM*STHCM*CPHICM P2WCM(1)=-P1WCM(1) P1WCM(2)=P12CM*STHCM*SPHICM P2WCM(2)=-P1WCM(2) P1WCM(3)=P12CM*CTHCM P2WCM(3)=-P1WCM(3) P1WCM(4)=E1CM P2WCM(4)=E2CM C Also construct zero mass vectors at same angle +SELF,IF=SINGLE. C Single precision. P1CM0(1)=.5*AM0*STHCM*CPHICM P2CM0(1)=-P1CM0(1) P1CM0(2)=.5*AM0*STHCM*SPHICM P2CM0(2)=-P1CM0(2) P1CM0(3)=.5*AM0*CTHCM P2CM0(3)=-P1CM0(3) P1CM0(4)=.5*AM0 P2CM0(4)=P1CM0(4) +SELF,IF=DOUBLE. C Double precision. DAM0=AM0 DCTH=CTHCM DSTH=DSQRT(1.D0-DCTH**2) DPHI=PHICM P1CM0(1)=.5*AM0*DSTH*DCOS(DPHI) P2CM0(1)=-P1CM0(1) P1CM0(2)=.5*AM0*DSTH*DSIN(DPHI) P2CM0(2)=-P1CM0(2) P1CM0(3)=.5*AM0*DCTH P2CM0(3)=-P1CM0(3) P1CM0(4)=.5*AM0 P2CM0(4)=P1CM0(4) +SELF. C Boost to lab frame. DO 320 K=1,3 320 PBOOST(K)=-PJETS(K,JET) PBOOST(4)=PJETS(4,JET) CALL LBOOST(PBOOST,1,P1WCM,P1LAB) CALL LBOOST(PBOOST,1,P2WCM,P2LAB) DO 330 K=1,4 PPAIR(K,NJ0-1)=P1LAB(K) PPAIR(K,NJ0)=P2LAB(K) 330 CONTINUE C Boost zero mass vectors -- double precision for 32 bits. PZERO(4,NJ0-1)=(P1CM0(4)*PWW(4,JET)+P1CM0(1)*PWW(1,JET) $ +P1CM0(2)*PWW(2,JET)+P1CM0(3)*PWW(3,JET))/PWW(5,JET) BOOST=(P1CM0(4)+PZERO(4,NJ0-1))/(PWW(4,JET)+PWW(5,JET)) DO 340 K=1,3 340 PZERO(K,NJ0-1)=P1CM0(K)+BOOST*PWW(K,JET) PZERO(4,NJ0)=(P2CM0(4)*PWW(4,JET)+P2CM0(1)*PWW(1,JET) $ +P2CM0(2)*PWW(2,JET)+P2CM0(3)*PWW(3,JET))/PWW(5,JET) BOOST=(P2CM0(4)+PZERO(4,NJ0))/(PWW(4,JET)+PWW(5,JET)) DO 350 K=1,3 350 PZERO(K,NJ0)=P2CM0(K)+BOOST*PWW(K,JET) NJ0=NJ0+2 310 CONTINUE C C Calculate cross section SIGWW2 containing TBRWW*RBRWW. C Compare with WW cross section containing TBRWW. Ratio C must be bounded by 3/(4*PI) for each W. C AFX=3./(2.*PI) IF(KEYS(6)) THEN CALL SIGWW2 SGWWMX=SIGEVT IF(IDJETS(1).NE.10) SGWWMX=SGWWMX*RBRWW(JQWW(1),JWWTYP(1),1)*AFX IF(IDJETS(2).NE.10) SGWWMX=SGWWMX*RBRWW(JQWW(2),JWWTYP(2),2)*AFX ELSEIF(KEYS(7)) THEN C Note that except for WW -> WW processes, SIGH3 just computes C the decay angular distribution, so it can be used for both C for SM and SUSY HL0/HH0 decays; HA0 -> WW is forbidden. C For Z + HL0 decays, we just return, ie use phase space. IDABS1=IABS(IDJETS(1)) IDABS2=IABS(IDJETS(2)) IF(.NOT.(IDABS1.EQ.10.OR.IDABS1.EQ.80.OR.IDABS1.EQ.90)) RETURN IF(.NOT.(IDABS2.EQ.10.OR.IDABS2.EQ.80.OR.IDABS2.EQ.90)) RETURN CALL SIGH3 SGWWMX=SIGLLQ*AFX**2 ELSEIF(KEYS(9)) THEN CALL SIGTC3 SGWWMX=SIGLLQ*AFX**2 ENDIF IF(WWSIG.GT.SGWWMX*RANF()) GO TO 400 NREJ=NREJ+1 IF(NREJ.LT.NTRIES) GO TO 300 GO TO 999 C C Good event C 400 CONTINUE RETURN C 999 CALL PRTEVT(0) WRITE(ITLIS,9991) NREJ 9991 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE ', 1'A GOOD WPAIR EVENT.'/' CHECK LIMITS OR INCREASE NTRIES.') STOP 99 998 CALL PRTEVT(0) WRITE(ITLIS,9981) JET 9981 FORMAT(//' ERROR IN WPAIR ... NO DECAY POSSIBLE FOR JET',I3) STOP 99 END +EOD +DECK,WWKIN. SUBROUTINE WWKIN(AM1,AM2) C WPAIR KINEMATICS, INCLUDING DOUBLE PRECISION CONVERSION FOR C 32-BIT MACHINES. CONVENTION IS THAT SINGLE PRECISION MASSES C AM1,AM2 ARE EXACT. +CDE,ITAPES +CDE,WWPAR. +CDE,JETPAR. C BASIC KINEMATICS FROM TWOKIN CALL TWOKIN(0.,0.,AM1,AM2) C WPAIR KINEMATICS -- JUST A COPY FOR CDC BUT CONSTRUCTS A C CONSISTENT SET OF DOUBLE PRECISION VARIABLES FOR 32-BIT C MACHINES. P3WW(1)=PT(1)*COS(PHI(1)) P3WW(2)=PT(1)*SIN(PHI(1)) P3WW(3)=P(1)*CTH(1) P3WW(5)=AM1 P4WW(1)=-P3WW(1) P4WW(2)=-P3WW(2) P4WW(3)=P(2)*CTH(2) P4WW(5)=AM2 +SELF,IF=SINGLE. P3WW(4)=SQRT(P3WW(1)**2+P3WW(2)**2+P3WW(3)**2+P3WW(5)**2) P4WW(4)=SQRT(P4WW(1)**2+P4WW(2)**2+P4WW(3)**2+P4WW(5)**2) +SELF,IF=DOUBLE. P3WW(4)=DSQRT(P3WW(1)**2+P3WW(2)**2+P3WW(3)**2+P3WW(5)**2) P4WW(4)=DSQRT(P4WW(1)**2+P4WW(2)**2+P4WW(3)**2+P4WW(5)**2) +SELF. P1WW(1)=0. P1WW(2)=0. P1WW(4)=.5*(P3WW(4)+P3WW(3)+P4WW(4)+P4WW(3)) P1WW(3)=P1WW(4) P2WW(1)=0. P2WW(2)=0. P2WW(4)=.5*(P3WW(4)-P3WW(3)+P4WW(4)-P4WW(3)) P2WW(3)=-P2WW(4) C INVARIANTS SWW=+2.*(P1WW(4)*P2WW(4)-P1WW(3)*P2WW(3)) TWW=-2.*(P1WW(4)*P3WW(4)-P1WW(3)*P3WW(3))+P3WW(5)**2 UWW=-2.*(P2WW(4)*P3WW(4)-P2WW(3)*P3WW(3))+P3WW(5)**2 RETURN END +EOD +DECK,WWSS. FUNCTION WWSS(T,U,T1,U1,T3,U3) C DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980). C SQUARE OF S GRAPH. +CDE,ITAPES +CDE,WWPAR. +SELF,IF=DOUBLE. DOUBLE PRECISION WWSS DOUBLE PRECISION T,U,T1,U1,T3,U3 DOUBLE PRECISION CV2A2 +SELF. CV2A2=CV**2+CA**2 WWSS= 1 +CV*CA*T*(-64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3+64.*T1*T3**2-6 1 4.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3**2+64.*U1**2*U3) 1 +CV*CA*T*U*(-128.*T1*U3-64.*T1*S13+128.*U1*T3+64.*U1*S13+64.*T3* 1 S13-64.*U3*S13) 1 +CV*CA*T*WM2*(128.*T1*U3+64.*T1*S13-64.*T1**2-128.*U1*T3+64.*U1* 1 S13+64.*U1**2-64.*T3*S13+64.*T3**2-64.*U3*S13-64.*U3**2) 1 +CV*CA*T**2*(-64.*T1*U3-64.*T1*S13+64.*U1*T3+64.*T3*S13) 1 +CV*CA*U*(-64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3+64.*T1*T3**2-6 1 4.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3**2+64.*U1**2*U3) WWSS=WWSS 1 +CV*CA*U*WM2*(128.*T1*U3-64.*T1*S13-64.*T1**2-128.*U1*T3-64.*U1* 1 S13+64.*U1**2+64.*T3*S13+64.*T3**2+64.*U3*S13-64.*U3**2) 1 +CV*CA*U**2*(-64.*T1*U3+64.*U1*T3+64.*U1*S13-64.*U3*S13) 1 +CV*CA*WM2*(128.*T1*U1*T3-128.*T1*U1*U3-128.*T1*T3*U3-128.*T1*T3 1 **2+128.*T1**2*T3+128.*U1*T3*U3+128.*U1*U3**2-128.*U1**2*U3) 1 +CV*CA*WM2**2*(128.*T1*S13+128.*T1**2-128.*U1*S13-128.*U1**2-128 1 .*T3*S13-128.*T3**2+128.*U3*S13+128.*U3**2) 1 +CV2A2*(128.*T1*U1*T3*U3-64.*T1**2*T3**2-64.*U1**2*U3**2) WWSS=WWSS 1 +CV2A2*T*(-32.*T1*U1*T3-32.*T1*U1*U3-32.*T1*T3*U3-64.*T1*T3*S13+ 1 32.*T1*T3**2+32.*T1**2*T3-32.*U1*T3*U3+64.*U1*U3*S13+32.*U1*U3** 1 2+32.*U1**2*U3) 1 +CV2A2*T*U*(64.*T1*U3+32.*T1*S13+64.*U1*T3+32.*U1*S13+32.*T3*S13 1 +32.*U3*S13+64.*S13**2) 1 +CV2A2*T*WM2*(-64.*T1*U3-32.*T1*S13+32.*T1**2-64.*U1*T3+32.*U1*S 1 13+32.*U1**2-32.*T3*S13+32.*T3**2+32.*U3*S13+32.*U3**2) 1 +CV2A2*T**2*(32.*T1*U3+32.*T1*S13+32.*U1*T3+32.*T3*S13) WWSS=WWSS 1 +CV2A2*U*(-32.*T1*U1*T3-32.*T1*U1*U3-32.*T1*T3*U3+64.*T1*T3*S13+ 1 32.*T1*T3**2+32.*T1**2*T3-32.*U1*T3*U3-64.*U1*U3*S13+32.*U1*U3** 1 2+32.*U1**2*U3) 1 +CV2A2*U*WM2*(-64.*T1*U3+32.*T1*S13+32.*T1**2-64.*U1*T3-32.*U1*S 1 13+32.*U1**2+32.*T3*S13+32.*T3**2-32.*U3*S13+32.*U3**2) 1 +CV2A2*U**2*(32.*T1*U3+32.*U1*T3+32.*U1*S13+32.*U3*S13) 1 +CV2A2*WM2*(64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3-64.*T1*T3**2- 1 64.*T1**2*T3+64.*U1*T3*U3-64.*U1*U3**2-64.*U1**2*U3) WWSS=WWSS 1 +CV2A2*WM2**2*(-64.*T1*S13-64.*T1**2-64.*U1*S13-64.*U1**2-64.*T3 1 *S13-64.*T3**2-64.*U3*S13-64.*U3**2-64.*S13**2) WWSS=2.*WWSS RETURN END +EOD +DECK,WWST. FUNCTION WWST(T,U,T1,U1,T3,U3,P1,P2) C DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980). C INTERFERENCE OF T AND S GRAPHS. +CDE,ITAPES +CDE,WWPAR. DIMENSION P1(4),P2(4) +SELF,IF=DOUBLE. DOUBLE PRECISION WWST DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2 DOUBLE PRECISION CVACQ,EPF +SELF. CVACQ=(CV+CA)*CQ WWST= 1 +CVACQ*(-256.*T1*U1*T3*U3+256.*T1**2*T3**2) 1 +CVACQ*T*(256.*T1*U1*T3+256.*T1*T3*S13-256.*T1*T3**2+128.*U1*T3* 1 U3-128.*U1*U3*S13-128.*U1**2*U3) 1 +CVACQ*T*U*(-256.*U1*T3-128.*U1*S13-128.*T3*S13-128.*S13**2) 1 +CVACQ*T*WM2*(384.*U1*T3-128.*U1*S13-128.*U1**2+256.*T3*S13-256. 1 *T3**2) 1 +CVACQ*T**2*(-256.*U1*T3-256.*T3*S13) 1 +CVACQ*U*(128.*T1*U1*T3-128.*T1*T3*S13-128.*T1*T3**2) WWST=WWST 1 +CVACQ*U*WM2*(128.*U1*T3-128.*T3*S13-128.*T3**2) 1 +CVACQ*WM2*(-256.*T1*U1*T3+512.*T1*T3**2-256.*U1*T3*U3) 1 +CVACQ*WM2**2*(256.*U1*S13+128.*U1**2+256.*T3*S13+384.*T3**2+128 1 .*S13**2) 1 +EPF(P1,P2,P3,Q1)*CVACQ*(128.*T3*U3+128.*T3*S13+64.*T3**2+128.*U 1 3*S13+64.*U3**2) 1 +EPF(P1,P2,P3,Q1)*CVACQ*T*(-32.*T3-32.*U3-64.*S13) 1 -32.*EPF(P1,P2,P3,Q1)*CVACQ*T*WM2 WWST=WWST 1 +EPF(P1,P2,P3,Q1)*CVACQ*U*(-32.*T3-32.*U3-64.*S13) 1 -32.*EPF(P1,P2,P3,Q1)*CVACQ*U*WM2 1 +EPF(P1,P2,P3,Q1)*CVACQ*WM2*(128.*T3+128.*U3+128.*S13) 1 +64.*EPF(P1,P2,P3,Q1)*CVACQ*WM2**2 1 -32.*EPF(P1,P2,P3,Q3)*CVACQ*T*WM2 1 -32.*EPF(P1,P2,P3,Q3)*CVACQ*U*WM2 1 +EPF(P1,P2,P3,Q3)*CVACQ*WM2*(64.*T3+64.*U3) 1 +64.*EPF(P1,P2,P3,Q3)*CVACQ*WM2**2 WWST=WWST 1 +EPF(P1,P3,Q1,Q3)*CVACQ*(128.*U1*T3+128.*U1*U3) 1 +EPF(P1,P3,Q1,Q3)*CVACQ*T*(-64.*U1) 1 +32.*EPF(P1,P3,Q1,Q3)*CVACQ*T*U 1 -32.*EPF(P1,P3,Q1,Q3)*CVACQ*T*WM2 1 +EPF(P1,P3,Q1,Q3)*CVACQ*U*(-64.*U1-64.*T3-64.*U3) 1 -96.*EPF(P1,P3,Q1,Q3)*CVACQ*U*WM2 1 +32.*EPF(P1,P3,Q1,Q3)*CVACQ*U**2 1 +EPF(P1,P3,Q1,Q3)*CVACQ*WM2*(128.*U1+64.*T3+64.*U3) WWST=WWST 1 +64.*EPF(P1,P3,Q1,Q3)*CVACQ*WM2**2 1 +EPF(P2,P3,Q1,Q3)*CVACQ*(-128.*T1*T3-128.*T1*U3) 1 +EPF(P2,P3,Q1,Q3)*CVACQ*T*(64.*T1+64.*T3+64.*U3) 1 -32.*EPF(P2,P3,Q1,Q3)*CVACQ*T*U 1 +96.*EPF(P2,P3,Q1,Q3)*CVACQ*T*WM2 1 -32.*EPF(P2,P3,Q1,Q3)*CVACQ*T**2 1 +EPF(P2,P3,Q1,Q3)*CVACQ*U*(64.*T1) 1 +32.*EPF(P2,P3,Q1,Q3)*CVACQ*U*WM2 1 +EPF(P2,P3,Q1,Q3)*CVACQ*WM2*(-128.*T1-64.*T3-64.*U3) 1 -64.*EPF(P2,P3,Q1,Q3)*CVACQ*WM2**2 WWST=WWST/T WWST=2.*WWST RETURN END +EOD +DECK,WWTT. FUNCTION WWTT(T,U,T1,U1,T3,U3) C DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980). C SQUARE OF T GRAPH. +CDE,ITAPES +CDE,WWPAR. +SELF,IF=DOUBLE. DOUBLE PRECISION WWTT DOUBLE PRECISION T,U,T1,U1,T3,U3 +SELF. WWTT= 1(+CQ**2*(-512.*T1**2*T3**2) 1 +CQ**2*T*(-512.*T1*U1*T3-512.*T1*T3*S13+512.*T1*T3**2) 1 +CQ**2*T*WM2*(-512.*U1*T3-512.*T3*S13+512.*T3**2) 1 +CQ**2*T**2*(512.*U1*T3+512.*T3*S13) 1 +CQ**2*WM2*(-1024.*T1*T3**2) 1 +CQ**2*WM2**2*(-512.*T3**2))/T**2 WWTT=2.*WWTT RETURN END +EOD +DECK,WZSS. FUNCTION WZSS(T,U,T1,U1,T3,U3,P1,P2) C DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980). C SQUARE OF S GRAPH. +CDE,ITAPES +CDE,WWPAR. DIMENSION P1(4),P2(4) +SELF,IF=DOUBLE. DOUBLE PRECISION WZSS DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2 DOUBLE PRECISION WM4,ZM4,WZM2,CSXCS +SELF. WM4=WM2**2 ZM4=ZM2**2 WZM2=WM2*ZM2 CSXCS=CS**2 WZSS= 1 +CSXCS*CV3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-128.*WM2*T1*T3**2-1 1 28.*WM2*T1*ZM4+128.*WM2*U1*T3*U3-64.*WM2*T3*ZM4-64.*WM2*S13*ZM4+ 1 64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64.*ZM2*T1*WM4-64.*ZM2*T1**2*T 1 3-64.*ZM2*U1**2*U3-128.*ZM2*T3*WM4-64.*ZM2*S13*WM4+128.*T1*U1*T3 1 *U3-192.*T1*T3*WZM2-64.*T1*S13*WZM2-64.*T1**2*T3**2-32.*T1**2*WZ 1 M2-32.*T1**2*ZM4+64.*U1*U3*WZM2-64.*U1*S13*WZM2-64.*U1**2*U3**2- 1 32.*U1**2*WZM2-32.*U1**2*ZM4-128.*T3*S13*WZM2-64.*T3**2*WZM2-64. 1 *T3**2*WM4-64.*S13**2*WZM2-96.*WM4*ZM4) WZSS=WZSS 1 +CSXCS*CV3*T*(64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*U1*U3-64.*WM2* 1 T3*S13+64.*WM2*T3**2+96.*WM2*ZM4+64.*ZM2*T1*T3-32.*ZM2*T1*S13+32 1 .*ZM2*T1**2-32.*ZM2*U1*T3-32.*ZM2*U1*U3+32.*ZM2*U1*S13+32.*ZM2*U 1 1**2+96.*ZM2*WM4-32.*T1*U1*T3-32.*T1*U1*U3-64.*T1*T3*S13+64.*T1* 1 T3**2+128.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-64.*U1*T3*U3+64.*U1*U 1 3*S13+32.*U1**2*U3+128.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2) WZSS=WZSS 1 +CSXCS*CV3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3 1 2.*T1*T3+32.*T1*S13+64.*U1*T3+32.*U1*U3+32.*U1*S13+64.*T3*S13+64 1 .*S13**2-32.*WZM2) 1 +CSXCS*CV3*T**2*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13- 1 32.*T1*T3+32.*T1*S13+32.*U1*T3+32.*U1*U3+64.*T3*S13-64.*WZM2) 1 +CSXCS*CV3*T**2*U*(-32.*S13) 1 +CSXCS*CV3*T**3*(-32.*S13) WZSS=WZSS 1 +CSXCS*CV3*U*(64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*U1*U3+64.*WM2* 1 T3*S13+64.*WM2*T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3+32.*ZM2*T1*S13+32 1 .*ZM2*T1**2-32.*ZM2*U1*T3-32.*ZM2*U1*U3-32.*ZM2*U1*S13+32.*ZM2*U 1 1**2+32.*ZM2*WM4-32.*T1*U1*T3-32.*T1*U1*U3+64.*T1*T3*S13+64.*T1* 1 T3**2+64.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3 1 *S13+32.*U1**2*U3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2) 1 +CSXCS*CV3*U**2*(32.*U1*T3+32.*U1*S13) WZSS=WZSS 1 +CSXCS*CA3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+128.*WM2*T1*ZM4+64.* 1 WM2*T3*ZM4+64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64. 1 *ZM2*T1*WM4+64.*ZM2*T1**2*T3-64.*ZM2*U1**2*U3+128.*ZM2*T3*WM4+64 1 .*ZM2*S13*WM4+192.*T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2+32. 1 *T1**2*ZM4-64.*U1*U3*WZM2-64.*U1*S13*WZM2-32.*U1**2*WZM2-32.*U1* 1 *2*ZM4+96.*WM4*ZM4) WZSS=WZSS 1 +CSXCS*CA3*T*(-64.*WM2*T1*T3-32.*WM2*U1*T3+32.*WM2*U1*U3-96.*WM2 1 *ZM4-64.*ZM2*T1*T3+32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*U1*T3+32 1 .*ZM2*U1*U3+32.*ZM2*U1*S13+32.*ZM2*U1**2-96.*ZM2*WM4-32.*T1*U1*T 1 3+32.*T1*U1*U3-128.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+32.*U1**2*U3 1 -128.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2) 1 +CSXCS*CA3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32 1 .*T1*T3-32.*T1*S13+64.*U1*T3-32.*U1*U3+32.*U1*S13+32.*WZM2) WZSS=WZSS 1 +CSXCS*CA3*T**2*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+3 1 2.*T1*T3-32.*T1*S13+32.*U1*T3-32.*U1*U3+64.*WZM2) 1 +CSXCS*CA3*T**2*U*(32.*S13) 1 +CSXCS*CA3*T**3*(32.*S13) WZSS=WZSS 1 +CSXCS*CA3*U*(-64.*WM2*T1*T3-32.*WM2*U1*T3+32.*WM2*U1*U3-32.*WM2 1 *ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*U1*T3+32 1 .*ZM2*U1*U3-32.*ZM2*U1*S13+32.*ZM2*U1**2-32.*ZM2*WM4-32.*T1*U1*T 1 3+32.*T1*U1*U3-64.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+32.*U1**2*U3- 1 64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2) 1 +CSXCS*CA3*U**2*(32.*U1*T3+32.*U1*S13) RETURN END +EOD +DECK,WZST. FUNCTION WZST(T,U,T1,U1,T3,U3,P1,P2) C DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980). C INTERFERENCE OF S AND T GRAPHS. +CDE,ITAPES +CDE,WWPAR. DIMENSION P1(4),P2(4) +SELF,IF=DOUBLE. DOUBLE PRECISION WZST DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2 DOUBLE PRECISION WM4,ZM4,WZM2,CSXCT,EPF +SELF. WM4=WM2**2 ZM4=ZM2**2 WZM2=WM2*ZM2 CSXCT=CS*CT/T WZST= 1 +CSXCT*CV3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+256.*WM2*T1*T3**2+19 1 2.*WM2*T1*ZM4-128.*WM2*U1*T3*U3+64.*WM2*T3*ZM4+64.*WM2*S13*ZM4-6 1 4.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64.*ZM2*T1*WM4+128.*ZM2*T1**2*T 1 3+192.*ZM2*T3*WM4+64.*ZM2*S13*WM4-128.*T1*U1*T3*U3+320.*T1*T3*WZ 1 M2+64.*T1*S13*WZM2+128.*T1**2*T3**2+32.*T1**2*WZM2+64.*T1**2*ZM4 1 -64.*U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2+128.*T3*S13*WZM2+ 1 64.*T3**2*WZM2+128.*T3**2*WM4+64.*S13**2*WZM2+128.*WM4*ZM4) WZST=WZST 1 +CSXCT*CV3*T*(-128.*WM2*T1*T3+64.*WM2*U1*T3+32.*WM2*U1*U3+128.*W 1 M2*T3*S13-128.*WM2*T3**2-128.*WM2*ZM4-128.*ZM2*T1*T3+64.*ZM2*T1* 1 S13-64.*ZM2*T1**2+32.*ZM2*U1*T3+32.*ZM2*U1*U3-32.*ZM2*U1*S13-32. 1 *ZM2*U1**2-128.*ZM2*WM4+64.*T1*U1*T3+32.*T1*U1*U3+128.*T1*T3*S13 1 -128.*T1*T3**2-192.*T1*WZM2-64.*T1*ZM4-64.*T1**2*T3+64.*U1*T3*U3 1 -64.*U1*U3*S13-32.*U1**2*U3-192.*T3*WZM2-64.*T3*WM4) WZST=WZST 1 +CSXCT*CV3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32 1 .*T1*T3-32.*T1*S13-64.*U1*T3-32.*U1*S13-64.*T3*S13-64.*S13**2+32 1 .*WZM2) 1 +CSXCT*CV3*T**2*(64.*WM2*T3-64.*WM2*S13+64.*ZM2*T1-64.*ZM2*S13+6 1 4.*T1*T3-64.*T1*S13-64.*U1*T3-32.*U1*U3-128.*T3*S13+96.*WZM2) 1 +CSXCT*CV3*T**2*U*(32.*S13) WZST=WZST 1 +CSXCT*CV3*T**3*(64.*S13) 1 +CSXCT*CV3*U*(-64.*WM2*T1*T3+32.*WM2*U1*T3-64.*WM2*T3*S13-64.*WM 1 2*T3**2-32.*WM2*ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-3 1 2.*ZM2*WM4+32.*T1*U1*T3-64.*T1*T3*S13-64.*T1*T3**2-64.*T1*WZM2-3 1 2.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2) WZST=WZST 1 +CSXCT*CA3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-192.*WM2*T1*ZM4-64. 1 *WM2*T3*ZM4-64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64 1 .*ZM2*T1*WM4-128.*ZM2*T1**2*T3-192.*ZM2*T3*WM4-64.*ZM2*S13*WM4-3 1 20.*T1*T3*WZM2-64.*T1*S13*WZM2-32.*T1**2*WZM2-64.*T1**2*ZM4+64.* 1 U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2-128.*WM4*ZM4) WZST=WZST 1 +CSXCT*CA3*T*(128.*WM2*T1*T3+64.*WM2*U1*T3-32.*WM2*U1*U3+128.*WM 1 2*ZM4+128.*ZM2*T1*T3-64.*ZM2*T1*S13+64.*ZM2*T1**2+32.*ZM2*U1*T3- 1 32.*ZM2*U1*U3-32.*ZM2*U1*S13-32.*ZM2*U1**2+128.*ZM2*WM4+64.*T1*U 1 1*T3-32.*T1*U1*U3+192.*T1*WZM2+64.*T1*ZM4+64.*T1**2*T3-32.*U1**2 1 *U3+192.*T3*WZM2+64.*T3*WM4) WZST=WZST 1 +CSXCT*CA3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3 1 2.*T1*T3+32.*T1*S13-64.*U1*T3-32.*U1*S13-32.*WZM2) 1 +CSXCT*CA3*T**2*(-64.*WM2*T3+64.*WM2*S13-64.*ZM2*T1+64.*ZM2*S13- 1 64.*T1*T3+64.*T1*S13-64.*U1*T3+32.*U1*U3-96.*WZM2) 1 +CSXCT*CA3*T**2*U*(-32.*S13) 1 +CSXCT*CA3*T**3*(-64.*S13) WZST=WZST 1 +CSXCT*CA3*U*(64.*WM2*T1*T3+32.*WM2*U1*T3+32.*WM2*ZM4+64.*ZM2*T1 1 *T3+32.*ZM2*T1*S13+32.*ZM2*T1**2+32.*ZM2*WM4+32.*T1*U1*T3+64.*T1 1 *WZM2+32.*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM 1 2) 1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*(64.*ZM2*T3+64.*ZM2*U3+64.*ZM2*S13+6 1 4.*T3*U3+64.*T3*S13+32.*T3**2+64.*U3*S13+32.*U3**2+32.*ZM4) WZST=WZST 1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*T*(-16.*ZM2-16.*T3-16.*U3-32.*S13) 1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*U*(-16.*ZM2-16.*T3-16.*U3-32.*S13) 1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*(32.*WM2*T3+32.*WM2*U3+32.*WZM2) 1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*T*(-16.*WM2) 1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*U*(-16.*WM2) 1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*(32.*WM2*T3+32.*WM2*U3+64.*ZM2*U1+64 1 .*U1*T3+64.*U1*U3+32.*WZM2) WZST=WZST 1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*T*(-16.*WM2-32.*U1) 1 +16.*EPF(P1,P3,Q1,Q3)*CSXCT*CV3*T*U 1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*U*(-16.*WM2-32.*ZM2-32.*U1-32.*T3-32 1 .*U3) 1 +16.*EPF(P1,P3,Q1,Q3)*CSXCT*CV3*U**2 1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*(-32.*WM2*T3-32.*WM2*U3-64.*ZM2*T1-6 1 4.*T1*T3-64.*T1*U3-32.*WZM2) WZST=WZST 1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T*(16.*WM2+32.*ZM2+32.*T1+32.*T3+32. 1 *U3) 1 -16.*EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T*U 1 -16.*EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T**2 1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*U*(16.*WM2+32.*T1) RETURN END +EOD +DECK,WZSU. FUNCTION WZSU(T,U,T1,U1,T3,U3,P1,P2) C DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980). C INTERFERENCE OF S AND U GRAPHS. +CDE,ITAPES +CDE,WWPAR. DIMENSION P1(4),P2(4) +SELF,IF=DOUBLE. DOUBLE PRECISION WZSU DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2 DOUBLE PRECISION WM4,ZM4,WZM2,CSXCU,EPF +SELF. WM4=WM2**2 ZM4=ZM2**2 WZM2=WM2*ZM2 CSXCU=CS*CU/U WZSU= 1 +CSXCU*CV3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-64.*WM2*T1*ZM4+128. 1 *WM2*U1*T3*U3-64.*WM2*T3*ZM4-64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3+64 1 .*ZM2*T1*U1*U3-64.*ZM2*T1*WM4-128.*ZM2*U1**2*U3-64.*ZM2*T3*WM4-6 1 4.*ZM2*S13*WM4+128.*T1*U1*T3*U3-64.*T1*T3*WZM2-64.*T1*S13*WZM2-3 1 2.*T1**2*WZM2+64.*U1*U3*WZM2-64.*U1*S13*WZM2-128.*U1**2*U3**2-32 1 .*U1**2*WZM2-64.*U1**2*ZM4-128.*T3*S13*WZM2-64.*T3**2*WZM2-64.*S 1 13**2*WZM2-64.*WM4*ZM4) WZSU=WZSU 1 +CSXCU*CV3*T*(-32.*WM2*U1*U3+64.*WM2*ZM4-32.*ZM2*U1*T3-32.*ZM2*U 1 1*U3+32.*ZM2*U1*S13+32.*ZM2*U1**2+64.*ZM2*WM4-32.*T1*U1*U3+64.*T 1 1*WZM2-64.*U1*T3*U3+64.*U1*U3*S13+32.*U1**2*U3+64.*T3*WZM2+64.*S 1 13*WZM2) 1 +CSXCU*CV3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3 1 2.*T1*T3+32.*T1*S13+64.*U1*T3+64.*U1*U3+32.*U1*S13+64.*T3*S13+64 1 .*S13**2-32.*WZM2) WZSU=WZSU 1 +CSXCU*CV3*T**2*(32.*U1*U3-32.*WZM2) 1 +CSXCU*CV3*T**2*U*(-32.*S13) WZSU=WZSU 1 +CSXCU*CV3*U*(64.*WM2*T1*T3-32.*WM2*U1*T3-64.*WM2*U1*U3+64.*WM2* 1 T3*S13+64.*WM2*T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3+32.*ZM2*T1*S13+32 1 .*ZM2*T1**2-64.*ZM2*U1*T3-64.*ZM2*U1*U3-64.*ZM2*U1*S13+64.*ZM2*U 1 1**2+32.*ZM2*WM4-32.*T1*U1*T3-64.*T1*U1*U3+64.*T1*T3*S13+64.*T1* 1 T3**2+64.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-128.*U1*T3*U3-128.*U1* 1 U3*S13+64.*U1**2*U3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2) WZSU=WZSU 1 +CSXCU*CV3*U**2*(64.*U1*T3+64.*U1*S13) 1 +CSXCU*CA3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+64.*WM2*T1*ZM4+64.*W 1 M2*T3*ZM4+64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64.* 1 ZM2*T1*WM4-128.*ZM2*U1**2*U3+64.*ZM2*T3*WM4+64.*ZM2*S13*WM4+64.* 1 T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2-64.*U1*U3*WZM2-64.*U1* 1 S13*WZM2-32.*U1**2*WZM2-64.*U1**2*ZM4+64.*WM4*ZM4) WZSU=WZSU 1 +CSXCU*CA3*T*(32.*WM2*U1*U3-64.*WM2*ZM4-32.*ZM2*U1*T3+32.*ZM2*U1 1 *U3+32.*ZM2*U1*S13+32.*ZM2*U1**2-64.*ZM2*WM4+32.*T1*U1*U3-64.*T1 1 *WZM2+32.*U1**2*U3-64.*T3*WZM2-64.*S13*WZM2) 1 +CSXCU*CA3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32 1 .*T1*T3-32.*T1*S13+64.*U1*T3-64.*U1*U3+32.*U1*S13+32.*WZM2) 1 +CSXCU*CA3*T**2*(-32.*U1*U3+32.*WZM2) WZSU=WZSU 1 +CSXCU*CA3*T**2*U*(32.*S13) 1 +CSXCU*CA3*U*(-64.*WM2*T1*T3-32.*WM2*U1*T3+64.*WM2*U1*U3-32.*WM2 1 *ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-64.*ZM2*U1*T3+64 1 .*ZM2*U1*U3-64.*ZM2*U1*S13+64.*ZM2*U1**2-32.*ZM2*WM4-32.*T1*U1*T 1 3+64.*T1*U1*U3-64.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+64.*U1**2*U3- 1 64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2) WZSU=WZSU 1 +CSXCU*CA3*U**2*(64.*U1*T3+64.*U1*S13) 1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*(32.*ZM2*T1+32.*ZM2*U1+32.*WZM2) 1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*T*(-16.*ZM2) 1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*U*(-16.*ZM2) 1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*(64.*WM2*T1+64.*WM2*U1+64.*WM2*S13+6 1 4.*T1*U1+64.*T1*S13+32.*T1**2+64.*U1*S13+32.*U1**2+32.*WM4) WZSU=WZSU 1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*T*(-16.*WM2-16.*T1-16.*U1-32.*S13) 1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*U*(-16.*WM2-16.*T1-16.*U1-32.*S13) 1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*(64.*WM2*T3+64.*WM2*U3+64.*ZM2*T1+64 1 .*ZM2*U1+64.*T1*T3+64.*T1*U3+64.*U1*T3+64.*U1*U3+64.*WZM2) 1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T*(-32.*WM2-32.*ZM2-32.*T1-32.*U1-32 1 .*T3-32.*U3) WZSU=WZSU 1 +32.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T*U 1 +16.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T**2 1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*U*(-32.*WM2-32.*ZM2-32.*T1-32.*U1-32 1 .*T3-32.*U3) 1 +16.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*U**2 1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*(-64.*WM2*T3-32.*ZM2*T1-32.*ZM2*U1-6 1 4.*T1*T3-64.*U1*T3-32.*WZM2) WZSU=WZSU 1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T*(32.*WM2+16.*ZM2+32.*T1+32.*U1+32. 1 *T3) 1 -16.*EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T*U 1 -16.*EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T**2 1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*U*(16.*ZM2+32.*T3) 1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*(64.*WM2*U3+32.*ZM2*T1+32.*ZM2*U1+64 1 .*T1*U3+64.*U1*U3+32.*WZM2) WZSU=WZSU 1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*T*(-16.*ZM2-32.*U3) 1 +16.*EPF(P2,P3,Q1,Q3)*CSXCU*CV3*T*U 1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*U*(-32.*WM2-16.*ZM2-32.*T1-32.*U1-32 1 .*U3) 1 +16.*EPF(P2,P3,Q1,Q3)*CSXCU*CV3*U**2 RETURN END +EOD +DECK,WZTU. FUNCTION WZTU(T,U,T1,U1,T3,U3,P1,P2) C DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980). C ALL T AND U GRAPH TERMS. +CDE,ITAPES +CDE,WWPAR. DIMENSION P1(4),P2(4) +SELF,IF=DOUBLE. DOUBLE PRECISION WZTU DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2 DOUBLE PRECISION WM4,ZM4,WZM2,CTXCT,CTXCU,CUXCU,EPF +SELF. WM4=WM2**2 ZM4=ZM2**2 WZM2=WM2*ZM2 CTXCT=CT**2/T**2 CTXCU=CT*CU/(T*U) CUXCU=CU**2/U**2 WZTU= 1 +CTXCT*CV3*(-128.*WM2*T1*T3**2-64.*WM2*T1*ZM4-64.*ZM2*T1**2*T3-6 1 4.*ZM2*T3*WM4-128.*T1*T3*WZM2-64.*T1**2*T3**2-32.*T1**2*ZM4-64.* 1 T3**2*WM4-32.*WM4*ZM4) WZTU=WZTU 1 +CTXCT*CV3*T*(64.*WM2*T1*T3-32.*WM2*U1*T3-64.*WM2*T3*S13+64.*WM2 1 *T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3-32.*ZM2*T1*S13+32.*ZM2*T1**2+32 1 .*ZM2*WM4-32.*T1*U1*T3-64.*T1*T3*S13+64.*T1*T3**2+64.*T1*WZM2+32 1 .*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4-32.*S13*WZM2) 1 +CTXCT*CV3*T**2*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13- 1 32.*T1*T3+32.*T1*S13+32.*U1*T3+64.*T3*S13-32.*WZM2) WZTU=WZTU 1 +CTXCT*CV3*T**3*(-32.*S13) 1 +CTXCT*CA3*(64.*WM2*T1*ZM4+64.*ZM2*T1**2*T3+64.*ZM2*T3*WM4+128.* 1 T1*T3*WZM2+32.*T1**2*ZM4+32.*WM4*ZM4) 1 +CTXCT*CA3*T*(-64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*ZM4-64.*ZM2*T 1 1*T3+32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*WM4-32.*T1*U1*T3-64.*T 1 1*WZM2-32.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4+32.*S13*WZ 1 M2) WZTU=WZTU 1 +CTXCT*CA3*T**2*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+3 1 2.*T1*T3-32.*T1*S13+32.*U1*T3+32.*WZM2) 1 +CTXCT*CA3*T**3*(32.*S13) WZTU=WZTU 1 +CTXCU*CV3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+64.*WM2*T1*ZM4-128.* 1 WM2*U1*T3*U3+64.*WM2*T3*ZM4+64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3-64. 1 *ZM2*T1*U1*U3+64.*ZM2*T1*WM4+64.*ZM2*T3*WM4+64.*ZM2*S13*WM4-128. 1 *T1*U1*T3*U3+64.*T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2-64.*U 1 1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2+128.*T3*S13*WZM2+64.*T3 1 **2*WZM2+64.*S13**2*WZM2+64.*WM4*ZM4) WZTU=WZTU 1 +CTXCU*CV3*T*(32.*WM2*U1*U3-64.*WM2*ZM4+32.*ZM2*U1*T3+32.*ZM2*U1 1 *U3-32.*ZM2*U1*S13-32.*ZM2*U1**2-64.*ZM2*WM4+32.*T1*U1*U3-64.*T1 1 *WZM2+64.*U1*T3*U3-64.*U1*U3*S13-32.*U1**2*U3-64.*T3*WZM2-64.*S1 1 3*WZM2) 1 +CTXCU*CV3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32 1 .*T1*T3-32.*T1*S13-64.*U1*T3-32.*U1*S13-64.*T3*S13-64.*S13**2+32 1 .*WZM2) WZTU=WZTU 1 +CTXCU*CV3*T**2*(-32.*U1*U3+32.*WZM2) 1 +CTXCU*CV3*T**2*U*(32.*S13) 1 +CTXCU*CV3*U*(-64.*WM2*T1*T3+32.*WM2*U1*T3-64.*WM2*T3*S13-64.*WM 1 2*T3**2-32.*WM2*ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-3 1 2.*ZM2*WM4+32.*T1*U1*T3-64.*T1*T3*S13-64.*T1*T3**2-64.*T1*WZM2-3 1 2.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2) WZTU=WZTU 1 +CTXCU*CA3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-64.*WM2*T1*ZM4-64.* 1 WM2*T3*ZM4-64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64. 1 *ZM2*T1*WM4-64.*ZM2*T3*WM4-64.*ZM2*S13*WM4-64.*T1*T3*WZM2-64.*T1 1 *S13*WZM2-32.*T1**2*WZM2+64.*U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1** 1 2*WZM2-64.*WM4*ZM4) WZTU=WZTU 1 +CTXCU*CA3*T*(-32.*WM2*U1*U3+64.*WM2*ZM4+32.*ZM2*U1*T3-32.*ZM2*U 1 1*U3-32.*ZM2*U1*S13-32.*ZM2*U1**2+64.*ZM2*WM4-32.*T1*U1*U3+64.*T 1 1*WZM2-32.*U1**2*U3+64.*T3*WZM2+64.*S13*WZM2) 1 +CTXCU*CA3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3 1 2.*T1*T3+32.*T1*S13-64.*U1*T3-32.*U1*S13-32.*WZM2) 1 +CTXCU*CA3*T**2*(32.*U1*U3-32.*WZM2) WZTU=WZTU 1 +CTXCU*CA3*T**2*U*(-32.*S13) 1 +CTXCU*CA3*U*(64.*WM2*T1*T3+32.*WM2*U1*T3+32.*WM2*ZM4+64.*ZM2*T1 1 *T3+32.*ZM2*T1*S13+32.*ZM2*T1**2+32.*ZM2*WM4+32.*T1*U1*T3+64.*T1 1 *WZM2+32.*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM 1 2) 1 +CUXCU*CV3*(-64.*ZM2*U1**2*U3-64.*U1**2*U3**2-32.*U1**2*ZM4) WZTU=WZTU 1 +CUXCU*CV3*T*U*(32.*U1*U3) 1 +CUXCU*CV3*U*(-32.*WM2*U1*U3-32.*ZM2*U1*T3-32.*ZM2*U1*U3-32.*ZM2 1 *U1*S13+32.*ZM2*U1**2-32.*T1*U1*U3-64.*U1*T3*U3-64.*U1*U3*S13+32 1 .*U1**2*U3) 1 +CUXCU*CV3*U**2*(32.*U1*T3+32.*U1*S13) 1 +CUXCU*CA3*(-64.*ZM2*U1**2*U3-32.*U1**2*ZM4) WZTU=WZTU 1 +CUXCU*CA3*T*U*(-32.*U1*U3) 1 +CUXCU*CA3*U*(32.*WM2*U1*U3-32.*ZM2*U1*T3+32.*ZM2*U1*U3-32.*ZM2* 1 U1*S13+32.*ZM2*U1**2+32.*T1*U1*U3+32.*U1**2*U3) 1 +CUXCU*CA3*U**2*(32.*U1*T3+32.*U1*S13) 1 +EPF(P1,P2,P3,Q1)*CTXCU*CV3*(-32.*ZM2*T1-16.*WZM2) 1 +EPF(P1,P2,P3,Q1)*CTXCU*CV3*T*(16.*ZM2) WZTU=WZTU 1 +EPF(P1,P2,P3,Q3)*CTXCU*CV3*(-48.*WM2*T1-16.*WM2*U1-32.*WM2*S13- 1 32.*T1*U1-64.*T1*S13-32.*T1**2-16.*WM4) 1 +EPF(P1,P2,P3,Q3)*CTXCU*CV3*T*(16.*WM2+16.*T1+16.*U1+32.*S13) 1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*(-32.*WM2*T3-32.*WM2*U3-64.*ZM2*T1-6 1 4.*T1*T3-64.*T1*U3-32.*WZM2) 1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T*(16.*WM2+32.*ZM2+32.*T1+32.*T3+32. 1 *U3) WZTU=WZTU 1 -16.*EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T*U 1 -16.*EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T**2 1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*U*(16.*WM2+32.*T1) 1 +EPF(P1,P3,Q1,Q3)*CTXCU*CV3*(32.*WM2*T3+32.*ZM2*T1+64.*T1*T3+16. 1 *WZM2) 1 +EPF(P1,P3,Q1,Q3)*CTXCU*CV3*T*(-16.*WM2-16.*ZM2-32.*T1-32.*T3) WZTU=WZTU 1 +16.*EPF(P1,P3,Q1,Q3)*CTXCU*CV3*T**2 1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*(-32.*WM2*U3-32.*ZM2*T1-64.*T1*U3-16 1 .*WZM2) 1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*T*(16.*ZM2+32.*U3) 1 -16.*EPF(P2,P3,Q1,Q3)*CTXCU*CV3*T*U 1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*U*(16.*WM2+32.*T1)+0. RETURN END +EOD +DECK,XWWWW. SUBROUTINE XWWWW C C SET UP W+ W- -> W+ W- AMPLITUDES AS RATIONAL FUNCTIONS OF Z C C RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I C /(ADWWWW(1,J)+ADWWWW(2,J)*Z)) C IM(F(Z,L)) = AIWWWW(L) (INDEPENDENT OF Z) C J LABELS PIECES WITH SAME DENOMINATOR. C L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1 C C *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01 C +CDE,CONST +CDE,JETPAR +CDE,WCON +CDE,HCON +SELF,IF=DOUBLE. DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2 $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF +SELF. C C USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW C AND AIWWWW ARE DIMENSIONLESS WM=WMASS(2) ZM=WMASS(4)/WM ZM2=ZM**2 ZM3=ZM**3 ZM4=ZM**4 ZM5=ZM**5 ZM6=ZM**6 HM=HMASS/WM HM2=HM**2 HM3=HM**3 HM4=HM**4 HG=HGAM/WM HG2=HG**2 RTS=QMW/WM S=RTS**2 S2=S**2 S3=S**3 PROPH=(S-HM2)**2+(HM*HG)**2 C CW=1./ZM CW2=CW**2 SW2=1.-CW2 SW=SQRT(SW2) QQ0=.5*RTS QQI=.5*SQRT(S-4.) QQF=.5*SQRT(S-4.) GSQ=4.*PI*ALFA/SW2 C C FROM WWWW3.EX ANWWWW(1,1,1) = 8.00E+00 * S - 3.00E+00 * S2 - 1.60E+01 $ * ( HM2 / PROPH) + 1.60E+01 * (S / PROPH) - 1.60E+01 * (S2 $ / PROPH) + 4.00E+00 * (S3 / PROPH) + 1.60E+01 * ((HM2 * S) $ / PROPH) - 4.00E+00 * ((HM2 * S2) / PROPH) ANWWWW(1,1,2) = 2.00E+00 * S ANWWWW(1,1,3) = -1.60E+01 + 6.00E+00 * S - 1.60E+01 * (HM2 $ / PROPH) + 1.60E+01 * (S / PROPH) - 8.00E+00 * (S2 / PROPH) $ + 8.00E+00 * ((HM2 * S) / PROPH) ANWWWW(1,1,4) = -2.40E+01 * RTS + 6.40E+01 * (RTS / (S $ - 1.00E+00 * ZM2)) + 1.60E+01 * ((RTS * S) / (S - 1.00E+00 $ * ZM2)) - 8.00E+00 * ((RTS * S2) / (S - 1.00E+00 * ZM2)) $ + 6.40E+01 * ((RTS * SW2) / S) - 6.40E+01 * ((RTS * SW2) / (S $ - 1.00E+00 * ZM2)) - 1.60E+01 * ((RTS * S * SW2) / (S $ - 1.00E+00 * ZM2)) + 8.00E+00 * ((RTS * S2 * SW2) / (S $ - 1.00E+00 * ZM2)) + 6.00E+00 * RTS * S + 1.60E+01 * RTS $ * SW2 - 8.00E+00 * RTS * S * SW2 ANWWWW(1,2,1) = -6.40E+01 + 1.60E+01 * S - 1.20E+01 * S2 $ + 3.00E+00 * S3 + 6.40E+01 * SW2 - 1.60E+01 * S * SW2 $ + 1.20E+01 * S2 * SW2 - 3.00E+00 * S3 * SW2 ANWWWW(1,2,2) = 6.40E+01 + 8.00E+00 * S - 2.00E+00 * S2 $ - 6.40E+01 * SW2 - 8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2 ANWWWW(1,2,3) = -6.40E+01 + 2.40E+01 * S - 6.00E+00 * S2 $ + 6.40E+01 * SW2 - 2.40E+01 * S * SW2 + 6.00E+00 * S2 * SW2 ANWWWW(1,2,4) = -9.60E+01 * RTS + 1.60E+01 * RTS * S + 2.00E+00 $ * RTS * S2 + 9.60E+01 * RTS * SW2 - 1.60E+01 * RTS * S * SW2 $ - 2.00E+00 * RTS * S2 * SW2 ANWWWW(1,3,1) = -6.40E+01 * SW2 + 1.60E+01 * S * SW2 - 1.20E+01 $ * S2 * SW2 + 3.00E+00 * S3 * SW2 ANWWWW(1,3,2) = 6.40E+01 * SW2 + 8.00E+00 * S * SW2 - 2.00E+00 $ * S2 * SW2 ANWWWW(1,3,3) = -6.40E+01 * SW2 + 2.40E+01 * S * SW2 - 6.00E+00 $ * S2 * SW2 ANWWWW(1,3,4) = -9.60E+01 * RTS * SW2 + 1.60E+01 * RTS * S * SW2 $ + 2.00E+00 * RTS * S2 * SW2 ANWWWW(1,4,1) = -3.20E+01 + 1.60E+01 * S - 2.00E+00 * S2 ANWWWW(1,4,2) = -4.00E+00 * S ANWWWW(1,4,3) = 4.00E+00 * S ANWWWW(1,4,4) = -1.60E+01 * RTS + 4.00E+00 * RTS * S ANWWWW(2,1,1) = -2.40E+01 * S + 6.00E+00 * S2 + 4.80E+01 * SW2 $ + 6.40E+01 * (1.00E+00 / (S - 1.00E+00 * ZM2)) + 4.80E+01 * (S $ / (S - 1.00E+00 * ZM2)) - 4.00E+00 * (S3 / (S - 1.00E+00 $ * ZM2)) + 6.40E+01 * (SW2 / S) - 6.40E+01 * (SW2 / (S $ - 1.00E+00 * ZM2)) - 4.80E+01 * ((S * SW2) / (S - 1.00E+00 $ * ZM2)) + 4.00E+00 * ((S3 * SW2) / (S - 1.00E+00 * ZM2)) $ - 4.00E+00 * S2 * SW2 ANWWWW(2,1,2) = 0.00E+00 ANWWWW(2,1,3) = 1.60E+01 * SW2 + 6.40E+01 * (1.00E+00 / (S $ - 1.00E+00 * ZM2)) + 1.60E+01 * (S / (S - 1.00E+00 * ZM2)) $ - 8.00E+00 * (S2 / (S - 1.00E+00 * ZM2)) + 6.40E+01 * (SW2 $ / S) - 6.40E+01 * (SW2 / (S - 1.00E+00 * ZM2)) - 1.60E+01 $ * ((S * SW2) / (S - 1.00E+00 * ZM2)) + 8.00E+00 * ((S2 * SW2) $ / (S - 1.00E+00 * ZM2)) - 8.00E+00 * S * SW2 ANWWWW(2,1,4) = 2.00E+00 * RTS * S ANWWWW(2,2,1) = -6.40E+01 - 1.12E+02 * S + 5.20E+01 * S2 $ - 5.00E+00 * S3 + 6.40E+01 * SW2 + 1.12E+02 * S * SW2 $ - 5.20E+01 * S2 * SW2 + 5.00E+00 * S3 * SW2 ANWWWW(2,2,2) = -8.00E+00 * S + 2.00E+00 * S2 + 8.00E+00 * S $ * SW2 - 2.00E+00 * S2 * SW2 ANWWWW(2,2,3) = -5.60E+01 * S + 1.40E+01 * S2 + 5.60E+01 * S $ * SW2 - 1.40E+01 * S2 * SW2 ANWWWW(2,2,4) = 1.60E+02 * RTS - 8.00E+00 * RTS * S - 4.00E+00 $ * RTS * S2 - 1.60E+02 * RTS * SW2 + 8.00E+00 * RTS * S * SW2 $ + 4.00E+00 * RTS * S2 * SW2 ANWWWW(2,3,1) = -6.40E+01 * SW2 - 1.12E+02 * S * SW2 + 5.20E+01 $ * S2 * SW2 - 5.00E+00 * S3 * SW2 ANWWWW(2,3,2) = -8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2 ANWWWW(2,3,3) = -5.60E+01 * S * SW2 + 1.40E+01 * S2 * SW2 ANWWWW(2,3,4) = 1.60E+02 * RTS * SW2 - 8.00E+00 * RTS * S * SW2 $ - 4.00E+00 * RTS * S2 * SW2 ANWWWW(2,4,1) = -1.60E+01 * S + 4.00E+00 * S2 ANWWWW(2,4,2) = 0.00E+00 ANWWWW(2,4,3) = 0.00E+00 ANWWWW(2,4,4) = -4.00E+00 * RTS * S ANWWWW(3,1,1) = S2 ANWWWW(3,1,2) = -2.00E+00 * S ANWWWW(3,1,3) = 2.00E+00 * S ANWWWW(3,1,4) = 0.00E+00 ANWWWW(3,2,1) = 1.60E+02 * S - 3.60E+01 * S2 + S3 - 1.60E+02 $ * S * SW2 + 3.60E+01 * S2 * SW2 - 1.00E+00 * S3 * SW2 ANWWWW(3,2,2) = -6.40E+01 - 8.00E+00 * S + 2.00E+00 * S2 $ + 6.40E+01 * SW2 + 8.00E+00 * S * SW2 - 2.00E+00 * S2 * SW2 ANWWWW(3,2,3) = 6.40E+01 + 4.00E+01 * S - 1.00E+01 * S2 $ - 6.40E+01 * SW2 - 4.00E+01 * S * SW2 + 1.00E+01 * S2 * SW2 ANWWWW(3,2,4) = -8.00E+00 * RTS * S + 2.00E+00 * RTS * S2 $ + 8.00E+00 * RTS * S * SW2 - 2.00E+00 * RTS * S2 * SW2 ANWWWW(3,3,1) = 1.60E+02 * S * SW2 - 3.60E+01 * S2 * SW2 + S3 $ * SW2 ANWWWW(3,3,2) = -6.40E+01 * SW2 - 8.00E+00 * S * SW2 + 2.00E+00 $ * S2 * SW2 ANWWWW(3,3,3) = 6.40E+01 * SW2 + 4.00E+01 * S * SW2 - 1.00E+01 $ * S2 * SW2 ANWWWW(3,3,4) = -8.00E+00 * RTS * S * SW2 + 2.00E+00 * RTS * S2 $ * SW2 ANWWWW(3,4,1) = -2.00E+00 * S2 ANWWWW(3,4,2) = 4.00E+00 * S ANWWWW(3,4,3) = -4.00E+00 * S ANWWWW(3,4,4) = 0.00E+00 ANWWWW(4,1,1) = 0.00E+00 ANWWWW(4,1,2) = 0.00E+00 ANWWWW(4,1,3) = 0.00E+00 ANWWWW(4,1,4) = 0.00E+00 ANWWWW(4,2,1) = -4.00E+00 * S2 + S3 + 4.00E+00 * S2 * SW2 $ - 1.00E+00 * S3 * SW2 ANWWWW(4,2,2) = 8.00E+00 * S - 2.00E+00 * S2 - 8.00E+00 * S $ * SW2 + 2.00E+00 * S2 * SW2 ANWWWW(4,2,3) = -8.00E+00 * S + 2.00E+00 * S2 + 8.00E+00 * S $ * SW2 - 2.00E+00 * S2 * SW2 ANWWWW(4,2,4) = 0.00E+00 ANWWWW(4,3,1) = -4.00E+00 * S2 * SW2 + S3 * SW2 ANWWWW(4,3,2) = 8.00E+00 * S * SW2 - 2.00E+00 * S2 * SW2 ANWWWW(4,3,3) = -8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2 ANWWWW(4,3,4) = 0.00E+00 ANWWWW(4,4,1) = 0.00E+00 ANWWWW(4,4,2) = 0.00E+00 ANWWWW(4,4,3) = 0.00E+00 ANWWWW(4,4,4) = 0.00E+00 C ADWWWW(1,1) = 1.00E+00 ADWWWW(1,2) = -4.00E+00 + S + 2.00E+00 * ZM2 ADWWWW(1,3) = -4.00E+00 + S ADWWWW(1,4) = -4.00E+00 + 2.00E+00 * HM2 + S ADWWWW(2,1) = 0.00E+00 ADWWWW(2,2) = 4.00E+00 - 1.00E+00 * S ADWWWW(2,3) = 4.00E+00 - 1.00E+00 * S ADWWWW(2,4) = 4.00E+00 - 1.00E+00 * S C AIWWWW(1) = 1.60E+01 * ((HG * HM) / PROPH) - 1.60E+01 * ((HG $ * HM * S) / PROPH) + 4.00E+00 * ((HG * HM * S2) / PROPH) AIWWWW(2) = 0.00E+00 AIWWWW(3) = 1.60E+01 * ((HG * HM) / PROPH) - 8.00E+00 * ((HG $ * HM * S) / PROPH) AIWWWW(4) = 0.00E+00 C C RESTORE MISSING FACTORS DO 100 J=1,4 AIWWWW(J)=AIWWWW(J)*GSQ/(16.) DO 100 I=1,4 DO 110 K=1,4 110 ANWWWW(K,I,J)=ANWWWW(K,I,J)*GSQ/(16.) 100 CONTINUE C RETURN END +EOD +DECK,XWWZZ SUBROUTINE XWWZZ C C SET UP W+ W- -> Z0 Z0 AMPLITUDES AS RATIONAL FUNCTIONS OF Z C C RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I C /(ADWWWW(1,J)+ADWWWW(2,J)*Z)) C IM(F(Z,L)) = AIWWWW(L) (INDEPENDENT OF Z) C J LABELS PIECES WITH SAME DENOMINATOR. C L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1 C C *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01 C +CDE,CONST +CDE,JETPAR +CDE,WCON +CDE,HCON +SELF,IF=DOUBLE. DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2 $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF +SELF. C C USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW C AND AIWWWW ARE DIMENSIONLESS WM=WMASS(2) ZM=WMASS(4)/WM ZM2=ZM**2 ZM3=ZM**3 ZM4=ZM**4 ZM5=ZM**5 ZM6=ZM**6 HM=HMASS/WM HM2=HM**2 HM3=HM**3 HM4=HM**4 HG=HGAM/WM HG2=HG**2 RTS=QMW/WM S=RTS**2 S2=S**2 S3=S**3 PROPH=(S-HM2)**2+(HM*HG)**2 C CORRECT SIGN OF HIGGS AMPLITUDE. PROPH=-PROPH C CW=1./ZM CW2=CW**2 SW2=1.-CW2 SW=SQRT(SW2) QQ0=.5*RTS QQI=.5*SQRT(S-4.) QQF=.5*SQRT(S-4.*ZM2) GSQ=4.*PI*ALFA/SW2 C C FROM WWZZ3.EX ANWWWW(1,1,1) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH)) $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2 $ * ZM) / (CW * PROPH)) - 8.00E+00 * ((S2 * ZM3) / (CW * PROPH)) $ + 4.00E+00 * ((S3 * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S $ * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM3) / (CW $ * PROPH)) - 4.00E+00 * ((HM2 * S2 * ZM) / (CW * PROPH)) $ + 8.00E+00 * CW2 * S - 6.00E+00 * CW2 * S2 + 8.00E+00 * CW2 $ * S * ZM2 ANWWWW(1,1,2) = 4.00E+00 * CW2 * S * ZM2 ANWWWW(1,1,3) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH)) $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2 $ * ZM3) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM3) / (CW $ * PROPH)) - 3.20E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2 ANWWWW(1,1,4) = 0.00E+00 ANWWWW(1,2,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3 $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2 $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4 ANWWWW(1,2,2) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2 $ - 4.00E+00 * CW2 * S * ZM4 - 2.00E+00 * CW2 * S2 * ZM2 ANWWWW(1,2,3) = -6.40E+01 * CW2 * ZM2 + 2.00E+01 * CW2 * S * ZM2 $ + 4.00E+00 * CW2 * S * ZM4 - 6.00E+00 * CW2 * S2 * ZM2 ANWWWW(1,2,4) = 1.92E+02 * CW2 * QQ0 * QQF * QQI * ZM $ - 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM3 + 3.20E+01 * CW2 $ * QQ0 * QQF * QQI * ZM5 + 1.60E+01 * CW2 * QQ0 * QQF * QQI * S $ * ZM ANWWWW(1,3,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3 $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2 $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4 ANWWWW(1,3,2) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2 $ - 4.00E+00 * CW2 * S * ZM4 - 2.00E+00 * CW2 * S2 * ZM2 ANWWWW(1,3,3) = -6.40E+01 * CW2 * ZM2 + 2.00E+01 * CW2 * S * ZM2 $ + 4.00E+00 * CW2 * S * ZM4 - 6.00E+00 * CW2 * S2 * ZM2 ANWWWW(1,3,4) = -1.92E+02 * CW2 * QQ0 * QQF * QQI * ZM $ + 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM3 - 3.20E+01 * CW2 $ * QQ0 * QQF * QQI * ZM5 - 1.60E+01 * CW2 * QQ0 * QQF * QQI * S $ * ZM ANWWWW(1,4,1) = 0.00E+00 ANWWWW(1,4,2) = 0.00E+00 ANWWWW(1,4,3) = 0.00E+00 ANWWWW(1,4,4) = 0.00E+00 ANWWWW(2,1,1) = 0.00E+00 ANWWWW(2,1,2) = 0.00E+00 ANWWWW(2,1,3) = 0.00E+00 ANWWWW(2,1,4) = 8.00E+00 * CW2 * QQ0 * S * ZM ANWWWW(2,2,1) = 4.80E+01 * CW2 * QQF * QQI * S - 2.00E+01 * CW2 $ * QQF * QQI * S2 + 6.40E+01 * CW2 * QQF * QQI * ZM2 + 9.60E+01 $ * CW2 * QQF * QQI * S * ZM2 - 1.60E+01 * CW2 * QQF * QQI * S $ * ZM4 ANWWWW(2,2,2) = 8.00E+00 * CW2 * QQF * QQI * S * ZM2 ANWWWW(2,2,3) = 5.60E+01 * CW2 * QQF * QQI * S * ZM2 ANWWWW(2,2,4) = 1.28E+02 * CW2 * QQ0 * ZM + 1.92E+02 * CW2 * QQ0 $ * ZM3 - 3.20E+01 * CW2 * QQ0 * S * ZM + 2.40E+01 * CW2 * QQ0 $ * S * ZM3 - 8.00E+00 * CW2 * QQ0 * S * ZM5 - 8.00E+00 * CW2 $ * QQ0 * S2 * ZM ANWWWW(2,3,1) = -4.80E+01 * CW2 * QQF * QQI * S + 2.00E+01 * CW2 $ * QQF * QQI * S2 - 6.40E+01 * CW2 * QQF * QQI * ZM2 $ - 9.60E+01 * CW2 * QQF * QQI * S * ZM2 + 1.60E+01 * CW2 * QQF $ * QQI * S * ZM4 ANWWWW(2,3,2) = -8.00E+00 * CW2 * QQF * QQI * S * ZM2 ANWWWW(2,3,3) = -5.60E+01 * CW2 * QQF * QQI * S * ZM2 ANWWWW(2,3,4) = 1.28E+02 * CW2 * QQ0 * ZM + 1.92E+02 * CW2 * QQ0 $ * ZM3 - 3.20E+01 * CW2 * QQ0 * S * ZM + 2.40E+01 * CW2 * QQ0 $ * S * ZM3 - 8.00E+00 * CW2 * QQ0 * S * ZM5 - 8.00E+00 * CW2 $ * QQ0 * S2 * ZM ANWWWW(2,4,1) = 0.00E+00 ANWWWW(2,4,2) = 0.00E+00 ANWWWW(2,4,3) = 0.00E+00 ANWWWW(2,4,4) = 0.00E+00 ANWWWW(3,1,1) = 2.00E+00 * CW2 * S2 ANWWWW(3,1,2) = -4.00E+00 * CW2 * S * ZM2 ANWWWW(3,1,3) = 4.00E+00 * CW2 * S * ZM2 ANWWWW(3,1,4) = 0.00E+00 ANWWWW(3,2,1) = 3.20E+01 * CW2 * S - 1.60E+01 * CW2 * S2 + CW2 $ * S3 + 9.60E+01 * CW2 * S * ZM2 + 3.20E+01 * CW2 * S * ZM4 $ - 2.20E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4 ANWWWW(3,2,2) = -6.40E+01 * CW2 * ZM2 - 1.20E+01 * CW2 * S $ * ZM2 + 4.00E+00 * CW2 * S * ZM4 + 2.00E+00 * CW2 * S2 * ZM2