+TITLE ISAJET 7.78 27-MAR-2008 12:16:18 +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,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,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,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/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 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,IGUTST,ASM3, $VUMT,VDMT,ASMTP,ASMSS,M3Q,MHDSQ,MHUSQ,MHDSMG,MHUSMG,MUMG,BMG, $FT2Z1,FB2Z1,FL2Z1 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 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG,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(10) REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN SAVE /SUGXIN/ +KEEP,XMSSM COMMON/XMSSM/GOMSSM,GOSUG,GOGMSB,GOAMSB,AL3UNI,GOMMAM $,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 +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/ C C DATA FOR XMSSM DATA GOMSSM/.FALSE./,GOSUG/.FALSE./,GOGMSB/.FALSE./ DATA GOAMSB/.FALSE./,GOMMAM/.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/ 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)=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)=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)=102 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=101 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)=102 ICOLOR(2,4)=0 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)=102 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)=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)=103 ICOLOR(2,4)=102 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)=102 ICOLOR(2,2)=101 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)=102 ICOLOR(2,3)=103 ICOLOR(1,4)=103 ICOLOR(2,4)=0 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)=103 ICOLOR(2,3)=101 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)