Index: trunk/code/jewel-2.3.0.f
===================================================================
--- trunk/code/jewel-2.3.0.f (revision 504)
+++ trunk/code/jewel-2.3.0.f (revision 505)
@@ -1,7848 +1,7849 @@
PROGRAM JEWEL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
integer j,i,kk,poissonian
integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
double precision sumofweightstot,wdisctot,scalefac
double precision gettemp,r,tau
character*2 b1,b2
call init()
SUMOFWEIGHTSTOT=0.d0
WDISCTOT=0.d0
C--e+ + e- event generation
if (collider.eq.'EEJJ') then
b1 = 'e+'
b2 = 'e-'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
&' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--e+ + e- event loop
DO 100 J=1,NSIM
call genevent(j,b1,b2)
100 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb'
write(logfid,*)'sum of event weights in e+ + e- channel:',
& sumofweights-wdisc
write(logfid,*)
else
C--hadronic event generation
if (isochannel.eq.'PP') then
nsimpp = nsim
nsimpn = 0
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'PN') then
nsimpp = 0
nsimpn = nsim
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'NP') then
nsimpp = 0
nsimpn = 0
nsimnp = nsim
nsimnn = 0
elseif (isochannel.eq.'NN') then
nsimpp = 0
nsimpn = 0
nsimnp = 0
nsimnn = nsim
else
nsimpp = poissonian(1.d0*nsim*nproton**2/mass**2)
nsimpn = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnp = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnn = poissonian(1.d0*nsim*(mass-nproton)**2/mass**2)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
scalefac = nsim*1.d0/(nsimsum*1.d0)
nsimpp = int(nsimpp*scalefac)
nsimpn = int(nsimpn*scalefac)
nsimnp = int(nsimnp*scalefac)
nsimnn = int(nsimnn*scalefac)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
endif
C--loop over channels
do 101 kk=1,4
if (kk.eq.1) then
b1 = 'p+'
b2 = 'p+'
nsimchn = nsimpp
elseif (kk.eq.2) then
b1 = 'p+'
b2 = 'n0'
nsimchn = nsimpn
elseif (kk.eq.3) then
b1 = 'n0'
b2 = 'p+'
nsimchn = nsimnp
else
b1 = 'n0'
b2 = 'n0'
nsimchn = nsimnn
endif
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsimchn,' events in ',
&b1,' + ',b2,' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--event loop
DO 102 J=1,nsimchn
call genevent(j,b1,b2)
102 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
& PARI(1),'mb'
write(logfid,*)'sum of event weights in ',b1,' + ',b2,
& ' channel:',sumofweights-wdisc
write(logfid,*)
101 continue
endif
C--finish
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
WRITE(HPMCFID,*)
CLOSE(HPMCFID,status='keep')
write(logfid,*)
write(logfid,*)'mean number of scatterings:',
& NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of effective scatterings:',
& NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings:',
& NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from IS shower:',
& nspliti/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from FS shower:',
& nsplitf/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'fraction of rejected IS splittings:',
& nisfail/nistry
write(logfid,*)'fraction of rejected FS splittings:',
& nfsfail/nfstry
write(logfid,*)'fraction of rejected momentum transfers:',
& ntrej/nttot
write(logfid,*)
write(logfid,*)'number of extrapolations in splitting integral: ',
& noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting partonic PDFs: ',
& noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting cross sections: ',
& noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in Sudakov form factor: ',
& noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
write(logfid,*)
write(logfid,*)'number of good events: ',ngood
write(logfid,*)'total number of discarded events: ',NDISC
write(logfid,*)'number of events for which conversion '//
&'to hepmc failed: ',NSTRANGE
call printtime
close(logfid,status='keep')
END
***********************************************************************
***********************************************************************
*** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES ****************
***********************************************************************
***********************************************************************
***********************************************************************
*** subroutine init
***********************************************************************
subroutine init()
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
common/pdfas/pdfalphas
double precision pdfalphas
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2)
&,SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
INTEGER NJOB,ios,pos,i,j,jj,intmass
DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr
character firstchar
CHARACTER*2 SNSET
CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer,
&label,value
CHARACTER*120 HEPMCFILE,LOGFILE,FILENAME2
CHARACTER(LEN=100) filename
LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST
data maxnscatcen/22990/
HPMCFID = 4
logfid = 3
C--default settings
nsim = 10000
njob = 0
logfile = 'out.log'
hepmcfile = 'out.hepmc'
filesplit = 'splitint.dat'
pdffile = 'pdfs.dat'
xsecfile = 'xsecs.dat'
filemed = 'medium-params.dat'
nf = 3
lqcd = 0.4
q0 = 1.5
ptmin = 5.
ptmax = 350.
etamax = 3.1
collider = 'PPJJ'
isochannel = 'XX'
channel = 'MUON'
sqrts = 2760
pdfset = 13100
pdfalphas = 0.118
mass = 208
nproton = 82
weighted = .true.
weightex = 5.
angord = .true.
allhad = .false.
hadro = .true.
hadrotype = 0
shorthepmc = .true.
compress = .true.
writescatcen = .false.
writedummies = .false.
scatrecoil = .false.
recsoftcut = 0.
rechardcut = 5.
kinmode = 1
recmode = 0
if (iargc().eq.0) then
write(*,*)'No parameter file given, '//
&'will run with default settings.'
else
call getarg(1,filename)
write(*,*)'Reading parameters from ',filename
open(unit=1,file=filename,status='old',err=110)
do 120 i=1,1000
read(1, '(A)', iostat=ios) buffer
if(ios.ne.0) goto 130
firstchar = buffer(1:1)
if (firstchar.eq.'#') goto 120
pos=scan(buffer,' ')
label=buffer(1:pos)
value=buffer(pos+1:)
if(label.eq."NEVENT")then
read(value,*,iostat=ios) nsim
elseif(label.eq."NJOB")then
read(value,*,iostat=ios) njob
elseif(label.eq."LOGFILE")then
read(value,'(a)',iostat=ios) logfile
elseif(label.eq."HEPMCFILE")then
read(value,'(a)',iostat=ios) hepmcfile
elseif(label.eq."SPLITINTFILE")then
read(value,'(a)',iostat=ios) filesplit
elseif(label.eq."PDFFILE")then
read(value,'(a)',iostat=ios) pdffile
elseif(label.eq."XSECFILE")then
read(value,'(a)',iostat=ios) xsecfile
elseif(label.eq."MEDIUMPARAMS")then
read(value,'(a)',iostat=ios) filemed
elseif(label.eq."NF")then
read(value,*,iostat=ios) nf
elseif(label.eq."LAMBDAQCD")then
read(value,*,iostat=ios) lqcd
elseif(label.eq."Q0")then
read(value,*,iostat=ios) q0
elseif(label.eq."PTMIN")then
read(value,*,iostat=ios) ptmin
elseif(label.eq."PTMAX")then
read(value,*,iostat=ios) ptmax
elseif(label.eq."ETAMAX")then
read(value,*,iostat=ios) etamax
elseif(label.eq."PROCESS")then
read(value,*,iostat=ios) collider
elseif(label.eq."ISOCHANNEL")then
read(value,*,iostat=ios) isochannel
elseif(label.eq."CHANNEL")then
read(value,*,iostat=ios) channel
elseif(label.eq."SQRTS")then
read(value,*,iostat=ios) sqrts
elseif(label.eq."PDFSET")then
read(value,*,iostat=ios) pdfset
elseif(label.eq."PDFALPHAS")then
read(value,*,iostat=ios) pdfalphas
elseif(label.eq."MASS")then
read(value,*,iostat=ios) mass
elseif(label.eq."NPROTON")then
read(value,*,iostat=ios) nproton
elseif(label.eq."WEIGHTED")then
read(value,*,iostat=ios) weighted
elseif(label.eq."WEXPO")then
read(value,*,iostat=ios) weightex
elseif(label.eq."ANGORD")then
read(value,*,iostat=ios) angord
elseif(label.eq."KEEPRECOILS")then
read(value,*,iostat=ios) allhad
elseif(label.eq."SCATRECOIL")then
read(value,*,iostat=ios) scatrecoil
elseif(label.eq."HADRO")then
read(value,*,iostat=ios) hadro
elseif(label.eq."HADROTYPE")then
read(value,*,iostat=ios) hadrotype
elseif(label.eq."SHORTHEPMC")then
read(value,*,iostat=ios) shorthepmc
elseif(label.eq."COMPRESS")then
read(value,*,iostat=ios) compress
elseif(label.eq."WRITESCATCEN")then
read(value,*,iostat=ios) writescatcen
elseif(label.eq."WRITEDUMMIES")then
read(value,*,iostat=ios) writedummies
elseif(label.eq."RECSOFTCUT")then
read(value,*,iostat=ios) recsoftcut
elseif(label.eq."RECHARDCUT")then
read(value,*,iostat=ios) rechardcut
elseif(label.eq."KINMODE")then
read(value,*,iostat=ios) kinmode
elseif(label.eq."RECMODE")then
read(value,*,iostat=ios) recmode
else
write(*,*)'unknown label ',label
endif
120 continue
110 write(*,*)
& 'Unable to open parameter file, will exit the run.'
call exit(1)
130 close(1,status='keep')
write(*,*)'...done'
endif
lps = lqcd
! scatrecoil = .false.
! if (.not.hadro) shorthepmc = .true.
if (recmode.eq.2) then
allhad = .false.
scatrecoil = .false.
endif
SCALEFACM=1.
ptfac=1.
ftfac=1.d0
if (ptmin.lt.3.d0) ptmin = 3.d0
if (.not.writescatcen) writedummies = .false.
OPEN(unit=logfid,file=LOGFILE,status='unknown')
MSTU(11)=logfid
call printtime
call printlogo(logfid)
write(logfid,*)
write(logfid,*)'parameters of the run:'
write(logfid,*)'NEVENT = ',nsim
write(logfid,*)'NJOB = ',njob
write(logfid,*)'LOGFILE = ',logfile
write(logfid,*)'HEPMCFILE = ',hepmcfile
write(logfid,*)'SPLITINTFILE = ',filesplit
write(logfid,*)'PDFFILE = ',pdffile
write(logfid,*)'XSECFILE = ',xsecfile
write(logfid,*)'MEDIUMPARAMS = ',filemed
write(logfid,*)'NF = ',nf
write(logfid,*)'LAMBDAQCD = ',lqcd
write(logfid,*)'Q0 = ',q0
write(logfid,*)'PTMIN = ',ptmin
write(logfid,*)'PTMAX = ',ptmax
write(logfid,*)'ETAMAX = ',etamax
write(logfid,*)'PROCESS = ',collider
write(logfid,*)'ISOCHANNEL = ',isochannel
write(logfid,*)'CHANNEL = ',channel
write(logfid,*)'SQRTS = ',sqrts
write(logfid,*)'PDFSET = ',pdfset
write(logfid,*)'PDFALPHAS = ',pdfalphas
write(logfid,*)'MASS = ',mass
write(logfid,*)'NPROTON = ',nproton
write(logfid,*)'WEIGHTED = ',weighted
write(logfid,*)'WEXPO = ',weightex
write(logfid,*)'ANGORD = ',angord
write(logfid,*)'HADRO = ',hadro
write(logfid,*)'HADROTYPE = ',hadrotype
write(logfid,*)'SHORTHEPMC = ',shorthepmc
write(logfid,*)'COMPRESS = ',compress
write(logfid,*)'KEEPRECOILS = ',allhad
write(logfid,*)'SCATRECOIL = ',scatrecoil
write(logfid,*)'RECSOFTCUT = ',recsoftcut
write(logfid,*)'RECHARDCUT = ',rechardcut
write(logfid,*)'WRITESCATCEN = ',writescatcen
write(logfid,*)'WRITEDUMMIES = ',writedummies
write(logfid,*)'KINMODE = ',kinmode
write(logfid,*)'RECMODE = ',recmode
write(logfid,*)
call flush(logfid)
if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
& .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
& .and.(collider.ne.'PPYG')
& .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
& .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
& .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
& .and.(collider.ne.'PPDY')) then
write(logfid,*)'Fatal error: colliding system unknown, '//
& 'will exit now'
call exit(1)
endif
C--initialize medium
intmass = int(mass)
CALL MEDINIT(FILEMED,logfid,etamax,intmass)
CALL MEDNEXTEVT
OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown')
WRITE(HPMCFID,*)
WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05'
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
NPART=2
if(ptmax.gt.0.)then
EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.)
else
EOVEST=sqrts/2.
endif
CALL EIXINT
CALL INSUDAINT(EOVEST)
write(logfid,*)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(SPLITIEXIST)THEN
write(logfid,*)'read splitting integrals from ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='old')
READ(10,*)QMAX,ZMMIN,NPOINT
DO 893 I=1,NPOINT+1
READ(10,*) QVAL(I),ZMVAL(I)
893 CONTINUE
DO 891 I=1,NPOINT+1
DO 892 J=1,NPOINT+1
READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
892 CONTINUE
891 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate splitting functions, '//
&'this may take some time'
CALL SPLITFNCINT(EOVEST)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(.NOT.SPLITIEXIST)THEN
write(logfid,*)'write splitting integrals to ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='new')
WRITE(10,*)QMAX,ZMMIN,NPOINT
DO 896 I=1,NPOINT+1
WRITE(10,*) QVAL(I),ZMVAL(I)
896 CONTINUE
DO 897 I=1,NPOINT+1
DO 898 J=1,NPOINT+1
WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
898 CONTINUE
897 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(PDFEXIST)THEN
write(logfid,*)'read pdfs from ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='old')
DO 872 I=1,2
DO 873 J=1,1000
READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
873 CONTINUE
872 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate pdfs, this may take some time'
CALL PDFINT(EOVEST)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(.NOT.PDFEXIST)THEN
write(logfid,*)'write pdfs to ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='new')
DO 876 I=1,2
DO 877 J=1,1000
WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
877 CONTINUE
876 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(XSECEXIST)THEN
write(logfid,*)'read cross sections from ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='old')
DO 881 J=1,1001
DO 885 JJ=1,101
READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
885 CONTINUE
881 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate cross sections, '//
&'this may take some time'
CALL XSECINT(EOVEST)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(.NOT.XSECEXIST)THEN
write(logfid,*)'write cross sections to ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='new')
DO 883 J=1,1001
DO 884 JJ=1,101
WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
884 CONTINUE
883 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
CALL FLUSH(3)
C--initialise random number generator status
IF(NJOB.GT.0)THEN
MRPY(1)=NJOB*1000
MRPY(2)=0
ENDIF
C--Call PYR once for initialization
R=PYR(0)
NDISC=0
NGOOD=0
NSTRANGE=0
ERRCOUNT=0
errl = 0
NSCAT=0.d0
NSCATEFF=0.d0
NSPLIT=0.d0
nspliti=0.d0
nsplitf=0.d0
nistry=0.d0
nisfail=0.d0
nfstry=0.d0
nfsfail=0.d0
nttot=0.d0
ntrej=0.d0
ntotspliti=0
noverspliti=0
ntotpdf=0
noverpdf=0
ntotxsec=0
noverxsec=0
ntotsuda=0
noversuda=0
end
***********************************************************************
*** subroutine initpythia
***********************************************************************
subroutine initpythia(beam1,beam2)
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
common/pdfas/pdfalphas
double precision pdfalphas
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
character*2 beam1,beam2
C--initialise PYTHIA
C--keep parton shower history in PYJETS
! MSTP(125)=2
C--no multiple interactions
MSTP(81) = 0
C--initial state radiation
MSTP(61)=1
C--switch off final state radiation off partons emitted from space-like shower
! MSTP(63)=0
C--switch off final state radiation
MSTP(71)=0
C--No hadronisation (yet)
MSTP(111)=0
C--parameter affecting treatment of string corners
PARU(14)=1.
C--Min shat in simulation
CKIN(1)=2.
C--pT-cut
CKIN(3)=PTMIN
CKIN(4)=PTMAX
C--ISR/FSR/UE tune
MSTP(5)=0
C...# Tuned flavour parameters:
PARJ(1) = 0.073
PARJ(2) = 0.2
PARJ(3) = 0.94
PARJ(4) = 0.032
PARJ(11) = 0.31
PARJ(12) = 0.4
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C--Fragmentation tune
MSTJ(11) = 5
PARJ(21) = 0.325
PARJ(41) = 0.5
PARJ(42) = 0.6
PARJ(47) = 0.67
PARJ(81) = 0.29
PARJ(82) = 1.65
C--particles stable if lifetime > PARJ(71), default = 10mm
MSTJ(22)=2
! PARJ(71)=288.
C--switch off pi0 decay
! MDCY(PYCOMP(111),1)=0
C--use LHAPDF
MSTP(52)=2
C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
C MSTW2008 (LO central) - 21000
MSTP(51)=PDFSET
IF(COLLIDER.EQ.'PPYQ')THEN
MSEL=0
MSUB(29)=1
ELSEIF(COLLIDER.EQ.'PPYG')THEN
MSEL=0
MSUB(14)=1
MSUB(115)=1
ELSEIF(COLLIDER.EQ.'PPYJ')THEN
MSEL=0
MSUB(14)=1
MSUB(29)=1
MSUB(115)=1
ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')
& .or.(COLLIDER.EQ.'PPZG')
& .or.(collider.eq.'PPDY'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1
IF(COLLIDER.EQ.'PPDY') MSUB(1)=1
MDME(174,1)=0 !Z decay into d dbar',
MDME(175,1)=0 !Z decay into u ubar',
MDME(176,1)=0 !Z decay into s sbar',
MDME(177,1)=0 !Z decay into c cbar',
MDME(178,1)=0 !Z decay into b bbar',
MDME(179,1)=0 !Z decay into t tbar',
MDME(182,1)=0 !Z decay into e- e+',
MDME(183,1)=0 !Z decay into nu_e nu_ebar',
MDME(184,1)=0 !Z decay into mu- mu+',
MDME(185,1)=0 !Z decay into nu_mu nu_mubar',
MDME(186,1)=0 !Z decay into tau- tau+',
MDME(187,1)=0 !Z decay into nu_tau nu_taubar',
if (channel.EQ.'ELEC')THEN
MDME(182,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(184,1)=1
ENDIF
ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')
& .or.(COLLIDER.EQ.'PPWG'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1
MDME(190,1)=0 ! W+ decay into dbar u,
MDME(191,1)=0 ! W+ decay into dbar c,
MDME(192,1)=0 ! W+ decay into dbar t,
MDME(194,1)=0 ! W+ decay into sbar u,
MDME(195,1)=0 ! W+ decay into sbar c,
MDME(196,1)=0 ! W+ decay into sbar t,
MDME(198,1)=0 ! W+ decay into bbar u,
MDME(199,1)=0 ! W+ decay into bbar c,
MDME(200,1)=0 ! W+ decay into bbar t,
MDME(202,1)=0 ! W+ decay into b'bar u,
MDME(203,1)=0 ! W+ decay into b'bar c,
MDME(204,1)=0 ! W+ decay into b'bar t,
MDME(206,1)=0 ! W+ decay into e+ nu_e,
MDME(207,1)=0 ! W+ decay into mu+ nu_mu,
MDME(208,1)=0 ! W+ decay into tau+ nu_tau,
MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau,
if (channel.EQ.'ELEC')THEN
MDME(206,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(207,1)=1
ENDIF
ELSE
C--All QCD processes are active
MSEL=1
ENDIF
! MSEL=0
! MSUB(11)=1
! MSUB(12)=1
! MSUB(53)=1
! MSUB(13)=1
! MSUB(68)=1
! MSUB(28)=1
C--weighted events
IF(WEIGHTED) MSTP(142)=1
C--number of errors to be printed
MSTU(22)=MAX(10,INT(5.*NSIM/100.))
C--number of lines in event record
MSTU(4)=23000
- MSTU(5)=23000
+! MSTU(5)=23000
+ MSTU(5)=10000
C--initialisation call
IF(COLLIDER.EQ.'EEJJ')THEN
OFFSET=9
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR.
& (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN
OFFSET=8
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or.
& (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN
OFFSET=10
CALL PYINIT('CMS',beam1,beam2,sqrts)
elseif (collider.eq.'PPDY') then
CALL PYINIT('CMS',beam1,beam2,sqrts)
ENDIF
end
***********************************************************************
*** subroutine genevent
***********************************************************************
subroutine genevent(j,b1,b2)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Variables local to this program
INTEGER NOLD,PID,IPART,LME1,LME2,j,i,LME1ORIG,LME2ORIG,llep1,
&llep2,lv
DOUBLE PRECISION PYR,ENI,QMAX1,R,GETMASS,PYP,Q1,Q2,P21,P22,ETOT,
&QMAX2,POLD,EN1,EN2,BETA(3),ENEW1,ENEW2,emax,lambda,x1,x2,x3,
&MEWEIGHT,PSWEIGHT,WEIGHT,EPS1,EPS2,THETA1,THETA2,Z1,Z2,
&getltimemax,pi,m1,m2
character*2 b1,b2
CHARACTER*2 TYPE1,TYPE2
LOGICAL FIRSTTRIP,WHICH1,WHICH2,ISDIQUARK
DATA PI/3.141592653589793d0/
N=0
COLMAX=600
DISCARD=.FALSE.
DO 91 I=1,23000
MV(I,1)=0.d0
MV(I,2)=0.d0
MV(I,3)=0.d0
MV(I,4)=0.d0
MV(I,5)=0.d0
ZA(I)=0.d0
ZD(I)=0.d0
THETAA(I)=0.d0
QQBARD(I)=.FALSE.
91 CONTINUE
nscatcen = 0
CALL MEDNEXTEVT
C--initialisation with matrix element
C--production vertex
CALL PICKVTX(X0,Y0)
LTIME=GETLTIMEMAX()
99 CALL PYEVNT
NPART=N-OFFSET
EVWEIGHT=PARI(10)
SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
GOTO 102
ELSE
NGOOD=NGOOD+1
ENDIF
-
+
C--DY: don't have to do anything
if (collider.eq.'PPDY') then
CALL PYEXEC
call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
goto 102
endif
C-- prepare event record
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
LME1ORIG=7
LME2ORIG=8
if(abs(k(7,2)).gt.21) then
lv=7
else
lv=8
endif
ELSE
LME1ORIG=OFFSET-1
LME2ORIG=OFFSET
ENDIF
DO 180 IPART=OFFSET+1, OFFSET+NPART
C--find decay leptons in V+jet events
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if(k(ipart,3).eq.offset-1) llep1=ipart
if(k(ipart,3).eq.offset) llep2=ipart
endif
IF(K(IPART,3).EQ.(LME1ORIG))THEN
LME1=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE1='GC'
ELSE
TYPE1='QQ'
ENDIF
ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN
LME2=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE2='GC'
ELSE
TYPE2='QQ'
ENDIF
ELSE
TRIP(IPART)=0
ANTI(IPART)=0
ZD(IPART)=0.d0
THETAA(IPART)=0.d0
ENDIF
C--assign colour indices
IF(K(IPART,1).EQ.2)THEN
IF(K(IPART-1,1).EQ.2)THEN
C--in middle of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
C--beginning of colour singlet
IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0))
& .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=0
FIRSTTRIP=.TRUE.
ELSE
TRIP(IPART)=0
ANTI(IPART)=COLMAX+1
FIRSTTRIP=.FALSE.
ENDIF
COLMAX=COLMAX+1
ENDIF
ENDIF
IF(K(IPART,1).EQ.1)THEN
C--end of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=0
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=0
ENDIF
ENDIF
180 CONTINUE
if (k(lme1,1).lt.11) K(LME1,1)=1
if (k(lme2,1).lt.11) K(LME2,1)=1
PID=K(LME1,2)
ENI=MAX(P(LME1,4),P(LME2,4))
DO 183 IPART=OFFSET+1, OFFSET+NPART
IF((IPART.NE.LME1).AND.(IPART.NE.LME2).AND.(K(IPART,1).LT.11))
& K(IPART,1)=4
if (k(ipart,2).eq.22) k(ipart,1)=4
183 CONTINUE
! DO 183 IPART=OFFSET+1, OFFSET+NPART
! IF((IPART.NE.LME1).AND.(IPART.NE.LME2))
! & K(IPART,1)=11
! if (k(ipart,2).eq.22) k(ipart,1)=4
! 183 CONTINUE
C--find virtualities and adapt four-vectors
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if (abs(k(lme1,2)).gt.21) then
QMAX1=0.d0
QMAX2=sqrt(pari(18)+p(lme1,5)**2)
else
QMAX1=sqrt(pari(18)+p(lme2,5)**2)
QMAX2=0.d0
endif
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ELSEIF(COLLIDER.EQ.'PPJJ'.OR.COLLIDER.EQ.'PPYJ'
& .OR.COLLIDER.EQ.'PPYQ'.OR.COLLIDER.EQ.'PPYG')THEN
if (k(lme1,1).eq.4) then
qmax1 = 0.d0
else
QMAX1=pari(17)
endif
if (k(lme2,1).eq.4) then
qmax2 = 0.d0
else
QMAX2=pari(17)
endif
! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
EN1=P(LME1,4)
EN2=P(LME2,4)
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
ETOT=P(LME1,4)+P(LME2,4)
IF(COLLIDER.EQ.'EEJJ')THEN
QMAX1=ETOT
QMAX2=ETOT
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
C-- find virtuality
Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
182 if (abs(k(lme1,2)).gt.21) then
m1=p(lme1,5)
else
m1=q1
endif
if (abs(k(lme2,2)).gt.21) then
m2=p(lme2,5)
else
m2=q2
endif
ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2
P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0)
& .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0)
& )THEN
IF(Q1.GT.Q2)THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ELSE
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
GOTO 182
ENDIF
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=m1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=m2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
C--correct to ME for first parton
IF(COLLIDER.EQ.'EEJJ')THEN
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
IF(Q1.GT.0.d0)THEN
C--generate z value
X1=Z1*(ETOT**2+Q1**2)/ETOT**2
X2=(ETOT**2-Q1**2)/ETOT**2
X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ENDIF
ENDIF
C--correct to ME for second parton
IF(Q2.GT.0.d0)THEN
C--generate z value
X1=(ETOT**2-Q2**2)/ETOT**2
X2=Z2*(ETOT**2+Q2**2)/ETOT**2
X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
ENDIF
186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2
P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=Q1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=Q2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
ENDIF
C--transfer recoil to decay leptons in V+jet
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
beta(1)=p(lv,1)/p(lv,4)
beta(2)=p(lv,2)/p(lv,4)
beta(3)=p(lv,3)/p(lv,4)
CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if (abs(k(lme1,2)).gt.21) then
beta(1)=p(lme1,1)/p(lme1,4)
beta(2)=p(lme1,2)/p(lme1,4)
beta(3)=p(lme1,3)/p(lme1,4)
else
beta(1)=p(lme2,1)/p(lme2,4)
beta(2)=p(lme2,2)/p(lme2,4)
beta(3)=p(lme2,3)/p(lme2,4)
endif
CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3))
endif
C--store initial parton pt and mass for output
if (k(lme1,1).eq.1) then
inpt(1) = pyp(lme1,10)
! inpt(1) = p(lme1,4)*sin(pyp(lme1,13))
inmass(1) = p(lme1,5)
inphi(1) = pyp(lme1,15)
ineta(1) = pyp(lme1,19)
inpt(2) = pyp(lme2,10)
! inpt(2) = p(lme2,4)*sin(pyp(lme2,13))
inmass(2) = p(lme2,5)
inphi(2) = pyp(lme2,15)
ineta(2) = pyp(lme2,19)
if (k(lme1,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme2,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z1
inz(2) = z2
if(z1.gt.0.d0) then
intheta(1) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(1) = 0.d0
endif
if(z2.gt.0.d0) then
intheta(2) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(2) = 0.d0
endif
else
inpt(1) = pyp(lme2,10)
! inpt(1) = p(lme2,4)*sin(pyp(lme2,13))
inmass(1) = p(lme2,5)
inphi(1) = pyp(lme2,15)
ineta(1) = pyp(lme2,19)
inpt(2) = pyp(lme1,10)
! inpt(2) = p(lme1,4)*sin(pyp(lme1,13))
inmass(2) = p(lme1,5)
inphi(2) = pyp(lme1,15)
ineta(2) = pyp(lme1,19)
if (k(lme2,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme1,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z2
inz(2) = z1
if(z2.gt.0.d0) then
intheta(1) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(1) = 0.d0
endif
if(z1.gt.0.d0) then
intheta(2) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(2) = 0.d0
endif
endif
ZA(LME1)=1.d0
ZA(LME2)=1.d0
THETAA(LME1)=P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
THETAA(LME2)=P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
ZD(LME1)=Z1
ZD(LME2)=Z2
QQBARD(LME1)=WHICH1
QQBARD(LME2)=WHICH2
MV(LME1,1)=X0
MV(LME1,2)=Y0
MV(LME1,3)=0.d0
MV(LME1,4)=0.d0
IF(P(LME1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME1,4)*0.2/Q1**2)
MV(LME1,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME1,5)=LTIME
ENDIF
MV(LME2,1)=X0
MV(LME2,2)=Y0
MV(LME2,3)=0.d0
MV(LME2,4)=0.d0
IF(P(LME2,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME2,4)*0.2/Q2**2)
MV(LME2,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME2,5)=LTIME
ENDIF
C--develop parton shower
CALL MAKECASCADE
IF(DISCARD) THEN
NGOOD=NGOOD-1
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
write(logfid,*)'discard event',J
GOTO 102
ENDIF
IF(.NOT.ALLHAD)THEN
DO 86 I=1,N
IF(K(I,1).EQ.3) K(I,1)=22
86 CONTINUE
ENDIF
IF(HADRO)THEN
CALL MAKESTRINGS(HADROTYPE)
! call combinegluons()
IF(DISCARD) THEN
write(logfid,*)'discard event',J
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
CALL PYEXEC
IF(MSTU(30).NE.ERRCOUNT)THEN
write(logfid,*)'PYTHIA discards event',J,
& ' (error number',MSTU(30),')'
ERRCOUNT=MSTU(30)
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
ENDIF
! DO 888 I=1,N
! IF(K(I,2).EQ.94)THEN
! NGOOD=NGOOD-1
! NSTRANGE=NSTRANGE+1
! NDISC=NDISC+1
! call pevrec(2,.false.)
! GOTO 102
! ENDIF
! 888 CONTINUE
IF(MSTU(30).NE.ERRCOUNT)THEN
ERRCOUNT=MSTU(30)
ELSE
CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
ENDIF
C--write message to log-file
102 IF(NSIM.GT.100)THEN
IF(MOD(J,NSIM/100).EQ.0)THEN
write(logfid,*) 'done with event number ',J,
& PARI(1), (sumofweights-wdisc)/j
ENDIF
else
write(logfid,*) 'done with event number ',J
ENDIF
call flush(logfid)
end
***********************************************************************
*** subroutine makestrings
***********************************************************************
SUBROUTINE MAKESTRINGS(WHICH)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER WHICH
IF(WHICH.EQ.0)THEN
CALL MAKESTRINGS_VAC
ELSEIF(WHICH.EQ.1)THEN
CALL MAKESTRINGS_MINL
ELSE
WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS'
ENDIF
END
***********************************************************************
*** subroutine makestrings_vac
***********************************************************************
SUBROUTINE MAKESTRINGS_VAC
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1
DOUBLE PRECISION EADDEND,PYR,DIR
LOGICAL ISDIQUARK,compressevent,roomleft
DATA EADDEND/10.d0/
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--first do strings with existing (anti)triplets
C--find string end (=quark or antiquark)
43 LQUARK=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR.
& (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN
LQUARK=I
GOTO 41
ENDIF
40 CONTINUE
GOTO 50
41 CONTINUE
C--copy string end to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LQUARK,2)
K(N,3)=LQUARK
K(N,4)=0
K(N,5)=0
P(N,1)=P(LQUARK,1)
P(N,2)=P(LQUARK,2)
P(N,3)=P(LQUARK,3)
P(N,4)=P(LQUARK,4)
P(N,5)=P(LQUARK,5)
K(LQUARK,1)=16
K(LQUARK,4)=N
K(LQUARK,5)=N
TRIP(N)=TRIP(LQUARK)
ANTI(N)=ANTI(LQUARK)
C--append matching colour partner
LMATCH=0
DO 44 J=1,10000000
DO 42 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0))
& .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
IF(K(I,2).EQ.21)THEN
K(N,1)=2
GOTO 44
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
42 CONTINUE
C--no matching colour partner found
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event',n,trip(n),anti(n),i
call pevrec(2,.true.)
discard = .true.
return
44 CONTINUE
C--now take care of purely gluonic remainder system
C-----------------------------------------
C--find gluon where anti-triplet is not matched
50 LLOOSE=0
DO 45 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
DO 46 J=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
IF(ANTI(I).EQ.TRIP(J)) GOTO 45
ENDIF
46 CONTINUE
LLOOSE=I
GOTO 47
ENDIF
45 CONTINUE
GOTO 51
47 CONTINUE
C--generate artificial triplet end
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
C--copy loose gluon to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LLOOSE,2)
K(N,3)=LLOOSE
K(N,4)=0
K(N,5)=0
P(N,1)=P(LLOOSE,1)
P(N,2)=P(LLOOSE,2)
P(N,3)=P(LLOOSE,3)
P(N,4)=P(LLOOSE,4)
P(N,5)=P(LLOOSE,5)
K(LLOOSE,1)=16
K(LLOOSE,4)=N
K(LLOOSE,5)=N
TRIP(N)=TRIP(LLOOSE)
ANTI(N)=ANTI(LLOOSE)
C--append matching colour partner
LMATCH=0
DO 48 J=1,10000000
DO 49 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(ANTI(I).EQ.TRIP(N)))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
K(N,1)=2
GOTO 48
ENDIF
49 CONTINUE
C--no matching colour partner found, add artificial end point
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
48 CONTINUE
51 CONTINUE
CALL CLEANUP(NOLD1)
END
***********************************************************************
*** subroutine makestrings_minl
***********************************************************************
SUBROUTINE MAKESTRINGS_MINL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1
DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR,
&pyp
DATA MCUT/1.d8/
DATA EADDEND/10.d0/
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
logical compressevent,roomleft
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--find most energetic unfragmented parton in event
43 EMAX=0
LMAX=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN
EMAX=P(I,4)
LMAX=I
ENDIF
40 CONTINUE
C--if there is non, we are done
IF(LMAX.EQ.0) GOTO 50
C--check if highest energy parton is (anti)quark or gluon
IF(K(LMAX,2).EQ.21)THEN
C--split gluon in qqbar pair and store one temporarily in line 1
C--make new line in event record for string end
N=N+2
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF((N-2).GT.NOLD)THEN
DO 47 J=NOLD,N-3
K(N+NOLD-J,1)=K(N+NOLD-J-2,1)
K(N+NOLD-J,2)=K(N+NOLD-J-2,2)
IF(K(N+NOLD-J-2,3).GT.NOLD) THEN
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2
ELSE
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)
ENDIF
K(N+NOLD-J,4)=0
K(N+NOLD-J,5)=0
P(N+NOLD-J,1)=P(N+NOLD-J-2,1)
P(N+NOLD-J,2)=P(N+NOLD-J-2,2)
P(N+NOLD-J,3)=P(N+NOLD-J-2,3)
P(N+NOLD-J,4)=P(N+NOLD-J-2,4)
P(N+NOLD-J,5)=P(N+NOLD-J-2,5)
K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2
K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2
47 CONTINUE
ENDIF
NOLD=NOLD+2
K(LMAX,1)=18
Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG')
IF(Z.GT.0.5)THEN
K(NOLD-1,2)=1
K(NOLD,2)=-1
ELSE
Z=1.-Z
K(NOLD-1,2)=-1
K(NOLD,2)=1
ENDIF
K(NOLD-1,1)=1
K(NOLD-1,3)=LMAX
K(NOLD-1,4)=0
K(NOLD-1,5)=0
P(NOLD-1,1)=(1.-Z)*P(LMAX,1)
P(NOLD-1,2)=(1.-Z)*P(LMAX,2)
P(NOLD-1,3)=(1.-Z)*P(LMAX,3)
P(NOLD-1,4)=(1.-Z)*P(LMAX,4)
P(NOLD-1,5)=P(LMAX,5)
K(NOLD,1)=1
K(NOLD,3)=LMAX
K(NOLD,4)=0
K(NOLD,5)=0
P(NOLD,1)=Z*P(LMAX,1)
P(NOLD,2)=Z*P(LMAX,2)
P(NOLD,3)=Z*P(LMAX,3)
P(NOLD,4)=Z*P(LMAX,4)
P(NOLD,5)=P(LMAX,5)
K(LMAX,1)=18
K(LMAX,4)=NOLD-1
K(LMAX,5)=NOLD
LMAX=NOLD
ENDIF
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LMAX,2)
K(N,3)=LMAX
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMAX,1)
P(N,2)=P(LMAX,2)
P(N,3)=P(LMAX,3)
P(N,4)=P(LMAX,4)
P(N,5)=P(LMAX,5)
K(LMAX,1)=16
K(LMAX,4)=N
K(LMAX,5)=N
LEND=LMAX
C--find closest partner
42 MMIN=1.d10
LMIN=0
DO 41 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1)
& .EQ.4).OR.(K(I,1).EQ.5))
& .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND.
& (K(I,3).NE.K(LEND,3))))
& .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN
MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2)
& -P(I,3)*P(LMAX,3)
IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN
MMIN=MINV
LMIN=I
ENDIF
ENDIF
41 CONTINUE
C--if no closest partner can be found, generate artificial end point for string
IF(LMIN.EQ.0)THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=1
K(N,2)=-K(LEND,2)
K(N,3)=0
K(N,4)=0
K(N,5)=0
P(N,1)=0.d0
P(N,2)=0.d0
IF(PYR(0).LT.0.5)THEN
DIR=1.d0
ELSE
DIR=-1.d0
ENDIF
P(N,3)=DIR*EADDEND
P(N,4)=EADDEND
P(N,5)=0.d0
GOTO 43
ELSE
C--else build closest partner in string
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(LMIN,2)
K(N,3)=LMIN
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMIN,1)
P(N,2)=P(LMIN,2)
P(N,3)=P(LMIN,3)
P(N,4)=P(LMIN,4)
P(N,5)=P(LMIN,5)
K(LMIN,1)=16
K(LMIN,4)=N
K(LMIN,5)=N
IF(K(LMIN,2).EQ.21)THEN
K(N,1)=2
LMAX=LMIN
GOTO 42
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
50 CONTINUE
CALL CLEANUP(NOLD)
END
***********************************************************************
*** subroutine cleanup
***********************************************************************
SUBROUTINE CLEANUP(NFIRST)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
INTEGER NFIRST,NLAST,I,J
NLAST=N
DO 21 I=1,NLAST-NFIRST
DO 22 J=1,5
K(I,J)=K(NFIRST+I,J)
P(I,J)=P(NFIRST+I,J)
V(I,J)=V(NFIRST+I,J)
22 CONTINUE
K(I,3)=0
21 CONTINUE
N=NLAST-NFIRST
END
***********************************************************************
*** subroutine makecascade
***********************************************************************
SUBROUTINE MAKECASCADE
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I
LOGICAL CONT
10 NOLD=N
CONT=.FALSE.
DO 11 I=2,NOLD
if (i.gt.n) goto 10
C--check if parton may evolve, i.e. do splitting or scattering
IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN
CONT=.TRUE.
CALL MAKEBRANCH(I)
IF(DISCARD) GOTO 12
ENDIF
11 CONTINUE
IF(CONT) GOTO 10
12 END
***********************************************************************
*** subroutine makebranch
***********************************************************************
SUBROUTINE MAKEBRANCH(L)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
& scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--local variables
INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold
integer oldstcode
DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT,
&TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR
LOGICAL OVERQ0,QQBARDEC
CHARACTER TYP
LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent
LINE=L
NSTART=0
NEND=0
STARTTIME=MV(LINE,4)
TSUM=0.d0
QSUM2=0.d0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
RETRYSPLIT=.FALSE.
MEDIND=.FALSE.
X=0.d0
Q=0.d0
TYPI=0
20 IF(DISCARD) RETURN
IF ((N.GT.20000).and.compress) roomleft = compressevent(line)
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN
IF(MEDIND)THEN
FORMTIME=starttime
ELSE
FORMTIME=MIN(MV(LINE,5),LTIME)
ENDIF
RADIATION=.TRUE.
ELSE
FORMTIME=LTIME
RADIATION=.FALSE.
ENDIF
TLEFT=FORMTIME-STARTTIME
IF(K(LINE,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
MEDIND=.FALSE.
IF(TLEFT.LE.1.d-10)THEN
C--no scattering
IF(RADIATION)THEN
C--if there is radiation associated with the parton then form it now
C--rotate such that momentum points in z-direction
NOLD=N
nscatcenold=nscatcen
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL MAKESPLITTING(LINE)
C--rotate back
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
IF(DISCARD) RETURN
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(LINE,1)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N-1,2)=MV(LINE,2)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N-1,3)=MV(LINE,3)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
MV(N, 1)=MV(LINE,1)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N, 2)=MV(LINE,2)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N, 3)=MV(LINE,3)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
LINE=N
NSTART=0
NEND=0
STARTTIME=MV(N,4)
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ELSE
NSTART=0
NEND=0
STARTTIME=FORMTIME
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ENDIF
ELSE
C--do scattering
C--find delta t for the scattering
DELTAT=TLEFT
OVERQ0=.FALSE.
CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,
& OVERQ0,.FALSE.)
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
C--do initial state splitting if there is one
NOLD=N
LINEOLD=LINE
oldstcode=k(line,1)
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
nscatcenold=nscatcen
25 IF(X.LT.1.d0) THEN
CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT)
IF(DISCARD) RETURN
IF(X.LT.1.d0)THEN
LINE=N
LKINE=N
IF(K(LINE,2).EQ.21)THEN
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ELSE
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ENDIF
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ELSE
LKINE=LINE
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
ENDIF
ENDIF
IF(X.EQ.1.d0)THEN
NEWMASS=0.d0
IF(NEND.GT.0)THEN
CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT,
& NEWMASS,OVERQ0,ZDEC,QQBARDEC)
IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN
MEDIND=.TRUE.
ELSE
MEDIND=.FALSE.
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ENDIF
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
LKINE=LINE
ENDIF
ENDIF
C--do kinematics
RETRYSPLIT=.FALSE.
IF(NEND.GT.0) THEN
nendold=nend
CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT,
& STARTTIME+TSUM,X,ZDEC,QQBARDEC)
IF(RETRYSPLIT) THEN
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
if (x.lt.1.d0) then
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
N=NOLD
LINE=LINEOLD
X=1.d0
K(LINE,1)=oldstcode
! K(LINE,1)=1
nscatcen=nscatcenold
NSPLIT=NSPLIT-EVWEIGHT
nspliti=nspliti-evweight
GOTO 25
else
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
endif
ELSE
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
ELSE
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
! IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE.
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))) RADIATION=.TRUE.
ENDIF
21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))
& .OR.(STARTTIME.LT.LTIME))THEN
GOTO 20
ENDIF
IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4
IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5
END
***********************************************************************
*** subroutine makesplitting
***********************************************************************
SUBROUTINE MAKESPLITTING(L)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,DIR
DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC,
&GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA,
&GETTEMP
LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4)
XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4)
XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4)
IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN
THETA=-1.d0
ELSE
THETA=THETAA(L)
ENDIF
C--on-shell partons cannot split
IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)
& .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3)
& .or.(zd(l).lt.0.d0)) GOTO 31
C--quark or gluon?
IF(K(L,2).EQ.21)THEN
QUARK=.FALSE.
ELSE
QUARK=.TRUE.
QQBAR=.FALSE.
ENDIF
C--if gluon decide on kind of splitting
QQBAR=QQBARD(L)
C--if g->gg splitting decide on colour order
IF(QUARK.OR.QQBAR)THEN
DIR=0
ELSE
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ENDIF
Z=ZD(L)
IF(Z.EQ.0.d0)THEN
write(logfid,*)'makesplitting: z=0',L,p(l,5)
goto 36
ENDIF
GOTO 35
C--generate z value
36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN
C--additional z constraint due to angular ordering
QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2)
IF(QH.GT.1)THEN
write(logfid,*)L,': reject event: angular ordering
& conflict in medium'
CALL PYLIST(2)
DISCARD=.TRUE.
GOTO 31
ENDIF
EPS=0.5-0.5*SQRT(1.-QH)
ELSE
EPS=0d0
ENDIF
IF(QUARK)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ')
ELSE
IF(QQBAR)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG')
ELSE
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG')
ENDIF
ENDIF
35 CONTINUE
C--maximum virtualities for daughters
BMAX1=MIN(P(L,5),Z*P(L,4))
CMAX1=MIN(P(L,5),(1.-Z)*P(L,4))
C--generate mass of quark or gluon (particle b) from Sudakov FF
30 IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
C--generate mass gluon (particle c) from Sudakov FF
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
C--quark (parton b) momentum
182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3))
PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2
C--if kinematics doesn't work out, generate new virtualities
C for daughters
C--massive phase space weight
IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0)
& .OR.((MB+MC).GT.P(L,5)))THEN
IF(MB.GT.MC)THEN
IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
ELSE
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
ENDIF
GOTO 182
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(QQBAR)THEN
K(N-1,2)=-1
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1-Z)*P(L,4)
P(N-1,5)=MC
ZA(N-1)=1.-Z
IF(ZDECC.GT.0.d0)THEN
THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4))
ELSE
THETAA(N-1)=0.d0
ENDIF
ZD(N-1)=ZDECC
QQBARD(N-1)=QQBARDECC
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(QUARK)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(QQBAR)THEN
K(N,2)=1
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
K(N,2)=21
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=Z*P(L,4)
P(N,5)=MB
ZA(N)=Z
IF(ZDECB.GT.0.d0)THEN
THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4))
ELSE
THETAA(N)=0.d0
ENDIF
ZD(N)=ZDECB
QQBARD(N)=QQBARDECB
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(PTS)*COS(PHIQ)
P(N,2)=SQRT(PTS)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N,5)=0.d0
ENDIF
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nsplitf=nsplitf+evweight
31 CONTINUE
END
***********************************************************************
*** subroutine makeinsplit
***********************************************************************
SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,TYPI,NOLD,DIR
DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
&PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC
LOGICAL QQBARDEC
CHARACTER*2 TYP2,TYPC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
IF(TYPI.EQ.21)THEN
TYP2='GG'
TYPC='GC'
ELSE
TYP2='QG'
TYPC='QQ'
ENDIF
ELSE
IF(TYPI.EQ.21)THEN
TYP2='GQ'
TYPC='QQ'
ELSE
TYP2='QQ'
TYPC='GC'
ENDIF
ENDIF
C--if g->gg decide on colour configuration
IF(TYP2.EQ.'GG')THEN
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
DIR=0
ENDIF
MB2=VIRT**2
MB2=P(L,5)**2-MB2
MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0,
& (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4),
& .FALSE.,ZDEC,QQBARDEC)**2
C--rotate such that momentum points in z-direction
NOLD=N
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
MC2=0.d0
IF(K(L,1).EQ.2) zdec = -1.d0
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
X=1.d0
RETURN
ENDIF
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(TYP2.EQ.'QG')THEN
K(N-1,2)=-TYPI
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ENDIF
ELSEIF(TYP2.EQ.'GQ')THEN
K(N-1,2)=K(L,2)
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=COLMAX+1
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1.-X)*P(L,4)
P(N-1,5)=SQRT(MC2)
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(TYP2.EQ.'QG')THEN
K(N,2)=TYPI
IF(K(N,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=ANTI(L)
ENDIF
ELSEIF(TYPI.NE.21)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSE
K(N,2)=21
IF(K(N-1,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(K(N-1,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ELSE
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=X*P(L,4)
IF(MB2.LT.0.d0)THEN
P(N,5)=-SQRT(-MB2)
ELSE
P(N,5)=SQRT(MB2)
ENDIF
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(KT2)*COS(PHIQ)
P(N,2)=SQRT(KT2)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(L,5)=TIME-TAURAD
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
MV(N,5)=TIME
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=ZDEC
QQBARD(N-1)=QQBARDEC
ZA(N)=1.d0
THETAA(N)=-1.d0
ZD(N)=0.d0
QQBARD(N)=.FALSE.
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nspliti=nspliti+evweight
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
END
***********************************************************************
*** subroutine doinstatescat
***********************************************************************
SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0,
& RETRYSPLIT)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT,
&WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT,
&XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS,
&GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD,
&GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT,
&pyp
LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT,
&QQBARDUM
CHARACTER TYP
CHARACTER*2 TYP2
DATA PI/3.141592653589793d0/
DATA COUNTMAX/10000/
COUNTER=0
XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4)
YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4)
ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4)
TSC=TSTART
MD1=GETMD(XSC,YSC,ZSC,TSC)
MS1=GETMS(XSC,YSC,ZSC,TSC)
IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN
write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC),
&GETNEFF(XSC,YSC,ZSC,TSC)
ENDIF
C--check for scattering
NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT)
IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116
C--decide whether there will be radiation
PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc)
IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN
NORAD=.TRUE.
ELSE
NORAD=.FALSE.
ENDIF
C--decide whether q or g is to be scattered
IF(K(L,2).EQ.21)THEN
TYP='G'
TYP2='GC'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','Q',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'G','C',xsc,ysc,zsc,tsc,0)
ELSE
TYP='Q'
TYP2='QQ'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','G',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'Q','C',xsc,ysc,zsc,tsc,0)
ENDIF
IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN
write(logfid,*)'error: flavour change probability=',
& PFCHANGE,'for ',TYP
ENDIF
IF(PYR(0).LT.PFCHANGE)THEN
FCHANGE=.TRUE.
ELSE
FCHANGE=.FALSE.
ENDIF
IF (NORAD) FCHANGE=.FALSE.
C--set TYPI
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
TYPI=INT(SIGN(2.d0,PYR(0)-0.5))
ELSE
TYPI=K(L,2)
ENDIF
ELSE
IF(FCHANGE)THEN
TYPI=21
ELSE
TYPI=K(L,2)
ENDIF
ENDIF
LOW=Q0**2/SCALEFACM**2
TMAX=4.*(P(L,4)**2-P(L,5)**2)
XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX)
IF(SIGMATOT.EQ.0.d0) GOTO 116
RTAU=PYR(0)
C--generate a trial emission
C--pick a x value from splitting function
112 COUNTER=COUNTER+1
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG')
ENDIF
ELSE
IF(FCHANGE)THEN
X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ENDIF
ENDIF
IF(NORAD) X=1.d0
C--initialisation
TMAXNEW=(X*P(L,4))**2
PHI=0.d0
TLEFT=DELTAT
TNOW=TSTART
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=-1.d-10
OVERQ0=.FALSE.
Q=P(L,5)
QOLD=P(L,5)
TAUEST=DELTAT
C--generate first momentum transfer
DELTAL=DT
NSTART=1
NEND=1
TNOW=TNOW+DELTAL
TSUM=DELTAL
TLEFT=TLEFT-DELTAL
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 118
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE.
C--get new virtuality
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
C--estimate formation time
111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN
TAUEST=DELTAT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
C--find number, position and momentum transfers of further scatterings
NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL)
IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN
C--add a momentum transfer
NEND=NEND+1
IF(NEND.GE.100)THEN
nend=nend-1
goto 114
ENDIF
TNOW=TNOW+DELTAL
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
C--update phase
IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4))
ENDIF
C--get new momentum transfer
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
COUNT2=0
119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 119
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF((-QSUM2.GT.LOW)
& .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE.
C--get new virtuality
QOLD=Q
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
GOTO 111
ENDIF
C--do reweighting
114 TMAXNEW=X**2*P(L,4)**2
IF(NORAD)THEN
WEIGHT=1.d0
Q=0.d0
X=1.d0
ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN
WEIGHT=0.d0
ELSEIF(-QSUM2.GT.P(L,4)**2)THEN
WEIGHT=0.d0
ELSE
IF(TYP.EQ.'G')THEN
FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg',
& FMAX
ENDIF
ENDIF
ENDIF
ELSE
FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq',
& FMAX
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))
& write(logfid,*)'error: weight=',WEIGHT
115 IF(PYR(0).GT.WEIGHT)THEN
IF(COUNTER.LT.COUNTMAX)THEN
GOTO 112
ELSE
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
RETURN
ENDIF
ENDIF
C--found meaningful configuration, now do final checks
C--check if phase is unity and weight with 1/Nscat
IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0)))
& .AND.(.NOT.NORAD))THEN
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
ELSE
IF(.NOT.NORAD)THEN
TLEFT=TLEFT-TAUEST
TNOW=TNOW+TAUEST
TSUM=TSUM+TAUEST
ENDIF
DELTAT=TSUM
ENDIF
RETURN
C--exit in case of failure
116 Q=0.d0
X=1.d0
NSTART=0
NEND=0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
OVERQ0=.FALSE.
TYPI=K(L,2)
RETURN
END
***********************************************************************
*** subroutine dofistatescat
***********************************************************************
SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS,
& OVERQ0,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--local variables
INTEGER L,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD,
&GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI,
&TAUEST,LOW,Z,pyp
LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR
CHARACTER TYP
DATA COUNTMAX/100/
DELTAL=0.d0
IF(-QSUM2.GT.P(L,4)**2)
& write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2
IF(K(L,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
LOW=Q0**2/SCALEFACM**2
TSUM=0.d0
PHI=0.d0
DELTAT=0.d0
C--check for radiation with first (given) momentum transfer
Q2OLD=0.d0
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ELSE
NEWMASS=P(L,5)
ENDIF
RTAU=PYR(0)
TLEFT=DTLEFT
222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN
TAUEST=TLEFT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL)
IF(.NOT.NOSCAT)THEN
C--do scattering
NEND=NEND+1
IF(NEND.gt.countmax)THEN
nend=nend-1
goto 218
ENDIF
IF(NSTART.EQ.0) NSTART=1
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4))
ENDIF
ALLQS(NEND,6)=TNOW+TSUM
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 219
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--figure out new virtuality
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ENDIF
GOTO 222
ENDIF
C--no more scattering
218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then
if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then
if (nend.eq.countmax) then
deltat=tsum
else if (TLEFT.LT.TAUEST) then
DELTAT=TSUM+tleft
else
DELTAT=TSUM+tauest
endif
NEWMASS=P(L,5)
ELSE
DELTAT=TSUM+TAUEST
ENDIF
else
DELTAT=0.d0
NSTART=1
NEND=1
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
NEWMASS=P(L,5)
endif
return
END
***********************************************************************
*** function getnewmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X,
& ZDEC,QQBARDEC)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L
DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
&GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD
LOGICAL IN,QQBARDEC,QQBAROLD
CHARACTER*2 TYP
IF(x*P(L,4).LT.Q0)THEN
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
IF (-Q2.LT.Q0**2)THEN
GETNEWMASS=0.d0
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
TYP='GC'
ELSE
TYP='QQ'
ENDIF
IF(SQRT(-QOLD2).LE.Q0)THEN
IF(IN)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
ELSE
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
ENDIF
GETNEWMASS=MIN(GETNEWMASS,X*P(L,4))
RETURN
ENDIF
Z=1.d0
QA=1.d0
IF(MAX(P(L,5),MASS).GT.0.d0)THEN
IF(-Q2.GT.-QOLD2)THEN
ZOLD=ZDEC
QQBAROLD=QQBARDEC
QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF(QTMP.LT.SQRT(-QOLD2))THEN
GETNEWMASS=MASS
ZDEC=ZOLD
QQBARDEC=QQBAROLD
ELSE
GETNEWMASS=QTMP
ENDIF
ELSE
PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
IF(PYR(0).LT.PKEEP)THEN
IF(P(L,5).LT.SQRT(-Q2))THEN
GETNEWMASS=MASS
ELSE
55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55
ENDIF
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
ELSE
IF(-Q2.GT.-QOLD2)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
if(getnewmass.lt.SQRT(-QOLD2))then
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
endif
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
GETNEWMASS=MIN(GETNEWMASS,x*P(L,4))
END
***********************************************************************
*** function getpnorad1
***********************************************************************
DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER LINE
DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT,
&SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd
md1 = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
ms1 = avmom(5)
shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4)
& -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3))
pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2
up = 4.*pcms2
LOW=Q0**2/SCALEFACM**2
IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN
GETPNORAD1=1.d0
RETURN
ENDIF
IF(K(LINE,2).EQ.21)THEN
CCOL=3./2.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'G','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=-1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'GB'))/SIGMATOT
ELSE
CCOL=2./3.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'Q','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'QB'))/SIGMATOT
ENDIF
IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN
write(logfid,*)'error: P_norad=',GETPNORAD1,
& P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1
ENDIF
END
***********************************************************************
*** subroutine getqvec
***********************************************************************
SUBROUTINE GETQVEC(L,J,DT,X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i
DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4),
&T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS,
&savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2,
&avmom(5)
CHARACTER TYPS
DATA PI/3.141592653589793d0/
DATA COUNTMAX/1000/
IF (J.GT.10000)THEN
discard = .true.
return
ENDIF
COUNTER=0
COUNT2=0
XSC=MV(L,1)+DT*P(L,1)/P(L,4)
YSC=MV(L,2)+DT*P(L,2)/P(L,4)
ZSC=MV(L,3)+DT*P(L,3)/P(L,4)
TSC=MV(L,4)+DT
md = GETMD(XSC,YSC,ZSC,TSC)
call AVSCATCEN(xsc,ysc,zsc,tsc,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
do 210 i=1,5
savemom(i) = p(l,i)
210 continue
xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8)
p(l,1) = xi*p(l,1)
p(l,2) = xi*p(l,2)
p(l,3) = xi*p(l,3)
p(l,4) = max(x*p(l,4),p(l,5))
444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
&K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5))
MV(1,1)=XSC
MV(1,2)=YSC
MV(1,3)=ZSC
MV(1,4)=TSC
TYPS='Q'
IF(K(1,2).EQ.21)TYPS='G'
shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4)
& -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3))
pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat)
& -savemom(5)**2
maxt = 4.*pcms2
K(1,1)=13
SCATCENTRES(J,1)=K(1,2)
SCATCENTRES(J,2)=P(1,1)
SCATCENTRES(J,3)=P(1,2)
SCATCENTRES(J,4)=P(1,3)
SCATCENTRES(J,5)=P(1,4)
SCATCENTRES(J,6)=P(1,5)
SCATCENTRES(J,7)=MV(1,1)
SCATCENTRES(J,8)=MV(1,2)
SCATCENTRES(J,9)=MV(1,3)
SCATCENTRES(J,10)=MV(1,4)
C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
C--pick a t from differential scattering cross section
204 T=-GETT(0.d0,MAXT,md)
202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5))
NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3))
PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
IF(DABS(PT2).LT.1.d-10) PT2=0.d0
IF(T.EQ.0.d0) PT2=0.d0
IF(PT2.LT.0.d0)THEN
T=0.d0
GOTO 202
ENDIF
PT=SQRT(PT2)
PHI2=PYR(0)*2*PI
NEWMOM(1)=PT*COS(PHI2)
NEWMOM(2)=PT*SIN(PHI2)
P(1,1)=NEWMOM(1)-P(L,1)
P(1,2)=NEWMOM(2)-P(L,2)
P(1,3)=NEWMOM(3)-P(L,3)
P(1,4)=NEWMOM(4)-P(L,4)
P(1,5)=0.d0
C--transformation to lab
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
ALLQS(J,1)=T
ALLQS(J,2)=P(1,1)
ALLQS(J,3)=P(1,2)
ALLQS(J,4)=P(1,3)
ALLQS(J,5)=P(1,4)
QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(QSUM2.GT.0.d0)THEN
QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(COUNTER.GT.COUNTMAX)THEN
write(logfid,*)'GETQVEC unable to find q vector'
ALLQS(J,1)=0.d0
ALLQS(J,2)=0.d0
ALLQS(J,3)=0.d0
ALLQS(J,4)=0.d0
ALLQS(J,5)=0.d0
ELSE
COUNTER=COUNTER+1
GOTO 444
ENDIF
ENDIF
do 211 i=1,5
p(l,i) = savemom(i)
211 continue
END
***********************************************************************
*** subroutine dokinematics
***********************************************************************
SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT,
& TIME,X,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold
DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T,
&NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp,
&m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old,
&newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2,
&ys,p3boost,pboost,m42,localt,oldt,precoil,qmass2,pdummy,pproj
double precision m4,z4,getmass,getms,getmd
double precision thetasub,phisub,rapsub
CHARACTER*2 TYP
LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle,
&softrec,splitrec,isrecoil
DATA PI/3.141592653589793d0/
data pdummy/1.d-6/
if (newm.ne.p(l,5)) then
if (p(l,5).lt.0.d0) then
nistry = nistry+evweight
else
nfstry = nfstry+evweight
endif
endif
IF((N+2*(n2-n1+1)).GT.22990)THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
if (k(l,1).eq.2) then
isrecoil = .true.
else
isrecoil = .false.
endif
firsttime = mv(l,5)
redokin = .false.
nttot=nttot+(n2-n1+1)*evweight
newm2=newm
nold=n
nscatcenold=nscatcen
colmaxold=colmax
statold=k(l,1)
204 DELTAM=NEWM2-P(L,5)
DMLEFT=DELTAM
TTOT=0.d0
DO 220 J=N1,N2
TTOT=TTOT+ALLQS(J,1)
220 CONTINUE
LINE=L
DO 222 J=N1,N2
splitrec = .false.
C--projectile type
IF(K(LINE,2).EQ.21)THEN
TYP='GC'
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
TYP='QQ'
DIR=0
ENDIF
K(1,1)=6
K(1,2)=SCATCENTRES(J,1)
P(1,1)=SCATCENTRES(J,2)
P(1,2)=SCATCENTRES(J,3)
P(1,3)=SCATCENTRES(J,4)
P(1,4)=SCATCENTRES(J,5)
P(1,5)=SCATCENTRES(J,6)
MV(1,1)=SCATCENTRES(J,7)
MV(1,2)=SCATCENTRES(J,8)
MV(1,3)=SCATCENTRES(J,9)
MV(1,4)=SCATCENTRES(J,10)
T=ALLQS(J,1)
if (t.eq.0.d0) then
rejectt = .true.
else
rejectt = .false.
endif
IF(TTOT.EQ.0.d0)THEN
DM=0.d0
ELSE
if (dmleft.lt.0.d0) then
DM=max(DMLEFT*T/TTOT*1.5d0,dmleft)
else
DM=min(DMLEFT*T/TTOT*1.5d0,dmleft)
endif
ENDIF
TTOT=TTOT-ALLQS(J,1)
C--transform to c.m.s. and rotate such that parton momentum is in z-direction
BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4))
BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4))
BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4))
IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0)
& .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN
reshuffle = .false.
else
reshuffle = .true.
endif
! reshuffle = .false.
205 if (.not.reshuffle) then
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
if (kinmode.eq.0)then
m42 = 0.d0
elseif (kinmode.eq.1)then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
maxt = -2.*p(1,5)*p(line,4) - p(1,5)**2 + m42
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
dm = 0.d0
m42 = p(1,5)**2
endif
m12 = -p(line,5)**2
203 newmass = p(line,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) then
enew = p(line,4)
else
enew = p(line,4)+(t+p(1,5)**2-m42)/(2.*p(1,5))
endif
pl = (t+2.*p(line,4)*enew-m12-m32)/(2.*p(line,3))
pt2 = enew**2-pl**2-m32
if (t.eq.0.d0) pt2 = 0.d0
if (dabs(pt2).lt.1.d-8) pt2 = 0.d0
if (pt2.lt.0.d0) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 203
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 203
else
write(logfid,*)' This should not have happened: pt^2<0!'
write(logfid,*)t,enew,pl,pt2
t = 0.d0
m42 = p(1,5)**2
rejectt = .true.
goto 203
endif
endif
pt = sqrt(pt2)
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=pt*cos(phi2)
p(n,2)=pt*sin(phi2)
p(n,3)=pl
p(n,4)=enew
p(n,5)=sign(sqrt(abs(m32)),newmass)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-sqrt(m42)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass (no rs): ',
& p(n-1,5),p(1,5),p(l,5),sqrt(m42),rejectt
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
else
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
reshuffle = .false.
goto 205
endif
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
shat = (p(1,4)+p(line,4))**2
p3old = p(line,3)
maxt = -4.*p(line,3)**2
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
ntrej=ntrej+evweight
endif
theta2 = acos(1.d0+t/(2.*p(line,3)**2))
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=p(line,3)*sin(theta2)*cos(phi2)
p(n,2)=p(line,3)*sin(theta2)*sin(phi2)
p(n,3)=p(line,3)*cos(theta2)
p(n,4)=p(line,4)
p(n,5)=p(line,5)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass: ',
& p(n-1,5),p(1,5),p(l,5)
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
C--outgoing projectile
K(N,1)=K(LINE,1)
if (isrecoil.and.(newm.gt.p(l,5)).and.(p(n,5).gt.q0)
& .and.(j.eq.n2)) then
k(n,1)=1
endif
K(N,2)=K(LINE,2)
! K(N,3)=L
K(N,3)=LINE
K(N,4)=0
K(N,5)=0
ZA(N)=1.d0
THETAA(N)=-1.d0
if ((k(n,1).eq.2).and.(z.eq.0.d0)) then
zd(n) = -1.d0
else
ZD(N)=Z
endif
QQBARD(N)=QQBAR
C--take care of incoming projectile
IF(K(LINE,1).EQ.1)THEN
K(LINE,1)=12
ELSE
write(*,*)line,k(line,1)
K(LINE,1)=14
call pevrec(2,.false.)
call exit(1)
ENDIF
K(LINE,4)=N-1
K(LINE,5)=N
C--temporary status code, will be overwritten later
K(N-1,1)=3
K(N-1,2)=21
K(N-1,3)=0
K(N-1,4)=0
K(N-1,5)=0
if (reshuffle) then
C--adjust mass and re-shuffle momenta
if (kinmode.eq.0) then
m42 = 0.d0
elseif (kinmode.eq.1) then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
206 newmass = p(n,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
E3new = (shat + m32 - m42)/(2.d0*sqrt(shat))
E4new = (shat - m32 + m42)/(2.d0*sqrt(shat))
p32 = E3new**2 - m32
p42 = E4new**2 - m42
if ((p32.lt.0.d0).or.(p42.lt.0.d0).or.
& (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (m42.eq.0.d0) then
p42 = 1.d-4
else
p42 = 0.d0
endif
E4new = sqrt(p42 + m42)
E3new = sqrt(shat) - E4new
p32 = E4new**2 - m42
m32 = E3new**2 - E4new**2 + m42
if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 206
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 206
endif
m42 = p(1,5)**2
E3new = p(n,4)
E4new = p(n-1,4)
p32 = p3old**2
p42 = p3old**2
if (p(n,5).lt.0.d0) then
m32 = -p(n,5)**2
else
m32 = p(n,5)**2
endif
endif
endif
p(n,1) = sqrt(p32)*p(n,1)/p3old
p(n,2) = sqrt(p32)*p(n,2)/p3old
p(n,3) = sqrt(p32)*p(n,3)/p3old
p(n,4) = E3new
p(n,5) = sign(sqrt(abs(m32)),newmass)
tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2-m32
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up projectiles mass (rs):',
& tmp,m32,p(n,5),dm,m42,p32
!---------------------------------
p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old
p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old
p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old
p(n-1,4) = E4new
p(n-1,5) = sqrt(m42)
tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
& -p(n-1,5)**2
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up scattering centres mass (rs):',
& tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or.
& (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or.
& (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) then
write(logfid,*) 'Oups, momentum not conserved (rs)',
& p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3)
write(logfid,*) m42,dm,E3new,E4new
endif
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
! write(*,*)((p(n-1,4)-p(1,4))**2-(p(n-1,1)-p(1,1))**2
! & -(p(n-1,2)-p(1,2))**2-(p(n-1,3)-p(1,3))**2)/t
C--transformation to lab
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
if (.not.allhad) then
k(n-1,1)=13
softrec=.false.
else
C--boost to fluid rest frame
ys = 0.5*log((mv(1,4)+mv(1,3))/(mv(1,4)-mv(1,3)))
p3boost = sinh(-ys)*p(n-1,4) + cosh(-ys)*p(n-1,3)
pboost = sqrt(p3boost**2+p(n-1,1)**2+p(n-1,2)**2)
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
if (pboost.lt.(recsoftcut*3.*localt)) then
softrec = .true.
k(n-1,1)=13
else
softrec = .false.
if (scatrecoil.and.(pboost.GT.(rechardcut*3.*localt))) THEN
K(N-1,1)=2
else
K(N-1,1)=3
ENDIF
endif
endif
if (rejectt) k(n-1,1)=11
C--outgoing projectile
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF(K(N,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=COLMAX+1
ANTI(N)=ANTI(LINE)
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=COLMAX+1
ENDIF
ELSEIF(K(N,2).GT.0)THEN
TRIP(N)=COLMAX+1
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=ANTI(LINE)
ENDIF
C--outgoing scattering centre
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(LINE)
ANTI(N-1)=TRIP(N)
ELSE
TRIP(N-1)=ANTI(N)
ANTI(N-1)=ANTI(LINE)
ENDIF
ELSE
TRIP(N-1)=0
ANTI(N-1)=0
ENDIF
C--outgoing scattering centre
if (splitrec) then
if (k(n-1,1).eq.2) k(n-1,1)=1
ZA(N-1)=1.d0
THETAA(N-1)=P(n-1,5)/(SQRT(Z4*(1.-Z4))*P(n-1,4))
ZD(N-1)=z4
QQBARD(N-1)=qqbardec
else
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=-1.d0
QQBARD(N-1)=.false.
endif
MV(N,4)=MV(1,4)
MV(N-1,4)=MV(1,4)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(line,1)
& +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N-1,2)=MV(line,2)
& +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N-1,3)=MV(line,3)
& +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
MV(N, 1)=MV(line,1)
& +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N, 2)=MV(line,2)
& +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N, 3)=MV(line,3)
& +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
IF(P(N-1,5).GT.P(1,5))THEN
LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2)
MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
IF(J.LT.N2)THEN
MV(N,5)=SCATCENTRES(J+1,10)
ELSE
IF(P(N,5).GT.0.d0)THEN
IF(DELTAM.EQ.0.d0)THEN
ENDTIME=firsttime
ELSE
IF(X.LT.1.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
ENDTIME=TIME
ENDIF
ENDIF
MV(N,5)=ENDTIME
ELSE
MV(N,5)=0.d0
ENDIF
ENDIF
MV(LINE,5)=ALLQS(J,6)
if ((.not.redokin).and.(.not.rejectt)) NSCAT=NSCAT+EVWEIGHT
C--store scattering centre before interaction in separate common block
if (writescatcen.and.(.not.rejectt).and.
& (nscatcen.lt.maxnscatcen)) then
nscatcen = nscatcen+1
if (nscatcen.gt.maxnscatcen) then
write(logfid,*)
&'WARNING: no room left to store further scattering centres'
goto 230
endif
if (recmode.eq.0) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.1) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
! precoil = sqrt(p(n-1,1)**2+p(n-1,2)**2+p(n-1,3)**2)
! dummies(nscatcen,1) = pdummy*p(n-1,1)/precoil
! dummies(nscatcen,2) = pdummy*p(n-1,2)/precoil
! dummies(nscatcen,3) = pdummy*p(n-1,3)/precoil
! dummies(nscatcen,4) = pdummy
C--------------------
c phisub = pyp(n-1,15)
c rapsub = pyp(n-1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = p(n-1,1)*pdummy/p(n-1,4)
dummies(nscatcen,2) = p(n-1,2)*pdummy/p(n-1,4)
dummies(nscatcen,3) = p(n-1,3)*pdummy/p(n-1,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.2) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil = sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
elseif (recmode.eq.3) then
if (softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil=sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
else
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
endif
endif
230 continue
! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then
! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5)
! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5)
! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5)
! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
! write(*,*)t
! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
! write(*,*)
! endif
DMLEFT=DMLEFT-(p(n,5)-P(LINE,5))
LINE=N
tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2
if (abs(tmp).ge.1.d-6)
& write(logfid,*)'dokinematics 4-momentum test failed:',
& tmp,j,p(l,5),p(line,5),p(n,5),reshuffle
222 CONTINUE
if (p(n,5).lt.0.d0) then
nisfail = nisfail+evweight
RETRYSPLIT=.TRUE.
return
endif
if (p(n,5).ne.newm2) then
RETRYSPLIT=.TRUE.
redokin = .true.
nfsfail = nfsfail+evweight
n=nold
colmax=colmaxold
nscatcen=nscatcenold
k(l,1)=statold
if (p(l,5).lt.0.d0) then
newm2 = 0.d0
else
if ((p(l,5).lt.q0).and.(k(l,1).ne.14)) then
if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then
newm2=q0+1.d-6
else
newm2=0.d0
! nisfail = nisfail+evweight
! RETRYSPLIT=.TRUE.
! write(*,*)'dokinematics takes the dubious exit'
! return
endif
else
newm2=p(l,5)
if (k(l,1).eq.14) z = 0.d0
endif
n2=n1
endif
goto 204
endif
if ((k(n,1).eq.1).and.
& ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))))
&write(logfid,*)'dokinematics did not reach sensible mass: ',l,
&p(n,5),newm,p(l,5),newm2
NSCATEFF=NSCATEFF+EVWEIGHT
END
***********************************************************************
*** function getproba
***********************************************************************
DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE,
& T1,INS2)
IMPLICIT NONE
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1
CHARACTER*2 TYPE
LOGICAL INS2
QA=QAA
ZA2=ZAA
EB=EBB
TYP=TYPE
T=T1
INSTATE=INS2
GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2)
& *DERIV(QF,1)
END
***********************************************************************
*** function getsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
& TYPE3,T2,INS)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI,
&HFIRST,T2,GETINSUDAFAST,QB2
CHARACTER*2 TYPE3
LOGICAL INS
DATA EPSI/1.d-4/
QB2=QB1
IF(INS)THEN
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ELSE
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ENDIF
IF(QB2.GE.(QMAX1-1.d-10)) THEN
GETSUDAKOV=1.d0
ELSE
IF(INS)THEN
GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3)
ELSE
QA=QA1
ZA2=ZA1
EB=EB1
TYP=TYPE3
T=T2
INSTATE=.FALSE.
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1)
GETSUDAKOV=EXP(-YSTART)
ENDIF
ENDIF
END
***********************************************************************
*** function getinsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI,
&HFIRST
CHARACTER*2 TYPE3
DATA EPSI/1.d-4/
QB1=QB
IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1
IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12
IF(QB1.GE.(QMAX1-1.d-12)) THEN
GETINSUDAKOV=1.d0
ELSE
TYP=TYPE3
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6)
GETINSUDAKOV=EXP(-YSTART)
ENDIF
END
***********************************************************************
*** function deriv
***********************************************************************
DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
INTEGER W4
DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI,
&GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ,
&MEDDERIV
DATA PI/3.141592653589793d0/
IF(W4.EQ.1)THEN
C--Sudakov integration
IF(INSTATE)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSE
DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL
ENDIF
ELSEIF(W4.EQ.2)THEN
C--P(q->qg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)*
& PQQ(XVAL)/(2.*PI)
ELSEIF(W4.EQ.3)THEN
C--P(g->gg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)
& *PGG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.4)THEN
C--P(g->qq) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)*
& PQG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.5)THEN
DERIV=EXP(-XVAL)/XVAL
ELSEIF(W4.EQ.6)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSEIF(W4.EQ.7)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.8)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PGQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.9)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.10)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)*
& *2.*PGG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.11)THEN
DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ')
& *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL)
ELSEIF(W4.EQ.12)THEN
DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG')
& *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL)
ELSEIF(W4.EQ.13)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC')
& *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.14)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ')
& *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.21)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ')
& /XVAL
ELSEIF(W4.EQ.22)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ')
& /XVAL
ELSEIF(W4.EQ.23)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG')
& /XVAL
ELSEIF(W4.EQ.24)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2.
& *GETINSPLITI(XVAL,'GG')/XVAL
ELSE
DERIV=MEDDERIV(XVAL,W4-100)
ENDIF
END
***********************************************************************
*** function getspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE
DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y,
&SPLITINTGG,SPLITINTQG,A,B,YB(2)
CHARACTER*2 TYPE1
ntotspliti=ntotspliti+1
if (qb.gt.qmax) then
noverspliti=noverspliti+1
if (noverspliti.le.25)
& write(logfid,*)'WARNING in getspliti: need to extrapolate: ',
& qb,qmax
endif
C--find boundaries for z integration
IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)))
ELSE
LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2)
ENDIF
C--find values in array
QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1)
QLINE=MAX(QLMAX,1)
QLINE=MIN(QLINE,NPOINT)
ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/
& (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1)
ZLINE=MAX(ZLMAX,1)
ZLINE=MIN(ZLINE,NPOINT)
IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR.
& (QLINE.LT.1).OR.(ZLINE.LT.1))THEN
write(logfid,*)'ERROR in GETSPLITI: line number out of bound',
& QLINE,ZLINE
ENDIF
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 17 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 16 J=1,2
YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
16 CONTINUE
17 CONTINUE
DO 30 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
30 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=MIN(Y,10.d0)
ELSE
SPLITINTGG=MIN(Y,10.d0)
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
DO 19 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 18 J=1,2
YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
18 CONTINUE
19 CONTINUE
DO 31 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
31 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=NF*MIN(Y,10.d0)
ELSE
SPLITINTQG=NF*MIN(Y,10.d0)
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
DO 21 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 20 J=1,2
YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
20 CONTINUE
21 CONTINUE
DO 32 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
32 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getinspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
UP = 1. - Q0**2/(4.*QB**2)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - LOG(LOG((1.-UP)*QB**2/LPS**2))
& + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + LOW - LOG(LOW) - UP + LOG(UP) )
& *3.*12.*PI/(2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'GG')THEN
GETINSPLITI=Y
ELSE
SPLITINTGG=Y
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 )
& *12.*PI/(2.*2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'QG')THEN
GETINSPLITI=NF*Y
ELSE
SPLITINTQG=NF*Y
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
& + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GQ')THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW))
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getpdf
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN
write(logfid,*)'error in GETPDF: parameter out of bound',X,Q
GETPDF=0.d0
RETURN
ENDIF
IF(TYP.EQ.'QQ')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GQ')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'QG')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GG')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10)
ENDIF
GETPDF=YSTART
ELSE
write(logfid,*)'error: pdf-type ',TYP,' does not exist'
GETPDF=0.d0
ENDIF
END
***********************************************************************
*** function getpdfxint
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER J,Q2CLOSE,Q2LINE
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP
ntotpdf=ntotpdf+1
if (q**2.gt.QINQX(1,1000)) then
noverpdf=noverpdf+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ',
& q**2,QINQX(1,1000)
endif
Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/
& (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1)
Q2LINE=MAX(Q2CLOSE,1)
Q2LINE=MIN(Q2LINE,999)
IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN
write(logfid,*)'ERROR in GETPDFXINT: line number out of bound',
& Q2LINE
ENDIF
IF(TYP.EQ.'QQ')THEN
DO 11 J=1,2
XA(J)=QINQX(1,Q2LINE-1+J)
YA(J)=QINQX(2,Q2LINE-1+J)
11 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
DO 13 J=1,2
XA(J)=GINQX(1,Q2LINE-1+J)
YA(J)=GINQX(2,Q2LINE-1+J)
13 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
DO 15 J=1,2
XA(J)=QINGX(1,Q2LINE-1+J)
YA(J)=QINGX(2,Q2LINE-1+J)
15 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
DO 17 J=1,2
XA(J)=GINGX(1,Q2LINE-1+J)
YA(J)=GINGX(2,Q2LINE-1+J)
17 CONTINUE
ELSE
write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q**2+B
GETPDFXINT=Y
END
***********************************************************************
*** subroutine getpdfxintexact
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION Q,EPSI,YSTART,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
HFIRST=0.01d0
YSTART=0.d0
XMAX=Q
Z=0.d0
IF(TYP.EQ.'QQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21)
ELSEIF(TYP.EQ.'QG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23)
ELSEIF(TYP.EQ.'GQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22)
ELSEIF(TYP.EQ.'GG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24)
ENDIF
GETPDFXINTEXACT=YSTART
END
***********************************************************************
*** function getxsecint
***********************************************************************
DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J
DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B
CHARACTER*2 TYP2
ntotxsec=ntotxsec+1
if (tm.gt.intq1(1000,101)) then
noverxsec=noverxsec+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getxsecint: need to extrapolate: ',
& tm,intq1(1000,101)
endif
TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/
& (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1)
TLINE=MAX(TCLOSE,1)
TLINE=MIN(TLINE,999)
MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/
&(INTQ1(1001,100)-INTQ1(1001,1))+1)
MDLINE=MAX(MDCLOSE,1)
MDLINE=MIN(MDLINE,99)
IF((TLINE.GT.999).OR.(MDLINE.GT.99)
& .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN
write(logfid,*)'ERROR in GETXSECINT: line number out of bound',
& TLINE,MDLINE
ENDIF
IF(TYP2.EQ.'QA')THEN
C--first quark integral
DO 12 I=1,2
X1A(I)=INTQ1(1001,MDLINE-1+I)
X2A(I)=INTQ1(TLINE-1+I,101)
DO 11 J=1,2
YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP2.EQ.'QB')THEN
C--second quark integral
DO 18 I=1,2
X1A(I)=INTQ2(1001,MDLINE-1+I)
X2A(I)=INTQ2(TLINE-1+I,101)
DO 17 J=1,2
YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I)
17 CONTINUE
18 CONTINUE
ELSEIF(TYP2.EQ.'GA')THEN
C--first gluon integral
DO 14 I=1,2
X1A(I)=INTG1(1001,MDLINE-1+I)
X2A(I)=INTG1(TLINE-1+I,101)
DO 13 J=1,2
YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP2.EQ.'GB')THEN
C--second gluon integral
DO 16 I=1,2
X1A(I)=INTG2(1001,MDLINE-1+I)
X2A(I)=INTG2(TLINE-1+I,101)
DO 15 J=1,2
YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I)
15 CONTINUE
16 CONTINUE
ELSE
write(logfid,*)'error in GETXSECINT: unknown integral type ',
& TYP2
ENDIF
DO 19 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*TM+B
19 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=YB(1)
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*MD+B
ENDIF
GETXSECINT=Y
END
***********************************************************************
*** function getinsudafast
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Q1,Q2,GETINSUDARED
CHARACTER*2 TYP
IF(Q2.LE.Q1)THEN
GETINSUDAFAST=1.d0
ELSEIF(Q1.LE.Q0)THEN
GETINSUDAFAST=GETINSUDARED(Q2,TYP)
ELSE
GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP)
ENDIF
IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0
IF(GETINSUDAFAST.LT.(-1.d-10))THEN
write(logfid,*)'ERROR: GETINSUDAFAST < 0:',
& GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP
ENDIF
if (getinsudafast.lt.0.d0) getinsudafast = 0.d0
END
***********************************************************************
*** function getinsudared
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER QCLOSE,QBIN,I
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP2
ntotsuda=ntotsuda+1
if (q.gt.sudaqq(1000,1)) then
noversuda=noversuda+1
if (noversuda.le.25)
& write(logfid,*)'WARNING in getinsudared: need to extrapolate: ',
& q,sudaqq(1000,1)
endif
QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0
& /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1)
QBIN=MAX(QCLOSE,1)
QBIN=MIN(QBIN,999)
IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN
write(logfid,*)
& 'ERROR in GETINSUDARED: line number out of bound',QBIN
ENDIF
IF(TYP2.EQ.'QQ')THEN
DO 16 I=1,2
XA(I)=SUDAQQ(QBIN-1+I,1)
YA(I)=SUDAQQ(QBIN-1+I,2)
16 CONTINUE
ELSEIF(TYP2.EQ.'QG')THEN
DO 17 I=1,2
XA(I)=SUDAQG(QBIN-1+I,1)
YA(I)=SUDAQG(QBIN-1+I,2)
17 CONTINUE
ELSEIF(TYP2.EQ.'GG')THEN
DO 18 I=1,2
XA(I)=SUDAGG(QBIN-1+I,1)
YA(I)=SUDAGG(QBIN-1+I,2)
18 CONTINUE
ELSEIF(TYP2.EQ.'GC')THEN
DO 19 I=1,2
XA(I)=SUDAGC(QBIN-1+I,1)
YA(I)=SUDAGC(QBIN-1+I,2)
19 CONTINUE
ELSE
write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q+B
GETINSUDARED=Y
IF(GETINSUDARED.LT.(-1.d-10))THEN
write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2
ENDIF
if (getinsudared.lt.0.d0) getinsudared = 0.d0
END
***********************************************************************
*** function getsscat
***********************************************************************
DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2,
& x,y,z,t,mode)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
integer mode
DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP,
&LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp,
&x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct
CHARACTER TYPE1,TYPE2
IF(TYPE1.EQ.'Q')THEN
CCOL=2./3.
ELSE
CCOL=3./2.
ENDIF
if (mode.eq.0) then
mdeb = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
& avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 + mp**2 +
& 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
else
if (mode.eq.1) then
mdeb = getmdmin()
else
mdeb = getmdmax()
endif
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)
pproj = sqrt(px**2+py**2+pz**2)
shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
endif
LOW=LW**2
IF(LOW.GT.UP)THEN
GETSSCAT=0.d0
RETURN
ENDIF
IF((TYPE2.EQ.'C').OR.
& ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR.
& ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN
GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB))
! write(*,*)'getsscat 1',GETSSCAT
ELSE
GETSSCAT=0.d0
ENDIF
LOW=Q0**2/SCALEFACM**2
IF(UP.GT.LOW)THEN
IF(TYPE1.EQ.'Q')THEN
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ')
& *3.*SCATPRIMFUNC(UP,MDEB)/2.
GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA')
ENDIF
ELSE
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
& SCATPRIMFUNC(LOW,MDEB))
& - GETXSECINT(UP,MDEB,'GB')
! write(*,*)'getsscat 2',GETSSCAT,CCOL*(SCATPRIMFUNC(UP,MDEB)-
! & SCATPRIMFUNC(LOW,MDEB)),-GETXSECINT(UP,MDEB,'GB')
ENDIF
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG')
& *2.*SCATPRIMFUNC(UP,MDEB)/3.
GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA')
! write(*,*)'getsscat 3',getsscat,-2.*GETXSECINT(UP,MDEB,'GA')
ENDIF
ENDIF
ENDIF
IF(GETSSCAT.LT.-1.d-4) then
write(logfid,*) 'error: cross section < 0',GETSSCAT,'for',
& EN,mp,LW,TYPE1,TYPE2,LW**2,UP,mode
endif
GETSSCAT=MAX(GETSSCAT,0.d0)
END
***********************************************************************
*** function getmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE,
& MAX2,INS,ZDEC,QQBARDEC)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--local variables
DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec,
&q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin,
&gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti,
&r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin
CHARACTER*2 TYPE
LOGICAL INS,QQBARDEC
DATA PI/3.141592653589793d0/
q2min = q0**2
alphmax = alphas(3.*ptfac*q2min/16.,lps)
log14 = log(0.25)
IF(TYPE.EQ.'QQ')THEN
pref=4.*alphmax/(3.*2.*PI)
ELSE
pref=29.*alphmax/(8.*2.*PI)
ENDIF
C--check if phase space available, return 0.d0 otherwise
IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
q2max = qbmax**2
! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2))
! IF(pyr(0).LE.sudaover)THEN
21 if (q2max-qbmin**2.lt.1e-4)then
getmass=qbmin
zdec=0.5
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
endif
return
endif
gmax = pref*log(q2min/(4.*q2max))**2
if (qbmin.gt.0.d0) then
rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax)
else
rmin = 0.d0
endif
r=pyr(0)*(1.d0-rmin)+rmin
arg=gmax+log(r)
if(arg.lt.0.d0)then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
! r=pyr(0)
! gmin = pref*log14**2
! gmax = pref*log(q2min/(4.*q2max))**2
! arg = log(r*exp(gmax)+(1.-r)*exp(gmin))
cand = q2min*exp(sqrt(arg/pref))/4.
eps = q2min/(4.*cand)
if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN
q2max=cand
goto 21
ENDIF
if (ins) then
trueval=getinspliti(sqrt(cand),type)
oest = -2.*pref*log(eps)
weight = trueval/oest
else
C--find true z interval
TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand)
& *SQRT(1.-cand/EP**2)
IF(TRUEEPS.LT.EPS)
& WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS
RZ=PYR(0)
z = 1.-eps**rz
if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then
weight = 0.
else
if (type.eq.'QQ')then
! if (ins) then
! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! endif
oest = 2.*pref/(1.-z)
weight = trueval/oest
else
if (pyr(0).lt.(17./29.)) z = 1.-z
! if (ins)then
! trueval = alphas(ptfac*(1.-z)*cand,lps)
! & *(pgg(z)+pqg(z))/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)
& *(pgg(z)+pqg(z))/(2.*pi)
! endif
oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi)
weight = trueval/oest
endif
thetanew = sqrt(cand/(z*(1.-z)))/ep
if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta))
& weight = 0.d0
endif
endif
IF (WEIGHT.GT.1.d0) WRITE(logfid,*)
& 'problem in getmass: weight> 1',
& WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND
R2=PYR(0)
IF(R2.GT.WEIGHT)THEN
q2max=cand
GOTO 21
ELSE
getmass=sqrt(cand)
if (.not.ins) then
ZDEC=Z
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
ENDIF
endif
ENDIF
END
***********************************************************************
*** function generatez
***********************************************************************
DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
CHARACTER*2 TYPE
IF(TI.EQ.0.d0)THEN
EPS=EPSI
ELSE
EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
& *SQRT(1.-TI/EA**2),EPSI)
ENDIF
IF(EPS.GT.0.5)THEN
GENERATEZ=0.5
GOTO 61
ENDIF
60 R=PYR(0)
IF(TYPE.EQ.'QQ')THEN
X=1.-(1.-EPS)*(EPS/(1.-EPS))**R
R=PYR(0)
IF(R.LT.((1.+X**2)/2.))THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSEIF(TYPE.EQ.'GG')THEN
X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R))
R=PYR(0)
HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X)
IF(R.LT.HELP)THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSE
R=PYR(0)*(1.-2.*EPS)+EPS
R1=PYR(0)/2.
HELP=0.5*(R**2+(1.-R)**2)
IF(R1.LT.HELP)THEN
GENERATEZ=R
ELSE
GOTO 60
ENDIF
ENDIF
61 END
***********************************************************************
*** function scatprimfunc
***********************************************************************
DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
DATA PI/3.141592653589793d0/
SCATPRIMFUNC = 2.*PI*(12.*PI)**2*(
& - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2
& - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2
END
***********************************************************************
*** function intpqq
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2)
& +LOG(1.-Z)))/((33.-2.*NF)*3.)
END
***********************************************************************
*** function intpgglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpgghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpqglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function intpqghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function gett
***********************************************************************
DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
&MDEB,MINT,T
DATA PI/3.141592653589793d0/
TMAX=MAXT+MDEB**2
TMIN=MINT+MDEB**2
IF(TMIN.GT.TMAX) THEN
GETT=0.d0
RETURN
ENDIF
20 R1=PYR(0)
T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX))
R2=PYR(0)
IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN
GETT=T-MDEB**2
ELSE
GOTO 20
ENDIF
! 20 R1 = pyr(0);
! R2 = pyr(0);
! t = abs(mdeb**2*sqrt(-2.*log(R1))*cos(2.*pi*R2))
! if (t.gt.maxt) goto 20
! gett=t
! return
END
***********************************************************************
*** function ei
***********************************************************************
DOUBLE PRECISION FUNCTION EI(X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--local variables
INTEGER K,LINE,LMAX
DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B
DOUBLE PRECISION YSTART,EPSI,HFIRST
DATA EPSI/1.e-5/
IF(DABS(X).GT.VALMAX)
& write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX
IF(X.GE.0.d0)THEN
LMAX=INT(X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 26 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(3,LINE-1+K)
26 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*X+B
ELSE
LMAX=INT(-X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 27 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(2,LINE-1+K)
27 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=-A*X+B
ENDIF
EI=Y
END
***********************************************************************
*** function pqq
***********************************************************************
DOUBLE PRECISION FUNCTION PQQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
END
***********************************************************************
*** function pgq
***********************************************************************
DOUBLE PRECISION FUNCTION PGQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
END
***********************************************************************
*** function pgg
***********************************************************************
DOUBLE PRECISION FUNCTION PGG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
END
***********************************************************************
*** function pqg
***********************************************************************
DOUBLE PRECISION FUNCTION PQG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQG=0.5*(Z**2 + (1.-Z)**2)
END
***********************************************************************
*** function alphas
***********************************************************************
DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,L0,PI,LAMBDA
DATA PI/3.141592653589793d0/
ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
END
***********************************************************************
*** subroutine splitfncint
***********************************************************************
SUBROUTINE SPLITFNCINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER NSTEP,I,J
DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
&LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2
DATA ZMMAX/0.5/
DATA NSTEP/999/
DATA EPSI/1.d-5/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
ZMMIN=Q0/EMAX
LNZMMIN=LOG(ZMMIN)
LNZMMAX=LOG(ZMMAX)
NPOINT=NSTEP
DO 100 I=1,NSTEP+1
Q=(I-1)*(QMAX-Q0)/NSTEP+Q0
QVAL(I)=Q
QQUAD=Q**2
DO 110 J=1,NSTEP+1
ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
ZMVAL(J)=ZM
IF(Q**2.LT.Q0**2)THEN
ZM2=0.5
ELSE
ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2)
ENDIF
ZM=MAX(ZM,ZM2)
IF(ZM.EQ.0.5)THEN
SPLITIQQV(I,J)=0.d0
SPLITIGGV(I,J)=0.d0
SPLITIQGV(I,J)=0.d0
ELSE
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2)
SPLITIQQV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3)
SPLITIGGV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4)
SPLITIQGV(I,J)=YSTART
ENDIF
110 CONTINUE
100 CONTINUE
END
***********************************************************************
*** subroutine pdfint
***********************************************************************
SUBROUTINE PDFINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I,J
DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI,
&Q2MAX,DELTAQ2,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
q2max = scalefacm*4.*pcms2
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
QINQX(1,1)=Q0**2
GINQX(1,1)=Q0**2
QINGX(1,1)=Q0**2
GINGX(1,1)=Q0**2
QINQX(2,1)=0.d0
GINQX(2,1)=0.d0
QINGX(2,1)=0.d0
GINGX(2,1)=0.d0
DO 12 J=2,1000
Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2))
QINQX(1,J)=Q2
GINQX(1,J)=Q2
QINGX(1,J)=Q2
GINGX(1,J)=Q2
QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ')
GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ')
QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG')
GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG')
12 CONTINUE
END
***********************************************************************
*** subroutine xsecint
***********************************************************************
SUBROUTINE XSECINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER J,K
DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI,
&GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
tmaxmax = scalefacm*4.*pcms2
DELTATMAX=(LOG(TMAXMAX)-
& LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0
MDMIN=GETMDMIN()
MDMAX=MAX(MDMIN,GETMDMAX())
DELTAMD=(MDMAX-MDMIN)/99.d0
DO 12 J=1,1000
TMAX = EXP((J-1)*DELTATMAX
& + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))
INTQ1(J,101)=TMAX
INTQ2(J,101)=TMAX
INTG1(J,101)=TMAX
INTG2(J,101)=TMAX
DO 13 K=1,100
MDX=MDMIN+(K-1)*DELTAMD
INTQ1(1001,K)=MDX
INTQ2(1001,K)=MDX
INTG1(1001,K)=MDX
INTG2(1001,K)=MDX
IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN
INTQ1(J,K)=0.d0
INTQ2(J,K)=0.d0
INTG1(J,K)=0.d0
INTG2(J,K)=0.d0
ELSE
C--first quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,11)
INTQ1(J,K)=YSTART
C--second quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,14)
INTQ2(J,K)=YSTART
C--first gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,12)
INTG1(J,K)=YSTART
C--second gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,13)
INTG2(J,K)=YSTART
ENDIF
13 CONTINUE
12 CONTINUE
END
***********************************************************************
*** function insudaint
***********************************************************************
SUBROUTINE INSUDAINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I
DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5),
&shat,pcms2
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0
DO 22 I=1,1000
Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6)))
SUDAQQ(I,1)=Q
SUDAQG(I,1)=Q
SUDAGG(I,1)=Q
SUDAGC(I,1)=Q
SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ')
SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG')
SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG')
SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC')
22 CONTINUE
END
***********************************************************************
*** function eixint
***********************************************************************
SUBROUTINE EIXINT
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C-local variables
INTEGER I,K
DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R
DATA EPSI/1.d-6/
NVAL=1000
VALMAX=55.
DO 10 I=1,NVAL
X=I*VALMAX/(NVAL*1.d0)
EIXS(1,I)=X
C--do negative arguments first
YSTART=0d0
HFIRST=0.01
CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5)
EIXS(2,I)=-YSTART
C--now do the positive arguments
IF (X.EQ.0.0) THEN
EI=-1.0D+300
ELSE IF (X.LE.40.0) THEN
EI=1.0D0
R=1.0D0
DO 15 K=1,100
R=R*K*X/(K+1.0D0)**2
EI=EI+R
IF (DABS(R/EI).LE.1.0D-15) GO TO 20
15 CONTINUE
20 GA=0.5772156649015328D0
EI=GA+DLOG(X)+X*EI
ELSE
EI=1.0D0
R=1.0D0
DO 25 K=1,20
R=R*K/X
EI=EI+R
25 continue
EI=DEXP(X)/X*EI
ENDIF
EIXS(3,I)=EI
10 CONTINUE
END
***********************************************************************
*** function odeint
***********************************************************************
subroutine odeint(ystart,a,b,eps,h1,hmin,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer nmax,nstep,w1
double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx,
&deriv,yscale,hdid,hnew
data nmax/100000/
x = a
y = ystart
h = sign(h1,b-a)
do 20 nstep=1,nmax
dydx = deriv(x,w1)
yscale = abs(y) + abs(h*dydx) + 1.e-25
if (((x + h - b)*h).gt.0.) h = b-x
call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1)
if ((x - b)*h.ge.0) then
ystart = y
return
endif
h = hnew
if (abs(h).lt.abs(hmin)) then
write(logfid,*)'Error in odeint: stepsize too small',w1
& ,ystart,a,b,h1
return
endif
20 continue
write(logfid,*)'Error in odeint: too many steps',w1
& ,ystart,a,b,h1
end
***********************************************************************
*** function rkstepper
***********************************************************************
subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer w1
double precision x,y,dydx,htest,hdid,hnew,yscale,eps,
&yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown,
&powerup,maxup,maxdown,deriv,fac
logical reject
data powerdown/0.25/
data powerup/0.2/
data safety/0.9/
data maxdown/10./
data maxup/5./
reject = .false.
h = htest
10 xnew = x + h
if (x.eq.xnew) then
write(logfid,*)'Error in rkstepper: step size not significant'
return
endif
yhalf = rk4step(x,y,dydx,h/2.,w1)
dydxhalf = deriv(x+h/2.,w1)
y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1)
y1 = rk4step(x,y,dydx,h,w1)
delta = y2-y1
err = abs(delta)/(yscale*eps)
if (err.gt.1.) then
reject = .true.
fac = max(1./maxdown,safety/err**powerdown)
h = h*fac
goto 10
else
if (reject) then
hnew = h
else
fac = min(maxup,safety/err**powerup)
hnew = fac*h
endif
x = xnew
y = y2 + delta/15.
hdid = h
endif
end
***********************************************************************
*** function rk4step
***********************************************************************
double precision function rk4step(x,y,dydx,h,w1)
implicit none
integer w1
double precision x,y,dydx,h,k1,k2,k4,yout,deriv
k1 = h*dydx
k2 = h*deriv(x+h/2.,w1)
k4 = h*deriv(x+h,w1)
yout = y+k1/6.+2.*k2/3.+k4/6.
rk4step = yout
end
***********************************************************************
*** function getdeltat
***********************************************************************
LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pythia common block
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--local variables
INTEGER LINE,I,NNULL
DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR,
&R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN,
&XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF,
&GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN,
&SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT
CHARACTER PTYPE
LOGICAL STOPNOW
C--initialization
GETDELTAT=.FALSE.
DELTAT=0.D0
DTMAX=DTMAX1
IF(K(LINE,2).EQ.21)THEN
PTYPE='G'
ELSE
PTYPE='Q'
ENDIF
NNULL=0
STOPNOW=.FALSE.
C--check for upper bound from plasma lifetime
IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART
IF(DTMAX.LT.0.D0) RETURN
C--calculate time relative to production of the considered parton
TOFF=TSTART-MV(LINE,4)
XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4)
YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4)
ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4)
C--calculate upper limit for density*cross section
SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1)
SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2)
NEFFMAX=GETNEFFMAX()
NEFFMIN=GETNATMDMIN()
LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN)
if(linvmax.eq.0.d0) return
DO 333 I=1,1000000
DELTAT=DELTAT-LOG(PYR(0))/LINVMAX
XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4)
YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4)
ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4)
TS=TSTART+DELTAT
IF(TS.LT.ZS)THEN
TAU=-1.d0
ELSE
TAU=SQRT(TS**2-ZS**2)
ENDIF
NEFF=GETNEFF(XS,YS,ZS,TS)
IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN
IF(NNULL.GT.4)THEN
STOPNOW=.TRUE.
ELSE
NNULL=NNULL+1
ENDIF
ELSE
NNULL=0
ENDIF
IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN
DELTAT=DTMAX
RETURN
ENDIF
IF(NEFF.GT.0.d0)THEN
SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0)
ELSE
SIGMA=0.d0
ENDIF
WEIGHT=5.d0*NEFF*SIGMA/LINVMAX
IF(WEIGHT.GT.1.d0+1d-6) then
if (line.ne.errl) then
write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT,
& NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX),
& p(line,4)
errl=line
endif
endif
R=PYR(0)
IF(R.LT.WEIGHT)THEN
GETDELTAT=.TRUE.
RETURN
ENDIF
333 CONTINUE
END
integer function poissonian(lambda)
implicit none
integer n
double precision lambda,disc,p,pyr,u,v,pi
data pi/3.141592653589793d0/
if (lambda.gt.745.d0) then
u = pyr(0);
v = pyr(0);
poissonian =
& int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda)
else
disc=exp(-lambda)
p=1.d0
n=0
800 p = p*pyr(0)
if (p.gt.disc) then
n = n+1
goto 800
endif
poissonian=n
endif
end
***********************************************************************
*** function ishadron
***********************************************************************
LOGICAL FUNCTION ISHADRON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.100) THEN
ISHADRON=.FALSE.
ELSE
IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN
ISHADRON = .FALSE.
ELSE
ISHADRON = .TRUE.
ENDIF
ENDIF
END
***********************************************************************
*** function isdiquark
***********************************************************************
LOGICAL FUNCTION ISDIQUARK(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.1000) THEN
ISDIQUARK=.FALSE.
ELSE
IF(MOD(INT(ID/10),10).EQ.0) THEN
ISDIQUARK = .TRUE.
ELSE
ISDIQUARK = .FALSE.
ENDIF
ENDIF
END
***********************************************************************
*** function islepton
***********************************************************************
LOGICAL FUNCTION ISLEPTON(ID)
IMPLICIT NONE
C-- local variables
INTEGER ID
IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN
ISLEPTON=.TRUE.
ELSE
ISLEPTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isparton
***********************************************************************
LOGICAL FUNCTION ISPARTON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
LOGICAL ISDIQUARK
IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN
ISPARTON=.TRUE.
ELSE
ISPARTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isprimstring
***********************************************************************
logical function isprimstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
isprimstring=.false.
return
endif
if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then
isprimstring=.true.
else
isprimstring=.false.
endif
end
***********************************************************************
*** function issecstring
***********************************************************************
logical function issecstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton,isprimstring
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
issecstring = .false.
return
endif
if (isprimstring(l)) then
issecstring = .false.
return
endif
if (isparton(K(K(K(l,3),3),2))) then
issecstring = .false.
else
issecstring = .true.
endif
end
***********************************************************************
*** function isprimhadron
***********************************************************************
logical function isprimhadron(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isprimstring,isparton
if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92))
& .and.isprimstring(K(l,3))
& .and.(.not.isparton(K(l,2)))) then
isprimhadron=.true.
else
isprimhadron=.false.
endif
if (k(l,1).eq.17) isprimhadron=.true.
end
***********************************************************************
*** function compressevent
***********************************************************************
logical function compressevent(l1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
integer l1,i,j,nold,nnew,nstart
nold = n
do 777 i=2,nold
if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)
& .or.(k(i,1).eq.14)).and.(i.ne.l1)) then
nnew = i
goto 778
endif
777 continue
compressevent = .false.
return
778 continue
nstart = nnew
do 779 i=nstart,nold
if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)
& .and.(k(i,1).ne.14)).or.(i.eq.l1)) then
do 780 j=1,5
p(nnew,j)=p(i,j)
v(nnew,j)=v(i,j)
mv(nnew,j)=mv(i,j)
780 continue
trip(nnew)=trip(i)
anti(nnew)=anti(i)
za(nnew)=za(i)
zd(nnew)=zd(i)
thetaa(nnew)=thetaa(i)
qqbard(nnew)=qqbard(i)
k(nnew,1)=k(i,1)
k(nnew,2)=k(i,2)
k(nnew,3)=0
k(nnew,4)=0
k(nnew,5)=0
if (l1.eq.i) l1=nnew
nnew=nnew+1
endif
779 continue
n=nnew-1
if ((nold-n).le.10) then
compressevent = .false.
else
compressevent = .true.
endif
do 781 i=nnew,nold
do 782 j=1,5
k(i,j)=0
p(i,j)=0.d0
v(i,j)=0.d0
mv(i,j)=0.d0
782 continue
trip(i)=0
anti(i)=0
za(i)=0.d0
zd(i)=0.d0
thetaa(i)=0.d0
qqbard(i)=.false.
781 continue
if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n
if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1
call flush(logfid)
return
end
***********************************************************************
*** subroutine pevrec
***********************************************************************
SUBROUTINE PEVREC(NUM,COL)
C--identifier of file for hepmc output and logfile
implicit none
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
INTEGER NUM,i
LOGICAL COL
DO 202 I=1,N
V(I,1)=MV(I,1)
V(I,2)=MV(I,2)
V(I,3)=MV(I,3)
V(I,4)=MV(I,4)
V(I,5)=MV(I,5)
! IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
! &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
! &ZD(I),THETAA(I)
IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
&K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } '
202 CONTINUE
CALL PYLIST(NUM)
END
***********************************************************************
*** subroutine converttohepmc
***********************************************************************
SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2)
IMPLICIT NONE
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART,
&NFIRST,NVERTEX,NTOT,J,CODEFIRST
integer intinpt(2),intinmass(2),intinphi(2),intineta
integer intz,inttheta
DOUBLE PRECISION mproton,centr,getcentrality,jprodr,phi,pi,
&pdummy,pscatcen,mneutron
LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring,
&issecstring
character*2 beam1,beam2
data mproton/0.9383/
data mneutron/0.9396/
DATA PI/3.141592653589793d0/
5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6)
5100 FORMAT(A2,2E14.6)
! 5200 FORMAT(A2,9I2,4E14.6)
! 5200 FORMAT(A2,2I7,7I2,4E14.6)
5200 FORMAT(A2,6I7,2I2,1I7,4E14.6)
5300 FORMAT(A2,2I2,5E14.6,2I2)
! 5400 FORMAT(A2,I6,6I2,I6,I2)
5400 FORMAT(A2,2I6,5I2,I6,I2)
5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2)
PBARCODE=0
VBARCODE=0
centr = getcentrality()
jprodr = sqrt(x0**2+y0**2)
if (abs(y0).lt.1.d-8) then
if (x0.gt.0.d0) then
phi = 0.d0
else
phi = pi
endif
else
if (x0.gt.0.d0) then
if (y0.gt.0.d0) then
phi = atan(y0/x0)
else
phi = (3.d0*pi/2.d0) - atan(x0/y0)
endif
else
if (y0.gt.0.d0) then
phi = (pi/2.d0) - atan(x0/y0)
else
phi = pi + atan(y0/x0)
endif
endif
endif
do 140 i=1,2
intinpt(i) = int(inpt(i)*100.)
intinmass(i) = int(inmass(i)*100.)
intinphi(i) = int(inphi(i)*100.)
140 continue
intineta = int(ineta(1)*100.)
intz = int(inz(1)*10000.)
inttheta = int(intheta(1)*100.)
if (shorthepmc) then
C--short output
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
PBARCODE=5
ELSE
NVERTEX=1
PBARCODE=2
ENDIF
nfirst = 0
do 131 i=1,N
if (((k(i,1).lt.6).or.(k(i,1).eq.17)))
& nfirst = nfirst+1
131 continue
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1,
&PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 133 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
133 continue
endif
C--write out dummy particles
if(writedummies) then
do 137 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
137 continue
endif
C--write out particle lines
do 132 i=1,N
if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then
pbarcode=pbarcode+1
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),4,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
endif
132 continue
else
C--long output
if (hadro) then
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 123 I=1,N
IF(K(i,3).ne.0)THEN
NSTART=I
GOTO 124
ENDIF
123 CONTINUE
124 CONTINUE
nstart=0
DO 126 I=NSTART+1,N
IF(isprimhadron(i)) NFIRST=NFIRST+1
IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15))
& .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1
126 CONTINUE
127 CONTINUE
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
CODEFIRST=NFIRST+PBARCODE
C--write out scattering centres
if(writescatcen) then
do 134 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
134 continue
endif
C--write out dummy particles
if(writedummies) then
do 138 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
138 continue
endif
C--first write out all particles coming directly from string or cluster decays
DO 125 I=NSTART+1,N
IF(.not.isprimhadron(i))THEN
GOTO 125
ELSE
IF (PBARCODE.EQ.CODEFIRST) GOTO 130
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
ENDIF
125 CONTINUE
130 CONTINUE
C--now write out all other particles and vertices
DO 129 I=NSTART+1,N
if (isprimhadron(i).or.isprimstring(i)) goto 129
if (isparton(K(i,2))) then
if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3))
goto 129
endif
if (issecstring(i)) then
codelist(i)=codelist(K(i,3))
goto 129
endif
PBARCODE=PBARCODE+1
IF((K(I,3).NE.K(I-1,3)))THEN
C--write out vertex line
WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
ENDIF
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
129 CONTINUE
else
C---------------------------------------------------------------------------------------
C--partonic events
! call pevrec(2,.false.)
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 150 I=9,N
IF((k(i,3).eq.1).or.(k(i,3).eq.2).or.
& (k(i,3).eq.7).or.(k(i,3).eq.8)) NFIRST=NFIRST+1
IF(K(I,4).NE.0) NVERTEX=NVERTEX+1
150 CONTINUE
nstart = 9+nfirst
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,centr,0.d0,0.d0,0.d0
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 151 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
151 continue
endif
C--write out dummy particles
if(writedummies) then
do 152 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
152 continue
endif
C--write out outgoing particles of first vertex
do 154 i=9,nstart-1
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
154 continue
C--now write out all other particles and vertices
DO 153 I=NSTART,N
PBARCODE=PBARCODE+1
if (k(i,3).eq.0) then
C--write out vertex line - scattering
WRITE(J,5400)'V ',CODELIST(K(I+1,3)),k(k(i+1,3),1),0,0,
& 0,0,0,K(K(I+1,3),5)-K(K(I+1,3),4)+1,0
elseif ((k(i,3).ne.k(i-1,3)).and.(k(i-1,3).ne.0)) then
C--write out vertex line - splitting
WRITE(J,5400)'V ',CODELIST(K(I,3)),k(k(i,3),1),0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
endif
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),4,0,0,0,0
elseif ((k(i,1).eq.11).and.(k(i,3).eq.0)) then
WRITE(J,5500)'P ',PBARCODE,0,0.d0,0.d0,0.d0,
& 0.d0,0.d0,0,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
ENDIF
153 CONTINUE
endif
endif
call flush(j)
END
subroutine combinegluons()
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
integer ncomb,i,j
double precision mom(4),mass2
logical compress,compressevent
data ncomb/5/
do 100 i=1,n
C-- find recoils (= gluons with finite mass)
if ((k(i,2).eq.21).and.(p(i,5).ne.0.d0).and.(k(i,1).eq.2)) then
mom(1) = p(i,1)
mom(2) = p(i,2)
mom(3) = p(i,3)
mom(4) = p(i,4)
do 101 j=1,ncomb-1
if ((k(i+j,2).eq.21).and.(p(i+j,5).ne.0.d0)
& .and.(k(i+j,1).eq.2)) then
mom(1) = mom(1) + p(i+j,1)
mom(2) = mom(2) + p(i+j,2)
mom(3) = mom(3) + p(i+j,3)
mom(4) = mom(4) + p(i+j,4)
k(i+j,1) = 11
else
goto 102
endif
101 continue
102 p(i,1) = mom(1)
p(i,2) = mom(2)
p(i,3) = mom(3)
p(i,4) = mom(4)
mass2 = mom(4)**2-mom(1)**2-mom(2)**2-mom(3)**2
if (mass2.lt.0.d0) then
write(logfid,*)mass2
else
p(i,5) = sqrt(mass2)
endif
endif
100 continue
C i=0
C compress = compressevent(i)
return
end
***********************************************************************
*** subroutine printlogo
***********************************************************************
subroutine printlogo(fid)
implicit none
integer fid
write(fid,*)
write(fid,*)' _______________'//
&'__________________________ '
write(fid,*)' | '//
&' | '
write(fid,*)' | JJJJJ EEEEE '//
&' W W EEEEE L | '
write(fid,*)' | J E '//
&' W W E L | '
write(fid,*)' _________________| J EEE '//
&' W W W EEE L |_________________ '
write(fid,*)'| | J J E '//
&' W W W W E L | |'
write(fid,*)'| | JJJ EEEEE '//
&' W W EEEEE LLLLL | |'
write(fid,*)'| |_______________'//
&'__________________________| |'
write(fid,*)'| '//
&' |'
write(fid,*)'| '//
&'this is JEWEL 2.3.0 |'
write(fid,*)'| '//
&' |'
- write(fid,*)'| Copyright Korinna C. Zapp (2021)'//
+ write(fid,*)'| Copyright Korinna C. Zapp (2022)'//
&' [Korinna.Zapp@thep.lu.se] |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The medium model was partly '//
&'implemented by Jochen Klein |'
write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '//
&'Kunnawalkam Elayavalli helped with the |'
write(fid,*)'| implementation of the V+jet processes '//
&'[raghav.k.e@cern.ch]. |'
write(fid,*)'| '//
&' |'
write(fid,*)'| Please cite JHEP 1303 (2013) '//
&'080 [arXiv:1212.1599] for physics and |'
write(fid,*)'| EPJC 74 (2014) no.2, 2762 [arXiv:1311.0048] '//
&' for the code. |'
write(fid,*)'| The reference for '//
&'V+jet processes is EPJC 76 (2016) no.12 695 |'
write(fid,*)'| [arXiv:1608.03099] and for recoil effects'//
&' it is JHEP 07 (2017) 141 |'
- write(fid,*)'| [arXiv:1707.01539]. '//
- &' |'
+ write(fid,*)'| [arXiv:1707.01539] and '//
+ &'arXiv:2207.?????. |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL relies heavily on PYTHIA 6'//
&' for the event generation. The modified |'
write(fid,*)'| version of PYTHIA 6.4.25 that is'//
&' shipped with JEWEL is, however, not an |'
write(fid,*)'| official PYTHIA release and must'//
&' not be used for anything else. Please |'
write(fid,*)'| refer to results as "JEWEL+PYTHIA".'//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL also uses code provided by'//
&'S. Zhang and J. M. Jing |'
write(fid,*)'| (Computation of Special Functions, '//
&'John Wiley & Sons, New York, 1996 and |'
write(fid,*)'| http://jin.ece.illinois.edu) for '//
&'computing the exponential integral Ei(x). |'
write(fid,*)'| '//
&' |'
write(fid,*)'|_________________________________'//
&'____________________________________________|'
write(fid,*)
write(fid,*)
end
***********************************************************************
*** subroutine printtime
***********************************************************************
subroutine printtime
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer*4 date(3),time(3)
1000 format (i2.2, '.', i2.2, '.', i4.4, ', ',
& i2.2, ':', i2.2, ':', i2.2 )
call idate(date)
call itime(time)
write(logfid,1000)date,time
end
Index: trunk/code/medium-simple.f
===================================================================
--- trunk/code/medium-simple.f (revision 504)
+++ trunk/code/medium-simple.f (revision 505)
@@ -1,777 +1,777 @@
SUBROUTINE MEDINIT(FILE,id,etam,mass)
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--longitudinal boost of momentum distribution
common/boostmed/boost
logical boost
C--factor to vary Debye mass
COMMON/MDFAC/MDFACTOR,MDSCALEFAC
DOUBLE PRECISION MDFACTOR,MDSCALEFAC
C--nuclear thickness function
COMMON /THICKFNC/ RMAX,TA(100,2)
DOUBLE PRECISION RMAX,TA
C--geometrical cross section
COMMON /CROSSSEC/ IMPMAX,CROSS(200,3)
DOUBLE PRECISION IMPMAX,CROSS
C--identifier of log file
common/logfile/logfid
integer logfid
DATA RAU/10./
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
C--local variables
INTEGER I,LUN,POS,IOS,id,mass
double precision etam
CHARACTER*100 BUFFER,LABEL,tempbuf
CHARACTER*80 FILE
character firstchar
logical fileexist
etamax2 = etam
logfid = id
IOS=0
LUN=77
C--default settings
TAUI=0.6d0
TI=0.485d0
TC=0.17d0
WOODSSAXON=.TRUE.
CENTRMIN=0.d0
CENTRMAX=10.d0
NF=3
A=mass
N0=0.17d0
D=0.54d0
SIGMANN=6.2
MDFACTOR=0.45d0
MDSCALEFAC=0.9d0
boost = .true.
C--read settings from file
write(logfid,*)
inquire(file=FILE,exist=fileexist)
if(fileexist)then
write(logfid,*)'Reading medium parameters from ',FILE
OPEN(unit=LUN,file=FILE,status='old',err=10)
do 20 i=1,1000
READ(LUN, '(A)', iostat=ios) BUFFER
if (ios.ne.0) goto 30
firstchar = buffer(1:1)
if (firstchar.eq.'#') goto 20
POS=SCAN(BUFFER,' ')
LABEL=BUFFER(1:POS)
BUFFER=BUFFER(POS+1:)
IF (LABEL=="TAUI")THEN
READ(BUFFER,*,IOSTAT=IOS) TAUI
ELSE IF (LABEL=="TI") THEN
READ(BUFFER,*,IOSTAT=IOS) TI
ELSE IF (LABEL=="TC") THEN
READ(BUFFER,*,IOSTAT=IOS) TC
ELSE IF (LABEL=="WOODSSAXON") THEN
READ(BUFFER,*,IOSTAT=IOS) WOODSSAXON
ELSE IF (LABEL=="CENTRMIN") THEN
READ(BUFFER,*,IOSTAT=IOS) CENTRMIN
ELSE IF (LABEL=="CENTRMAX") THEN
READ(BUFFER,*,IOSTAT=IOS) CENTRMAX
ELSE IF (LABEL=="NF") THEN
READ(BUFFER,*,IOSTAT=IOS) NF
ELSE IF (LABEL=="N0") THEN
READ(BUFFER,*,IOSTAT=IOS) N0
ELSE IF (LABEL=="D") THEN
READ(BUFFER,*,IOSTAT=IOS) D
ELSE IF (LABEL=="SIGMANN") THEN
READ(BUFFER,*,IOSTAT=IOS) SIGMANN
ELSE IF (LABEL=="MDFACTOR") THEN
READ(BUFFER,*,IOSTAT=IOS) MDFACTOR
ELSE IF (LABEL=="MDSCALEFAC") THEN
READ(BUFFER,*,IOSTAT=IOS) MDSCALEFAC
else
write(logfid,*)'unknown label ',label
endif
20 continue
30 close(LUN,status='keep')
write(logfid,*)'...done'
goto 40
10 write(logfid,*)'Could not open medium parameter file, '//
& 'will run with default settings.'
else
write(logfid,*)'No medium parameter file found, '//
& 'will run with default settings.'
endif
40 write(logfid,*)'using parameters:'
write(logfid,*)'TAUI =',TAUI
write(logfid,*)'TI =',TI
write(logfid,*)'TC =',TC
write(logfid,*)'WOODSSAXON =',WOODSSAXON
write(logfid,*)'CENTRMIN =',CENTRMIN
write(logfid,*)'CENTRMAX =',CENTRMAX
write(logfid,*)'NF =',NF
write(logfid,*)'A =',A
write(logfid,*)'N0 =',N0
write(logfid,*)'D =',D
write(logfid,*)'SIGMANN =',SIGMANN
write(logfid,*)'MDFACTOR =',MDFACTOR
write(logfid,*)'MDSCALEFAC =',MDSCALEFAC
write(logfid,*)
write(logfid,*)
write(logfid,*)
C--calculate T_A(x,y)
CALL CALCTA
C--calculate geometrical cross section
CALL CALCXSECTION
END
SUBROUTINE MEDNEXTEVT
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--geometrical cross section
COMMON /CROSSSEC/ IMPMAX,CROSS(200,3)
DOUBLE PRECISION IMPMAX,CROSS
C--local variables
integer i,j
DOUBLE PRECISION PYR,R,b1,b2,gettemp
C--pick an impact parameter
r=(pyr(0)*(centrmax-centrmin)+centrmin)/100.
i=0
do 130 j=1,200
if ((r-cross(j,3)/cross(200,3)).ge.0.) then
i=i+1
else
goto 132
endif
130 continue
132 continue
b1 = (i-1)*0.1d0
b2 = i*0.1d0
breal = (b2*(cross(i,3)/cross(200,3)-r)
& +b1*(r-cross(i+1,3)/cross(200,3)))/
& (cross(i,3)/cross(200,3)-cross(i+1,3)/cross(200,3))
centr = r;
END
double precision function getcentrality()
implicit none
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
getcentrality=centr
end
SUBROUTINE PICKVTX(X,Y)
IMPLICIT NONE
DOUBLE PRECISION X,Y
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
C--local variables
DOUBLE PRECISION X1,X2,Y1,Y2,Z,XVAL,YVAL,ZVAL,NTHICK,PYR
X1=BREAL/2.-RAU
X2=RAU-BREAL/2.
Y1=-SQRT(4*RAU**2-BREAL**2)/2.
Y2=SQRT(4*RAU**2-BREAL**2)/2.
C--small system
- x1=-1.
- x2=1.
- y1=-1.
- y2=1.
+! x1=-1.
+! x2=1.
+! y1=-1.
+! y2=1.
C--end small system
131 XVAL=PYR(0)*(X2-X1)+X1
YVAL=PYR(0)*(Y2-Y1)+Y1
IF((NTHICK(XVAL-BREAL/2.,YVAL).EQ.0.d0).OR.
& NTHICK(XVAL+BREAL/2.,YVAL).EQ.0.d0) GOTO 131
C--small system
- if (sqrt(xval**2+yval**2).gt.1.d0) goto 131
+! if (sqrt(xval**2+yval**2).gt.1.d0) goto 131
C--end small system
ZVAL=PYR(0)*NTHICK(-BREAL/2.,0d0)*NTHICK(BREAL/2.,0d0)
Z=NTHICK(XVAL-BREAL/2.,YVAL)*NTHICK(XVAL+BREAL/2.,YVAL)
IF(ZVAL.GT.Z) GOTO 131
X=XVAL
Y=YVAL
END
SUBROUTINE SETB(BVAL)
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
DOUBLE PRECISION BVAL
BREAL=BVAL
END
SUBROUTINE GETSCATTERER(X,Y,Z,T,TYPE,PX,PY,PZ,E,MS)
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
C--internal medium parameters
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--longitudinal boost of momentum distribution
common/boostmed/boost
logical boost
C--function calls
DOUBLE PRECISION GETTEMP,GETMD,GETMOM,GETMS
C--identifier of log file
common/logfile/logfid
integer logfid
C--local variables
DOUBLE PRECISION X,Y,Z,T,MS,PX,PY,PZ,E,MD,TEMP
INTEGER TYPE
DOUBLE PRECISION R,PYR,pmax,wt,tau,theta,phi,pi,p,ys,pz2,e2
DATA PI/3.141592653589793d0/
R=PYR(0)
IF(R.LT.(2.*12.*NF*D3/3.)/(2.*12.*NF*D3/3.+3.*16.*ZETA3/2.))THEN
TYPE=2
MS=GETMS(X,Y,Z,T)
ELSE
TYPE=21
MS=GETMD(X,Y,Z,T)
ENDIF
TEMP=GETTEMP(X,Y,Z,T)
tau=sqrt(t**2-z**2)
if (boost) then
ys = 0.5*log((t+z)/(t-z))
else
ys = 0.d0
endif
pmax = 10.*temp
IF(TEMP.LT.1.D-2)THEN
write(logfid,*)'asking for a scattering centre without medium:'
write(logfid,*)'at (x,y,z,t)=',X,Y,Z,T
write(logfid,*)'making one up to continue but '//
& 'something is wrong!'
TYPE=21
PX=0.d0
PY=0.d0
PZ=0.d0
MS=GETMS(0.d0,0.d0,0.d0,0.d0)
MD=GETMD(0.d0,0.d0,0.d0,0.d0)
E=SQRT(PX**2+PY**2+PZ**2+MS**2)
RETURN
ENDIF
10 p = pyr(0)**0.3333333*pmax
E2 = sqrt(p**2+ms**2)
if (type.eq.2) then
wt = (exp(ms/temp)-1.)/(exp(E2/temp)-1.)
else
wt = (exp(ms/temp)+1.)/(exp(E2/temp)+1.)
endif
if (wt.gt.1.) write(logfid,*)'Error in getscatterer: weight = ',wt
if (wt.lt.0.) write(logfid,*)'Error in getscatterer: weight = ',wt
if (pyr(0).gt.wt) goto 10
phi = pyr(0)*2.*pi
theta = -acos(2.*pyr(0)-1.)+pi
px = p*sin(theta)*cos(phi)
py = p*sin(theta)*sin(phi)
pz2 = p*cos(theta)
E = cosh(ys)*E2 + sinh(ys)*pz2
pz = sinh(ys)*E2 + cosh(ys)*pz2
END
SUBROUTINE AVSCATCEN(X,Y,Z,T,PX,PY,PZ,E,m)
IMPLICIT NONE
C--longitudinal boost of momentum distribution
common/boostmed/boost
logical boost
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--local variables
double precision x,y,z,t,px,py,pz,e,getms,m,ys
if (boost) then
ys = 0.5*log((t+z)/(t-z))
-! if ((z.eq.0.d0).and.(t.eq.0.d0)) ys =0.d0
- if (t.eq.0.d0) ys =0.d0
+ if ((z.eq.0.d0).and.(t.eq.0.d0)) ys =0.d0
+! if (t.eq.0.d0) ys =0.d0
if (ys.gt.etamax2) ys=etamax2
if (ys.lt.-etamax2) ys=-etamax2
else
ys = 0.d0
endif
m = getms(x,y,z,t)
e = m*cosh(ys)
px = 0.d0
py = 0.d0
pz = m*sinh(ys)
end
SUBROUTINE maxscatcen(PX,PY,PZ,E,m)
IMPLICIT NONE
C--longitudinal boost of momentum distribution
common/boostmed/boost
logical boost
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--local variables
double precision px,py,pz,e,getmsmax,m,ys
if (boost) then
ys = etamax2
else
ys = 0.d0
endif
m = getmsmax()
e = m*cosh(ys)
px = 0.d0
py = 0.d0
pz = m*sinh(ys)
end
DOUBLE PRECISION FUNCTION GETMD(X1,Y1,Z1,T1)
IMPLICIT NONE
C--factor to vary Debye mass
COMMON/MDFAC/MDFACTOR,MDSCALEFAC
DOUBLE PRECISION MDFACTOR,MDSCALEFAC
DOUBLE PRECISION X1,Y1,Z1,T1,GETTEMP
GETMD=MDSCALEFAC*3.*GETTEMP(X1,Y1,Z1,T1)
GETMD=MAX(GETMD,MDFACTOR)
END
DOUBLE PRECISION FUNCTION GETMS(X2,Y2,Z2,T2)
IMPLICIT NONE
DOUBLE PRECISION X2,Y2,Z2,T2,GETMD
GETMS=GETMD(X2,Y2,Z2,T2)/SQRT(2.)
END
DOUBLE PRECISION FUNCTION GETNEFF(X3,Y3,Z3,T3)
IMPLICIT NONE
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C-- local variables
DOUBLE PRECISION X3,Y3,Z3,T3,PI,GETTEMP,tau,cosheta
DATA PI/3.141592653589793d0/
tau = sqrt(t3**2-z3**2)
cosheta = t3/tau
GETNEFF=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.)
& *GETTEMP(X3,Y3,Z3,T3)**3/PI**2
getneff = getneff/cosheta
C--small system
- getneff = getneff/3.
+! getneff = getneff/3.
C--end small system
END
DOUBLE PRECISION FUNCTION GETTEMP(X4,Y4,Z4,T4)
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--local variables
DOUBLE PRECISION X4,Y4,Z4,T4,TAU,NPART,EPS0,EPSIN,TEMPIN,PI,
&NTHICK,ys
DATA PI/3.141592653589793d0/
GETTEMP=0.D0
C--small system
- if (sqrt(x4**2+y4**2).gt.1.) return
+! if (sqrt(x4**2+y4**2).gt.1.) return
C--end small system
IF(ABS(Z4).GT.T4)RETURN
TAU=SQRT(T4**2-Z4**2)
C--check for overlap region
IF((NTHICK(X4-BREAL/2.,Y4).EQ.0.d0).OR.
&NTHICK(X4+BREAL/2.,Y4).EQ.0.d0) RETURN
ys = 0.5*log((t4+z4)/(t4-z4))
if (abs(ys).gt.etamax2) return
C--determine initial temperature at transverse position
IF(WOODSSAXON)THEN
EPS0=(16.*8.+7.*2.*6.*NF)*PI**2*TI**4/240.
! EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4)
! & *PI*RAU**2/(2.*A)
EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4)/
& NPART(0.d0,0.d0,0.d0,0.d0)
TEMPIN=(EPSIN*240./(PI**2*(16.*8.+7.*2.*6.*NF)))**0.25
ELSE
TEMPIN=TI
ENDIF
C--calculate temperature if before initial time
IF(TAU.LE.TAUI)THEN
GETTEMP=TEMPIN*TAU/TAUI
ELSE
C--evolve temperature
GETTEMP=TEMPIN*(TAUI/TAU)**0.3333
ENDIF
IF(GETTEMP.LT.TC) GETTEMP=0.d0
END
DOUBLE PRECISION FUNCTION GETTEMPMAX()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--function call
DOUBLE PRECISION GETTEMP
GETTEMPMAX=GETTEMP(0.D0,0.D0,0.D0,TAUI)
END
DOUBLE PRECISION FUNCTION GETMDMAX()
IMPLICIT NONE
C--factor to vary Debye mass
COMMON/MDFAC/MDFACTOR,MDSCALEFAC
DOUBLE PRECISION MDFACTOR,MDSCALEFAC
DOUBLE PRECISION GETTEMPMAX
GETMDMAX=MDSCALEFAC*3.*GETTEMPMAX()
GETMDMAX=MAX(GETMDMAX,MDFACTOR)
END
DOUBLE PRECISION FUNCTION GETMDMIN()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--factor to vary Debye mass
COMMON/MDFAC/MDFACTOR,MDSCALEFAC
DOUBLE PRECISION MDFACTOR,MDSCALEFAC
DOUBLE PRECISION GETTEMPMAX
GETMDMIN=MDSCALEFAC*3.*TC
GETMDMIN=MAX(GETMDMIN,MDFACTOR)
END
DOUBLE PRECISION FUNCTION GETMSMAX()
IMPLICIT NONE
DOUBLE PRECISION GETMDMAX,SQRT
GETMSMAX=GETMDMAX()/SQRT(2.D0)
END
DOUBLE PRECISION FUNCTION GETNATMDMIN()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--factor to vary Debye mass
COMMON/MDFAC/MDFACTOR,MDSCALEFAC
DOUBLE PRECISION MDFACTOR,MDSCALEFAC,PI
DATA PI/3.141592653589793d0/
C--local variables
DOUBLE PRECISION T,GETMDMIN
T=GETMDMIN()/(MDSCALEFAC*3.)
GETNATMDMIN=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.)
& *T**3/PI**2
END
DOUBLE PRECISION FUNCTION GETLTIMEMAX()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C--function call
DOUBLE PRECISION GETTEMPMAX
GETLTIMEMAX=TAUI*(GETTEMPMAX()/TC)**3*cosh(etamax2)
END
DOUBLE PRECISION FUNCTION GETNEFFMAX()
IMPLICIT NONE
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--max rapidity
common/rapmax2/etamax2
double precision etamax2
C-- local variables
DOUBLE PRECISION PI,GETTEMPMAX
DATA PI/3.141592653589793d0/
GETNEFFMAX=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.)
& *GETTEMPMAX()**3/PI**2
END
DOUBLE PRECISION FUNCTION NPART(XX1,YY1,XX2,YY2)
IMPLICIT NONE
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--local variables
DOUBLE PRECISION XX1,YY1,XX2,YY2,NTHICK
NPART = NTHICK(XX1,YY1)*(1.-EXP(-SIGMANN*NTHICK(XX2,YY2))) +
& NTHICK(XX2,YY2)*(1.-EXP(-SIGMANN*NTHICK(XX1,YY1)))
END
DOUBLE PRECISION FUNCTION NTHICK(X1,Y1)
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--identifier of log file
common/logfile/logfid
integer logfid
C--nuclear thickness function
COMMON /THICKFNC/ RMAX,TA(100,2)
DOUBLE PRECISION RMAX,TA
INTEGER LINE,LMIN,LMAX,I
DOUBLE PRECISION X1,Y1,XA(4),YA(4),Y,DY,R,C,B,DELTA
R=SQRT(X1**2+Y1**2)
IF(R.GT.TA(100,1))THEN
NTHICK=0.
ELSE
LINE=INT(R*99.d0/TA(100,1)+1)
LMIN=MAX(LINE,1)
LMIN=MIN(LMIN,99)
IF((R.LT.TA(LMIN,1)).OR.(R.GT.TA(LMIN+1,1)))
& write(logfid,*)LINE,LMIN,R,TA(LMIN,1),TA(LMIN+1,1)
XA(1)=TA(LMIN,1)
XA(2)=TA(LMIN+1,1)
YA(1)=TA(LMIN,2)
YA(2)=TA(LMIN+1,2)
C=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-C*XA(1)
NTHICK=C*R+B
ENDIF
END
SUBROUTINE CALCTA()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C-- nuclear thickness function
COMMON /THICKFNC/ RMAX,TA(100,2)
DOUBLE PRECISION RMAX,TA
C--variables for integration
COMMON/INTEG/B,R
DOUBLE PRECISION B,R
C--local variables
INTEGER NSTEPS,I
DOUBLE PRECISION EPS,HFIRST,Y
NSTEPS=100
EPS=1.E-4
HFIRST=0.1D0
R=1.12*A**(0.33333)-0.86*A**(-0.33333)
RMAX=2.*R
DO 10 I=1,NSTEPS
C--set transverse position
B=(I-1)*2.D0*R/NSTEPS
Y=0.D0
C--integrate along longitudinal line
CALL ODEINT(Y,-2*R,2*R,EPS,HFIRST,0.d0,101)
TA(I,1)=B
TA(I,2)=Y
10 CONTINUE
END
SUBROUTINE CALCXSECTION()
IMPLICIT NONE
C--medium parameters
COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF
INTEGER NF
DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C-- geometrical cross section
COMMON /CROSSSEC/ IMPMAX,CROSS(200,3)
DOUBLE PRECISION IMPMAX,CROSS
C--local variables
INTEGER IX,IY,IB
DOUBLE PRECISION B,P,PROD,X,Y,NTHICK,NPART,pprev
pprev=0.
DO 30 IB=1,200
B=0.1d0*IB
PROD=1.d0
DO 10 IX=1,100
DO 20 IY=1,100
X=-20.d0+IX*0.4d0
Y=-20.d0+IY*0.4d0
PROD=PROD*
&EXP(-NTHICK(X+B/2.D0,Y)*SIGMANN)**(0.16d0*NTHICK(X-B/2.D0,Y))
20 CONTINUE
10 CONTINUE
P=(1.D0-PROD)*8.8D0/14.D0*B
CROSS(IB,1)=B
CROSS(IB,2)=P
if (ib.eq.1) then
cross(ib,3)=0.
else
cross(ib,3)=cross(ib-1,3)+(p+pprev)/2.*0.1
endif
pprev=p
30 CONTINUE
IMPMAX=19.95
END
DOUBLE PRECISION FUNCTION MEDDERIV(XVAL,W)
IMPLICIT NONE
DOUBLE PRECISION XVAL
INTEGER W
C--medium parameters
COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D,
&N0,SIGMANN,A,WOODSSAXON
DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0,
&SIGMANN
INTEGER A
LOGICAL WOODSSAXON
C--variables for integration
COMMON/INTEG/B,R
DOUBLE PRECISION B,R
IF (W.EQ.1) THEN
C--XVAL corresponds to z-coordinate
MEDDERIV=N0/(1+EXP((SQRT(B**2+XVAL**2)-R)/D))
ELSE
MEDDERIV=0.D0
ENDIF
END
Index: trunk/code/pythia6425mod-lhapdf6.f
===================================================================
--- trunk/code/pythia6425mod-lhapdf6.f (revision 504)
+++ trunk/code/pythia6425mod-lhapdf6.f (revision 505)
@@ -1,68450 +1,68450 @@
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C++ This version of PYTHIA 6.4.25 was modified to run with the ++
C++ jet quenching Monte Carlo JEWEL. It is not an official release ++
C++ of PYTHIA and may not be used for anything else. ++
C++ ++
C++ Modifications with respect to the official PYTHIA version: ++
C++ * The event record was enlarged to 23000 lines. ++
C++ * The LHAPDF interface was activated and modified such that ++
C++ nuclear PDF's can be used. ++
C++ * A customised version of PYEVWT was introduced to allow for ++
C++ the generation of weighted events. ++
C++ ++
C++ Korinna Zapp ++
C++ (Oct. 2013) ++
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*********************************************************************
C*********************************************************************
C* **
C* Mar 2011 **
C* **
C* The Lund Monte Carlo **
C* **
C* PYTHIA version 6.4 **
C* **
C* Torbjorn Sjostrand **
C* Department of Theoretical Physics **
C* Lund University **
C* Solvegatan 14A, S-223 62 Lund, Sweden **
C* E-mail torbjorn@thep.lu.se **
C* **
C* SUSY and Technicolor parts by **
C* Stephen Mrenna **
C* Computing Division **
C* Generators and Detector Simulation Group **
C* Fermi National Accelerator Laboratory **
C* MS 234, Batavia, IL 60510, USA **
C* phone + 1 - 630 - 840 - 2556 **
C* E-mail mrenna@fnal.gov **
C* **
C* New multiple interactions and more SUSY parts by **
C* Peter Skands **
C* CERN/PH, CH-1211 Geneva, Switzerland **
C* phone +41 - 22 - 767 2447 **
C* E-mail peter.skands@cern.ch **
C* **
C* Several parts are written by Hans-Uno Bengtsson **
C* PYSHOW is written together with Mats Bengtsson **
C* PYMAEL is written by Emanuel Norrbin **
C* advanced popcorn baryon production written by Patrik Eden **
C* code for virtual photons mainly written by Christer Friberg **
C* code for low-mass strings mainly written by Emanuel Norrbin **
C* Bose-Einstein code mainly written by Leif Lonnblad **
C* CTEQ parton distributions are by the CTEQ collaboration **
C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
C* SaS photon parton distributions together with Gerhard Schuler **
C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
C* MSSM Higgs mass calculation code by M. Carena, **
C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
C* PYGAUS adapted from CERN library (K.S. Kolbig) **
C* NRQCD/colour octet production of onium by S. Wolf **
C* **
C* The latest program version and documentation is found on WWW **
C* http://www.thep.lu.se/~torbjorn/Pythia.html **
C* **
C* Copyright Torbjorn Sjostrand, Lund 2010 **
C* **
C*********************************************************************
C*********************************************************************
C *
C List of subprograms in order of appearance, with main purpose *
C (S = subroutine, F = function, B = block data) *
C *
C B PYDATA to contain all default values *
C S PYCKBD to check that BLOCK DATA has been correctly loaded *
C S PYTEST to test the proper functioning of the package *
C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
C *
C S PYINIT to administer the initialization procedure *
C S PYEVNT to administer the generation of an event *
C S PYEVNW ditto, for new multiple interactions scenario *
C S PYSTAT to print cross-section and other information *
C S PYUPEV to administer the generation of an LHA hard process *
C S PYUPIN to provide initialization needed for LHA input *
C S PYLHEF to produce a Les Houches Event File from run *
C S PYINRE to initialize treatment of resonances *
C S PYINBM to read in beam, target and frame choices *
C S PYINKI to initialize kinematics of incoming particles *
C S PYINPR to set up the selection of included processes *
C S PYXTOT to give total, elastic and diffractive cross-sect. *
C S PYMAXI to find differential cross-section maxima *
C S PYPILE to select multiplicity of pileup events *
C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
C S PYGAGA to handle lepton -> lepton + gamma branchings *
C S PYRAND to select subprocess and kinematics for event *
C S PYSCAT to set up kinematics and colour flow of event *
C S PYEVOL handler for pT-ordered ISR and multiple interactions *
C S PYSSPA to simulate initial state spacelike showers *
C S PYPTIS to do pT-ordered initial state spacelike showers *
C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
C S PYPTMI to do pT-ordered multiple interactions *
C F PYFCMP to give companion quark x*f distribution *
C F PYPCMP to calculate momentum integral for companion quarks *
C S PYUPRE to rearranges contents of the HEPEUP commonblock *
C S PYADSH to administrate sequential final-state showers *
C S PYVETO to allow the generation of an event to be aborted *
C S PYRESD to perform resonance decays *
C S PYMULT to generate multiple interactions - old scheme *
C S PYREMN to add on target remnants - old scheme *
C S PYMIGN to generate multiple interactions - new scheme *
C S PYMIHK to connect colours in mult. int. - new scheme *
C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
C S PYMIHG to collapse two pairs of LHA1 colour tags. *
C S PYMIRM to add on target remnants in mult. int.- new scheme *
C S PYFSCR to perform final state colour reconnections - -"- *
C S PYDIFF to set up kinematics for diffractive events *
C S PYDISG to set up kinematics, remnant and showers for DIS *
C S PYDOCU to compute cross-sections and handle documentation *
C S PYFRAM to perform boosts between different frames *
C S PYWIDT to calculate full and partial widths of resonances *
C S PYOFSH to calculate partial width into off-shell channels *
C S PYRECO to handle colour reconnection in W+W- events *
C S PYKLIM to calculate borders of allowed kinematical region *
C S PYKMAP to construct value of kinematical variable *
C S PYSIGH to calculate differential cross-sections *
C S PYSGQC auxiliary to PYSIGH for QCD processes *
C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
C S PYSGHG auxiliary to PYSIGH for Higgs processes *
C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
C S PYSGTC auxiliary to PYSIGH for technicolor processes *
C S PYSGEX auxiliary to PYSIGH for various exotic processes *
C S PYPDFU to evaluate parton distributions *
C S PYPDFL to evaluate parton distributions at low x and Q^2 *
C S PYPDEL to evaluate electron parton distributions *
C S PYPDGA to evaluate photon parton distributions (generic) *
C S PYGGAM to evaluate photon parton distributions (SaS sets) *
C S PYGVMD to evaluate VMD part of photon parton distributions *
C S PYGANO to evaluate anomalous part of photon PDFs *
C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
C S PYGDIR to evaluate direct contribution to photon PDFs *
C S PYPDPI to evaluate pion parton distributions *
C S PYPDPR to evaluate proton parton distributions *
C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
C S PYGRVL to evaluate the GRV 94L proton parton distributions *
C S PYGRVM to evaluate the GRV 94M proton parton distributions *
C S PYGRVD to evaluate the GRV 94D proton parton distributions *
C F PYGRVV auxiliary to the PYGRV* routines *
C F PYGRVW auxiliary to the PYGRV* routines *
C F PYGRVS auxiliary to the PYGRV* routines *
C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
C S PYPDPO to evaluate old proton parton distributions *
C F PYHFTH to evaluate threshold factor for heavy flavour *
C S PYSPLI to find flavours left in hadron when one removed *
C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
C S PYSTBH to evaluate matrix element for t + b + H processes *
C S PYTBHB auxiliary to PYSTBH *
C S PYTBHG auxiliary to PYSTBH *
C S PYTBHQ auxiliary to PYSTBH *
C F PYTBHS auxiliary to PYSTBH *
C *
C S PYMSIN to initialize the supersymmetry simulation *
C S PYSLHA to interface to SUSY spectrum and decay calculators *
C S PYAPPS to determine MSSM parameters from SUGRA input *
C S PYSUGI to determine MSSM parameters using ISASUSY *
C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
C F PYRNMQ to determine running squark masses *
C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
C S PYINOM to calculate neutralino/chargino mass eigenstates *
C F PYRNM3 to determine running M3, gluino mass *
C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
C S PYHGGM to determine Higgs mass spectrum *
C S PYSUBH to determine Higgs masses in the MSSM *
C S PYPOLE to determine Higgs masses in the MSSM *
C S PYRGHM auxiliary to PYPOLE *
C S PYGFXX auxiliary to PYRGHM *
C F PYFINT auxiliary to PYPOLE *
C F PYFISB auxiliary to PYFINT *
C S PYSFDC to calculate sfermion decay partial widths *
C S PYGLUI to calculate gluino decay partial widths *
C S PYTBBN to calculate 3-body decay of gluino to neutralino *
C S PYTBBC to calculate 3-body decay of gluino to chargino *
C S PYNJDC to calculate neutralino decay partial widths *
C S PYCJDC to calculate chargino decay partial widths *
C F PYXXZ6 auxiliary for ino 3-body decays *
C F PYXXGA auxiliary for ino -> ino + gamma decay *
C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
C F PYX2XH auxiliary for ino -> ino + Higgs decay *
C S PYHEXT to calculate non-SM Higgs decay partial widths *
C F PYH2XX auxiliary for H -> ino + ino decay *
C F PYGAUS to perform Gaussian integration *
C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
C F PYSIMP to perform Simpson integration *
C F PYLAMF to evaluate the lambda kinematics function *
C S PYTBDY to perform 3-body decay of gauginos *
C S PYTECM to calculate techni_rho/omega masses *
C S PYXDIN to initialize Universal Extra Dimensions *
C S PYUEDC to compute UED mass radiative corrections *
C S PYXUED to compute UED cross sections *
C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
C F PYGRAW to compute UED partial widths to G* *
C F PYWDKK to compute UED differential partial widths to G* *
C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
C S PYCMQR auxiliary to PYEICG *
C S PYCMQ2 auxiliary to PYEICG *
C S PYCDIV auxiliary to PYCMQR *
C S PYCSRT auxiliary to PYCMQR *
C S PYTHAG auxiliary to PYCMQR *
C S PYCBAL auxiliary to PYEICG *
C S PYCBA2 auxiliary to PYEICG *
C S PYCRTH auxiliary to PYEICG *
C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
C S PYWIDX to calculate decay widths from within PYWIDT *
C S PYRVSF to calculate R-violating sfermion decay widths *
C S PYRVNE to calculate R-violating neutralino decay widths *
C S PYRVCH to calculate R-violating chargino decay widths *
C S PYRVGL to calculate R-violating gluino decay widths *
C F PYRVSB auxiliary to PYRVSF *
C S PYRVGW to calculate R-Violating 3-body widths *
C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
C *
C S PY1ENT to fill one entry (= parton or particle) *
C S PY2ENT to fill two entries *
C S PY3ENT to fill three entries *
C S PY4ENT to fill four entries *
C S PY2FRM to interface to generic two-fermion generator *
C S PY4FRM to interface to generic four-fermion generator *
C S PY6FRM to interface to generic six-fermion generator *
C S PY4JET to generate a shower from a given 4-parton config *
C S PY4JTW to evaluate the weight od a shower history for above *
C S PY4JTS to set up the parton configuration for above *
C S PYJOIN to connect entries with colour flow information *
C S PYGIVE to fill (or query) commonblock variables *
C S PYONOF to allow easy control of particle decay modes *
C S PYTUNE to select a predefined 'tune' for min-bias and UE *
C S PYEXEC to administrate fragmentation and decay chain *
C S PYPREP to rearrange showered partons along strings *
C S PYSTRF to do string fragmentation of jet system *
C S PYJURF to find boost to string junction rest frame *
C S PYINDF to do independent fragmentation of one or many jets *
C S PYDECY to do the decay of a particle *
C S PYDCYK to select parton and hadron flavours in decays *
C S PYKFDI to select parton and hadron flavours in fragm *
C S PYNMES to select number of popcorn mesons *
C S PYKFIN to calculate falvour prod. ratios from input params. *
C S PYPTDI to select transverse momenta in fragm *
C S PYZDIS to select longitudinal scaling variable in fragm *
C S PYSHOW to do m-ordered timelike parton shower evolution *
C S PYPTFS to do pT-ordered timelike parton shower evolution *
C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
C S PYBOEI to include Bose-Einstein effects (crudely) *
C S PYBESQ auxiliary to PYBOEI *
C F PYMASS to give the mass of a particle or parton *
C F PYMRUN to give the running MSbar mass of a quark *
C S PYNAME to give the name of a particle or parton *
C F PYCHGE to give three times the electric charge *
C F PYCOMP to compress standard KF flavour code to internal KC *
C S PYERRM to write error messages and abort faulty run *
C F PYALEM to give the alpha_electromagnetic value *
C F PYALPS to give the alpha_strong value *
C F PYANGL to give the angle from known x and y components *
C F PYR to provide a random number generator *
C S PYRGET to save the state of the random number generator *
C S PYRSET to set the state of the random number generator *
C S PYROBO to rotate and/or boost an event *
C S PYEDIT to remove unwanted entries from record *
C S PYLIST to list event record or particle data *
C S PYLOGO to write a logo *
C S PYUPDA to update particle data *
C F PYK to provide integer-valued event information *
C F PYP to provide real-valued event information *
C S PYSPHE to perform sphericity analysis *
C S PYTHRU to perform thrust analysis *
C S PYCLUS to perform three-dimensional cluster analysis *
C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
C S PYJMAS to give high and low jet mass of event *
C S PYFOWO to give Fox-Wolfram moments *
C S PYTABU to analyze events, with tabular output *
C *
C S PYEEVT to administrate the generation of an e+e- event *
C S PYXTEE to give the total cross-section at given CM energy *
C S PYRADK to generate initial state photon radiation *
C S PYXKFL to select flavour of primary qqbar pair *
C S PYXJET to select (matrix element) jet multiplicity *
C S PYX3JT to select kinematics of three-jet event *
C S PYX4JT to select kinematics of four-jet event *
C S PYXDIF to select angular orientation of event *
C S PYONIA to perform generation of onium decay to gluons *
C *
C S PYBOOK to book a histogram *
C S PYFILL to fill an entry in a histogram *
C S PYFACT to multiply histogram contents by a factor *
C S PYOPER to perform operations between histograms *
C S PYHIST to print and reset all histograms *
C S PYPLOT to print a single histogram *
C S PYNULL to reset contents of a single histogram *
C S PYDUMP to dump histogram contents onto a file *
C *
C S PYSTOP routine to handle Fortran STOP condition *
C *
C S PYKCUT dummy routine for user kinematical cuts *
C S PYEVWT dummy routine for weighting events *
C S UPINIT dummy routine to initialize user processes *
C S UPEVNT dummy routine to generate a user process event *
C S UPVETO dummy routine to abort event at parton level *
C S PDFSET dummy routine to be removed when using PDFLIB *
C S STRUCTM dummy routine to be removed when using PDFLIB *
C S STRUCTP dummy routine to be removed when using PDFLIB *
C S SUGRA dummy routine to be removed when linking with ISAJET *
C F VISAJE dummy functn. to be removed when linking with ISAJET *
C S SSMSSM dummy routine to be removed when linking with ISAJET *
C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
C S FHSETPARA dummy routine -"- FEYNHIGGS *
C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
C S PYTAUD dummy routine for interface to tau decay libraries *
C S PYTIME dummy routine for giving date and time *
C *
C*********************************************************************
C...PYDATA
C...Default values for switches and parameters,
C...and particle, decay and process data.
BLOCK DATA PYDATA
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYDATR/MRPY(6),RRPY(100)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
& AU(3,3),AD(3,3),AE(3,3)
COMMON/PYLH3C/CPRO(2),CVER(2)
CHARACTER CPRO*12,CVER*12
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
&/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
&/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
&/PYBINS/,/PYLH3P/,/PYLH3C/
C...PYDAT1, containing status codes and most parameters.
DATA MSTU/
& 0, 0, 0, 23000,23000, 500, 8000, 0, 0, 2,
1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
7 30*0,
1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
& 80*0/
DATA (PARU(I),I=1,100)/
& 3.141592653589793D0, 6.283185307179586D0,
& 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
6 40*0D0/
DATA (PARU(I),I=101,200)/
& 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
& 0D0, 0D0, 0D0, 0D0, 0D0,
1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
DATA MSTJ/
& 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
6 40*0,
& 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
2 80*0/
DATA PARJ/
& 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
& 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
5 0D0, 0D0, 0D0, 1.0D0, 0D0,
6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
& 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
4 10*0D0,
5 10*0D0,
6 10*0D0,
7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
9 5*0D0/
C...PYDAT2, with particle data and flavour treatment parameters.
DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
&-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
&3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
&0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
&2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
&2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
&2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
&2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
&2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
&7*0,3,
C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
&81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
&3*-3,0,-3,0,-3,0,-3,
&3*0,3,
&25*0/
DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
&2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
&-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
&6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
&83*0,12*1,9*0,2,3*0,25*0/
DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
&2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
&2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
&1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,
&81*0,21*1,3*0,1,25*0/
DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
&16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
&37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
&58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
&79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
&100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
&321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
&443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
&555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
&3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
&3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
&4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
&4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
&5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
&5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
&5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
&10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
&10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
&10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
&20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
&100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
&1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
&1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
&2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
&2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
&3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
&4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
&9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
&9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
&3000115,3000215,
&81*0,
C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
&6100001,6100002,6100003,6100004,6100005,6100006,
&5100001,5100002,5100003,5100004,5100005,5100006,
&6100011,6100013,6100015,
&5100012,5100011,5100014,5100013,5100016,5100015,
&5100021,5100022,5100023,5100024,
&25*0/
DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
&2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
&5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
&3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
&1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
&1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
&0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
&2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
&3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
&5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
&9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
&1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
&1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
&1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
&1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
&2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
&2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
&2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
&3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
&5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
&5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
&6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
&7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
&10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
&11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
&1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
&2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
&5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
&2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
&2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
&3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
&4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
&3*9.5D0,2*250D0,
&81*0,
C...UED
&586.,588.,586.,588.,586.,586.,6*598.,
&3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
&2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
&3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
&0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
&0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
&2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
&2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
&3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
&0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
&0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
&0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
&8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
&0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
&0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
&0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
&0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
&2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
&7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
&20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
&83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
&60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
&0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
&2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
&0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
&2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
&0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
&0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
&0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
&0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
&19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
&0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
&1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
&21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
&0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
&8.80013D0,13*0D0,2.54987D0,2.84456D0,
&81*0,
C...UED
&12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
&0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
&26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
&5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
&44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
&24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
&7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
&0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
DATA PARF/
& 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
& 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
3 60*0D0,
4 0.2D0, 0.5D0, 8*0D0,
5 1800*0D0/
DATA ((VCKM(I,J),J=1,4),I=1,4)/
& 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
& 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
& 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
& 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
C...PYDAT3, with particle decay parameters and data.
DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
&4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
&2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
&6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,
&81*0,
C...UED
&5*1,0,5*1,0,13*1,25*0/
DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
&87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
&503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
&583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
&739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
&953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
&1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
&1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
&1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
&1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
&1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
&1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
&1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
&1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
&1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
&1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
&1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
&2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
&3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
&4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
&4214,4215,4216,4296,4322,
&81*0,
C...UED
%5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
&5031,5032,5033,
&5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
&25*0/
DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
&2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
&5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
&3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
&3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
&0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
&5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
&45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
&28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
&3*22,15,12,2*7,7*0,6*1,26,30,
&81*0,
C...UED
&6*2,6*3,9*1,24,1,18,6,25*0/
DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
&7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
&2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
&2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
&3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
&3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
&1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
&3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
&5*-1,3*1,-1,
&649*0,
C...UED
&10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
&1,24*1,2912*0/
DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
&2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
&8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
&8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
&18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
&3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
&2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
&14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
&19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
&14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
&2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
&2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
&17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
&3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
&9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
&16*32,
C...UED
&653*0,30*0,9*0,12*0,37*0,2912*0/
DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
&0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
&0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
&0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
&0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
&0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
&0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
&0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
&0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
&0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
&0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
&0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
&0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
&4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
&64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
&0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
&0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
&0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
&0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
&0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
&69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
&0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
&66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
&0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
&0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
&0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
&0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
&0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
&0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
&0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
&0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
&0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
&0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
&0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
&0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
&0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
&0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
&0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
&2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
&0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
&0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
&0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
&0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
&0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
&0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
&0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
&0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
&0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
&0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
&0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
&0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
&0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
&2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
&0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
&0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
&0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
&0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
&2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
&4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
&0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
&0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
&0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
&0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
&0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
&0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
&1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
&0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
&2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
&0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
&0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
&0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
&0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
&2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
&0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
&0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
&2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
&0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
&0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
&0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
&0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
&0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
&0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
&0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
&0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
&1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
&0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
&0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
&0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
&2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
&0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
&4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
&3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
&0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
&2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
&0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
&0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
&3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
&3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
&0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
&0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
&0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
&0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
&0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
&0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
&0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
&0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
&0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
&0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
&0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
&0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
&0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
&0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
&3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
&0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
&0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
&0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
&0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
&0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
&0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
&0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
&0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
&0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
&0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
&0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
&0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
&0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
&0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
&0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
&6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
&0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
&0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
&0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
&0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
&0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
&0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
&0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
&0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
&0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
&0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
&0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
&0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
&0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
&0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
&0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
&0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
&0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
&0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
&0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
&0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
&0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
&0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
&0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
&2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
&0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
&0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
&3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
&0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
&4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
&0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
&2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
&0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
&0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
&2*0.011947D0,0.011946D0,0D0,
&649*0.D0,
C....UED
&0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
&0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
&0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
&0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
&9*1.D0,
&24*0.0416667,
&1.,
&3*0.D0,6*0.08333D0,
&3*0.D0,6*0.08333D0,
&6*0.166667D0,
&2912*0.D0/
DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
&21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
&4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
&23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
&22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
&-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
&3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
&-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
&2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
&2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
&1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
&-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
&1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
&2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
&1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
&-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
&13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
&-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
&37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
&2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
&1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
&2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
&1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
&-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
&1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
&2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
&24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
&2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
&1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
&2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
&1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
&-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
&1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
&2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
&-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
&1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
&-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
&-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
&223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
&22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
&321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
&323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
&323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
&11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
&-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
&2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
&2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
&411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
&-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
&-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
&211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
&5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
&323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
&443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
&2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
&6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
&2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
&3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
&2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
&513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
&2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
&3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
&3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
&2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
&3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
&2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
&3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
&2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
&-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
&2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
&2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
&2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
&2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
&2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
&-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
&-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
&2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
&-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
&-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
&223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
&2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
&323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
&2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
&523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
&-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
&2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
&10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
&1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
&1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
&12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
&1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
&2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
&1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
&1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
&12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
&1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
&3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
&1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
&3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
&15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
&1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
&1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
&-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
&2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
&1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
&2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
&1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
&2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
&1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
&2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
&1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
&2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
&1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
&2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
&2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
&-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
&1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
&6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
&1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
&-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
&-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
&-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
&-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
&-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
&-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
&-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
&-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
&-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
&-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
&-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
&-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
&-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
&-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
&-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
&16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
&1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
&-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
&1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
&-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
&2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
&-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
&1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
&-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
&2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
&-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
&5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
&14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
&16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
&11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
&12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
&13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
&14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
&15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
&-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
&6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
&-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
&2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
&1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
&-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
&-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
&-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
&-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
&-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
&-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
&-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
&-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
&-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
&3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
&1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
&-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
&1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
&-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
&2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
&-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
&1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
&-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
&2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
&-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
&5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
&14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
&16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
&11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
&12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
&13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
&14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
&15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
&16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
&16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
&-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
&1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
&-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
&1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
&-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
&2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
&-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
&1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
&-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
&2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
&12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
&14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
&12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
&11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
&14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
&13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
&16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
&15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
&-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
&6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
&1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
&-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
&2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
&2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
&-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
&-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
&16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
&2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
&2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
&2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
&2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
&2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
&2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
&1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
&2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
&14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
&1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
&1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
&-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
&1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
&12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
&1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
&2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
&-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
&2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
&11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
&1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
&1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
&-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
&4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
&3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
&1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
&2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
&1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
&1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
&6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
&1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,
&5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
&22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
&21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
&9*15/
DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
&12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
&3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
&2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
&18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
&22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
&16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
&14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
&-11,-13,-15,-17,
&649*0,
C...UED
&5100023,5100022,5100023,5100022,5100023,5100022,
&5100023,5100022,5100023,5100022,5100023,5100022,
&5100023,-5100024,5100022,5100023,5100024,5100022,
&5100023,-5100024,5100022,5100023,5100024,5100022,
&5100023,-5100024,5100022,5100023,5100024,5100022,
&9*5100022,
&6100001,6100002,6100003,6100004,6100005,6100006,
&5100001,5100002,5100003,5100004,5100005,5100006,
&-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
&-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
&39,
&6100011,6100013,6100015,
&5100011,5100013,5100015,
%5100012,5100014,5100016,
&-6100011,-6100013,-6100015,
&-5100011,-5100013,-5100015,
%-5100012,-5100014,-5100016,
&-5100011,-5100013,-5100015,
&5100012,5100014,5100016,
&2912*0/
DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
&6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
&2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
&13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
&-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
&-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
&2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
&-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
&-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
&12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
&-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
&1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
&2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
&2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
&2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
&2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
&2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
&2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
&-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
&2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
&-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
&1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
&-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
&-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
&2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
&2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
&2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
&2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
&-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
&1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
&-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
&-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
&2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
&2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
&2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
&2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
&2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
&1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
&2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
&-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
&-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
&22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
&-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
&2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
&111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
&221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
&-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
&211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
&211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
&111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
&211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
&211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
&-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
&2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
&-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
&431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
&-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
&20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
&4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
&433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
&-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
&-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
&-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
&-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
&111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
&11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
&213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
&-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
&211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
&3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
&111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
&-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
&15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
&4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
&13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
&1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
&3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
&4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
&1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
&3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
&2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
&-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
&2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
&2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
&-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
&111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
&311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
&-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
&-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
&1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
&-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
&2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
&5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
&2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
&4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
&16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
&1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
&13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
&5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
&5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
&13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
&1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
&5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
&1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
&-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
&-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
&-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
&-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
&-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
&-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
&-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
&1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
&6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
&5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
&4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
&23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
&-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
&-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
&5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
&14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
&-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
&-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
&1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
&6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
&5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
&4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
&3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
&-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
&2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
&-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
&6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
&-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
&-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
&-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
&-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
&2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
&15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
&25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
&-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
&-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
&-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
&13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
&15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
&-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
&-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
&-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
&-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
&-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
&22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
&16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
&-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
&-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
&-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
&16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
&-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
&-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
&3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
&2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
&5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
&4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
&1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
&-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
&-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
&2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
&16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
&2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
&14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
&-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
&-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
&6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
&-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
&-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
&6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
&36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
&2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
&5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
&3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
&5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
&2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
&2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
&13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
&15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
&23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
&5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
&-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
&-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
&-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
&2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
&21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
&3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,
&-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
&9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
&9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
&3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
&-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
&2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
&2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
&-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
&3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
&-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
&3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
&649*0,
C...UED
&1,1,2,2,3,3,4,4,5,5,6,6,
&1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
&11,13,15,12,11,14,13,16,15,
&-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
&1,2,3,4,5,6,1,2,3,4,5,6,
&22,
&-11,-13,-15,-11,-13,-15,-12,-14,-16,
&11,13,15,11,13,15,12,14,16,
&12,14,16,-11,-13,-15,
&2912*0/
DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
&2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
&2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
&402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
&-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
&211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
&3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
&113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
&111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
&111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
&-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
&-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
&111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
&3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
&-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
&111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
&-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
&111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
&-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
&441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
&2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
&2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
&4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
&2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
&2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
&4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
&3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
&4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
&3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
&-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
&-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
&6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
&-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
&-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
&-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
&-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
&-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
&-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
&-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
&-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
&-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
&-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
&-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
&-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
&-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
&-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
&-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
&-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
&-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
&-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
&4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
&-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
&14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
&2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
&2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
&2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
&2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
&-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
&-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
&-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
&-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
&-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
&-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
&-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
&-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
&-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
&-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
&-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
&11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
&-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
&-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
&-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
&-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
&-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
&4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
&28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
&-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
&15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
&2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
&2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
&2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
&2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
&1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
&6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
&6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
&6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
&3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
&6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
&111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
&-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
&34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
&-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
&2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
&4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
&162*81,31*0,-211,111,6516*0/
DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
&3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
&3*111,-211,111,7193*0/
C...PYDAT4, with particle names (character strings).
DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
&2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
&'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
&'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
&'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
&'junction',' ','system','cluster','string','indep.','CMshower',
&'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
&'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
&'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
&'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
&'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
&'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
&'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
&'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
&'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
&'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
&'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
&'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
&'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
&'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
&'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
&'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
&'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
&'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
&'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
&'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
&'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
&'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
&'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
&'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
&'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
&'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
&'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
&'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
&'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
&'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
&'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
&'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
&'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
&'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
&'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
&'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
&'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
&'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
&'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
&81*' ',
C...UED
&'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
&'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
&'e*_S-','mu*_S-','tau*_S-',
&'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
&'g*','gamma*','Z*0','W*+',25*' '/
DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
&'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
&'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
&'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
&' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
&'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
&'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
&3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
&'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
&'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
&'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
&'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
&'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
&'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
&'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
&'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
&'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
&'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
&'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
&'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
&'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
&'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
&'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
&'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
&'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
&'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
&'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
&'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
&'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
&'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
&'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
&'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
&'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
&'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
&'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
&'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
&'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
&'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
&'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
&'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
&'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
&'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
&81*' ',
C...UED
&'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
&'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
&'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
&'nu*_eDbar','e*_Dbar+',
&'nu*_muDbar','mu*_Dbar+',
&'nu*_tauDbar','tau*_Dbar+',
&'g*','gamma*','Z*0','W*-',25*' '/
C...PYDATR, with initial values for the random number generator.
DATA MRPY/19780503,0,0,97,33,0/
C...Default values for allowed processes and kinematics constraints.
DATA MSEL/1/
DATA MSUB/500*0/
DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
&5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
&6*1,4*0,4*1,16*0/
DATA CKIN/
& 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
& 1.0D0, -10D0, 10D0, -40D0, 40D0,
1 -40D0, 40D0, -40D0, 40D0, -40D0,
1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
6 -1D0, 0D0, -1D0, 0D0, -1D0,
7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
7 0.99D0, 2D0, -1D0, 0D0, 0D0,
8 120*0D0/
C...Default values for main switches and parameters. Reset information.
DATA (MSTP(I),I=1,100)/
& 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
DATA (MSTP(I),I=101,200)/
& 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
8 6, 425, 2011, 03, 23, 0, 0, 0, 0, 0,
9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
DATA (PARP(I),I=1,100)/
& 0.25D0, 10D0, 8*0D0,
1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
2 10*0D0,
3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
5 10*0D0,
6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
DATA (PARP(I),I=101,200)/
& 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
2 1.0D0, 0.4D0, 8*0D0,
3 0.01D0, 9*0D0,
4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
8 0.3D0, 0.64D0,
9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
DATA MSTI/200*0/
DATA PARI/200*0D0/
DATA MINT/400*0/
DATA VINT/400*0D0/
C...Constants for the generation of the various processes.
DATA (ISET(I),I=1,100)/
& 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
DATA (ISET(I),I=101,200)/
& -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
DATA (ISET(I),I=201,300)/
& 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
DATA (ISET(I),I=301,500)/
& 2, 9*-2, 9*2, 21*-2,
4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
9 1, 1, 2, 2, 2, 5*-2,
& 5, 5, 18*-2,
2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
8 2, 2, 18*-2/
DATA ((KFPR(I,J),J=1,2),I=1,50)/
& 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
& 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
DATA ((KFPR(I,J),J=1,2),I=51,100)/
5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
DATA ((KFPR(I,J),J=1,2),I=101,150)/
& 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
& 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
DATA ((KFPR(I,J),J=1,2),I=151,200)/
5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
DATA ((KFPR(I,J),J=1,2),I=201,240)/
& 1000011, 1000011, 2000011, 2000011, 1000011,
& 2000011, 1000013, 1000013, 2000013, 2000013,
& 1000013, 2000013, 1000015, 1000015, 2000015,
& 2000015, 1000015, 2000015, 1000011, 1000012,
1 1000015, 1000016, 2000015, 1000016, 1000012,
1 1000012, 1000016, 1000016, 0, 0,
1 1000022, 1000022, 1000023, 1000023, 1000025,
1 1000025, 1000035, 1000035, 1000022, 1000023,
2 1000022, 1000025, 1000022, 1000035, 1000023,
2 1000025, 1000023, 1000035, 1000025, 1000035,
2 1000024, 1000024, 1000037, 1000037, 1000024,
2 1000037, 1000022, 1000024, 1000023, 1000024,
3 1000025, 1000024, 1000035, 1000024, 1000022,
3 1000037, 1000023, 1000037, 1000025, 1000037,
3 1000035, 1000037, 1000021, 1000022, 1000021,
3 1000023, 1000021, 1000025, 1000021, 1000035/
DATA ((KFPR(I,J),J=1,2),I=241,280)/
4 1000021, 1000024, 1000021, 1000037, 1000021,
4 1000021, 1000021, 1000021, 0, 0,
4 1000002, 1000022, 2000002, 1000022, 1000002,
4 1000023, 2000002, 1000023, 1000002, 1000025,
5 2000002, 1000025, 1000002, 1000035, 2000002,
5 1000035, 1000001, 1000024, 2000005, 1000024,
5 1000001, 1000037, 2000005, 1000037, 1000002,
5 1000021, 2000002, 1000021, 0, 0,
6 1000006, 1000006, 2000006, 2000006, 1000006,
6 2000006, 1000006, 1000006, 2000006, 2000006,
6 0, 0, 0, 0, 0,
6 0, 0, 0, 0, 0,
7 1000002, 1000002, 2000002, 2000002, 1000002,
7 2000002, 1000002, 1000002, 2000002, 2000002,
7 1000002, 2000002, 1000002, 1000002, 2000002,
7 2000002, 1000002, 1000002, 2000002, 2000002/
DATA ((KFPR(I,J),J=1,2),I=281,350)/
8 1000005, 1000002, 2000005, 2000002, 1000005,
8 2000002, 1000005, 1000002, 2000005, 2000002,
8 1000005, 2000002, 1000005, 1000005, 2000005,
8 2000005, 1000005, 1000005, 2000005, 2000005,
9 1000005, 1000005, 2000005, 2000005, 1000005,
9 2000005, 1000005, 1000021, 2000005, 1000021,
9 1000005, 2000005, 37, 25, 37,
9 35, 36, 25, 36, 35,
& 37, 37, 18*0,
C...UED: 311-319
& 5100021, 5100021,
& 5100002, 5100021,
& 5100002, 5100001,
& 5100002, -5100002,
& 5100002, -5100002,
& 5100002, -6100001,
& 5100002, -5100001,
& 5100002, 6100001,
& 5100001, -5100001,
& 42*0,
4 9900041, 0, 9900042, 0, 9900041,
4 11, 9900042, 11, 9900041, 13,
4 9900042, 13, 9900041, 15, 9900042,
4 15, 9900041, 9900041, 9900042, 9900042/
DATA ((KFPR(I,J),J=1,2),I=351,400)/
5 9900041, 0, 9900042, 0, 9900023,
5 0, 9900024, 0, 0, 0,
5 0, 0, 0, 0, 0,
5 0, 0, 0, 0, 0,
6 24, 24, 24, 3000211, 3000211,
6 3000211, 22, 3000111, 22, 3000221,
6 23, 3000111, 23, 3000221, 24,
6 3000211, 0, 0, 24, 23,
7 24, 3000111, 3000211, 23, 3000211,
7 3000111, 22, 3000211, 23, 3000211,
7 24, 3000111, 24, 3000221, 22,
7 24, 22, 23, 23, 23,
8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
9 5000039, 0, 5000039, 0, 21,
9 5000039, 0, 5000039, 21, 5000039,
9 10*0/
DATA ((KFPR(I,J),J=1,2),I=401,500)/
& 37, 6, 37, 6, 36*0,
2 443, 21, 9900443, 21, 9900441,
2 21, 9910441, 21, 0, 9900443,
2 0, 9900441, 0, 9910441, 21,
2 9900443, 21, 9900441, 21, 9910441,
3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
6 553, 21, 9900553, 21, 9900551,
6 21, 9910551, 21, 0, 9900553,
6 0, 9900551, 0, 9910551, 21,
6 9900553, 21, 9900551, 21, 9910551,
7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
DATA COEF/10000*0D0/
DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
&4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
&3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
&3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
&3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
&4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
&2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
&4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
&3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
&4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
&0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
C...Treatment of resonances.
DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
&3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
&81*0,21*1,4*1,25*0/
C...Character constants: name of processes.
DATA PROC(0)/ 'All included subprocesses '/
DATA (PROC(I),I=1,20)/
&'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
&'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
&'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
&' ', 'W+ + W- -> h0 ',
&' ', 'f + f'' -> f + f'' (QFD) ',
1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
DATA (PROC(I),I=21,40)/
2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
DATA (PROC(I),I=41,60)/
4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
DATA (PROC(I),I=61,80)/
6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
DATA (PROC(I),I=81,100)/
8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
8'g + g -> chi_2c + g ', ' ',
9'Elastic scattering ', 'Single diffractive (XB) ',
9'Single diffractive (AX) ', 'Double diffractive ',
9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
9' ', ' ',
9'q + gamma* -> q ', ' '/
DATA (PROC(I),I=101,120)/
&'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
&'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
&'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
&'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
&' ', 'f + fbar -> gamma + h0 ',
1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1' ', ' '/
DATA (PROC(I),I=121,140)/
2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
2'f + f'' -> f + f'' + h0 ',
2'f + f'' -> f" + f"'' + h0 ',
2' ', ' ',
2' ', ' ',
2' ', ' ',
3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
DATA (PROC(I),I=141,160)/
4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
4'q + l -> LQ ', 'e + gamma -> e* ',
4'd + g -> d* ', 'u + g -> u* ',
4'g + g -> eta_tc ', ' ',
5'f + fbar -> H0 ', 'g + g -> H0 ',
5'gamma + gamma -> H0 ', ' ',
5' ', 'f + fbar -> A0 ',
5'g + g -> A0 ', 'gamma + gamma -> A0 ',
5' ', ' '/
DATA (PROC(I),I=161,180)/
6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
6'f + fbar -> f'' + fbar'' (g/Z)',
6'f +fbar'' -> f" + fbar"'' (W) ',
6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
6'q + qbar -> e + e* ', ' ',
7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
7'f + f'' -> f + f'' + H0 ',
7'f + f'' -> f" + f"'' + H0 ',
7' ', 'f + fbar -> Z0 + A0 ',
7'f + fbar'' -> W+/- + A0 ',
7'f + f'' -> f + f'' + A0 ',
7'f + f'' -> f" + f"'' + A0 ',
7' '/
DATA (PROC(I),I=181,200)/
8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
8'q + g -> q + A0 ', 'g + g -> g + A0 ',
9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
9' ', ' ',
9' ', ' '/
DATA (PROC(I),I=201,220)/
&'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
&'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
&'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
&'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
&'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
DATA (PROC(I),I=221,240)/
2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
DATA (PROC(I),I=241,260)/
4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
4' ', 'qj + g -> ~qj_L + ~chi1 ',
4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
5'qj + g -> ~qj_R + ~g ', ' '/
DATA (PROC(I),I=261,300)/
6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
6'g + g -> ~t_2 + ~t_2bar ', ' ',
6' ', ' ',
6' ', ' ',
7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
DATA (PROC(I),I=301,340)/
&'f + fbar -> H+ + H- ',
&9*' ', 'g + g -> g* + g* ',
&'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
&'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
&'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
&'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
&21*' '/
DATA (PROC(I),I=341,380)/
4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
5'f + f -> f'' + f'' + H_L++/-- ',
5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
5'f + fbar'' -> W_R+/- ',5*' ',
6' ', 'f + fbar -> W_L+ W_L- ',
6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
6'f + fbar -> W+/- pi_T-/+ ', ' ',
7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
7'f + fbar'' -> W+/- pi_T0 ',
7'f + fbar'' -> W+/- pi_T0'' ',
7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
7'f + fbar -> Z0 Z0 (ETC) '/
DATA (PROC(I),I=381,420)/
8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
8' ', ' ',
9'f + fbar -> G* ', 'g + g -> G* ',
9'q + qbar -> g + G* ', 'q + g -> q + G* ',
9'g + g -> g + G* ', ' ',
9 4*' ',
&'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
& 18*' '/
DATA (PROC(I),I=421,460)/
2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
3'q + q~ -> g + cc~[3P2(1)] ',
3 21 *' '/
DATA (PROC(I),I=461,500)/
6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
7'q + q~ -> g + bb~[3P2(1)] ',
7 21 *' '/
C...Cross sections and slope offsets.
DATA SIGT/294*0D0/
C...Supersymmetry switches and parameters.
DATA IMSS/0,
& 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
1 89*0/
DATA RMSS/0D0,
& 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
3 10*0D0,
4 0D0,1D0,8*0D0,
5 49*0D0/
C...Initial values for R-violating SUSY couplings.
C...Should not be changed here. See PYMSIN.
DATA RVLAM/27*0D0/
DATA RVLAMP/27*0D0/
DATA RVLAMB/27*0D0/
C...Technicolor switches and parameters
DATA ITCM/0,
& 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1 89*0/
DATA RTCM/0D0,
& 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
4 200D0, 48*0D0/
C...UED switches and parameters.
C... IUED(0) empty IUED vector element
C... IUED(1) UED ON(=1)/OFF(=0) switch
C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
C... IUED(4) N the number of large extra dimensions
C... IUED(5) Selects whether the code takes Lambda (=0)
C... or Lambda*R (=1) as input.
C... IUED(6) With radiative corrections to the masses (=1)
C... or without (=0)
C...
C... RUED(0) empty RUED vector element
C... RUED(1) RINV (1/R) the curvature of the extra dimension
C... RUED(2) XMD the (4+N)-dimensional Planck scale
C... RUED(3) LAMUED (Lambda cutoff scale)
C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
C...
DATA IUED/0,0,0,5,6,0,1,93*0/
DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
C...Data for histogramming routines.
DATA IHIST/1000,20000,55,1/
DATA INDX/1000*0/
C...Data for SUSY Les Houches Accord.
DATA CPRO/'PYTHIA ','PYTHIA '/
DATA CVER/'6.4 ','6.4 '/
DATA MODSEL/200*0/
DATA PARMIN/100*0D0/
DATA RMSOFT/101*0D0/
DATA AU/9*0D0/
DATA AD/9*0D0/
DATA AE/9*0D0/
END
C*********************************************************************
C...PYCKBD
C...Check that BLOCK DATA PYDATA has been loaded.
C...Should not be required, except that some compilers/linkers
C...are pretty buggy in this respect.
SUBROUTINE PYCKBD
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
C...Check a few variables to see they have been sensibly initialized.
IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
&.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
&MSTP(1).GT.5) THEN
C...If not, abort the run right away.
WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
WRITE(*,*) 'The program execution is stopped now!'
CALL PYSTOP(8)
ENDIF
RETURN
END
C*********************************************************************
C...PYTEST
C...A simple program (disguised as subroutine) to run at installation
C...as a check that the program works as intended.
SUBROUTINE PYTEST(MTEST)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
C...Local arrays.
DIMENSION PSUM(5),PINI(6),PFIN(6)
C...Save defaults for values that are changed.
MSTJ1=MSTJ(1)
MSTJ3=MSTJ(3)
MSTJ11=MSTJ(11)
MSTJ42=MSTJ(42)
MSTJ43=MSTJ(43)
MSTJ44=MSTJ(44)
PARJ17=PARJ(17)
PARJ22=PARJ(22)
PARJ43=PARJ(43)
PARJ54=PARJ(54)
MST101=MSTJ(101)
MST104=MSTJ(104)
MST105=MSTJ(105)
MST107=MSTJ(107)
MST116=MSTJ(116)
C...First part: loop over simple events to be generated.
IF(MTEST.GE.1) CALL PYTABU(20)
NERR=0
DO 180 IEV=1,500
C...Reset parameter values. Switch on some nonstandard features.
MSTJ(1)=1
MSTJ(3)=0
MSTJ(11)=1
MSTJ(42)=2
MSTJ(43)=4
MSTJ(44)=2
PARJ(17)=0.1D0
PARJ(22)=1.5D0
PARJ(43)=1D0
PARJ(54)=-0.05D0
MSTJ(101)=5
MSTJ(104)=5
MSTJ(105)=0
MSTJ(107)=1
IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
C...Ten events each for some single jets configurations.
IF(IEV.LE.50) THEN
ITY=(IEV+9)/10
MSTJ(3)=-1
IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
C...Ten events each for some simple jet systems; string fragmentation.
ELSEIF(IEV.LE.130) THEN
ITY=(IEV-41)/10
IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
& 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
C...Seventy events with independent fragmentation and momentum cons.
ELSEIF(IEV.LE.200) THEN
ITY=1+(IEV-131)/16
MSTJ(2)=1+MOD(IEV-131,4)
MSTJ(3)=1+MOD((IEV-131)/4,4)
IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
& 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
& 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
C...A hundred events with random jets (check invariant mass).
ELSEIF(IEV.LE.300) THEN
100 DO 110 J=1,5
PSUM(J)=0D0
110 CONTINUE
NJET=2D0+6D0*PYR(0)
DO 130 I=1,NJET
KFL=21
IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
EJET=5D0+20D0*PYR(0)
THETA=ACOS(2D0*PYR(0)-1D0)
PHI=6.2832D0*PYR(0)
IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
DO 120 J=1,4
PSUM(J)=PSUM(J)+P(I,J)
120 CONTINUE
130 CONTINUE
IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
& (PSUM(5)+PARJ(32))**2) GOTO 100
C...Fifty e+e- continuum events with matrix elements.
ELSEIF(IEV.LE.350) THEN
MSTJ(101)=2
CALL PYEEVT(0,40D0)
C...Fifty e+e- continuum event with varying shower options.
ELSEIF(IEV.LE.400) THEN
MSTJ(42)=1+MOD(IEV,2)
MSTJ(43)=1+MOD(IEV/2,4)
MSTJ(44)=MOD(IEV/8,3)
CALL PYEEVT(0,90D0)
C...Fifty e+e- continuum events with coherent shower.
ELSEIF(IEV.LE.450) THEN
CALL PYEEVT(0,500D0)
C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
ELSE
CALL PYONIA(5,9.46D0)
ENDIF
C...Generate event. Find total momentum, energy and charge.
DO 140 J=1,4
PINI(J)=PYP(0,J)
140 CONTINUE
PINI(6)=PYP(0,6)
CALL PYEXEC
DO 150 J=1,4
PFIN(J)=PYP(0,J)
150 CONTINUE
PFIN(6)=PYP(0,6)
C...Check conservation of energy, momentum and charge;
C...usually exact, but only approximate for single jets.
MERR=0
IF(IEV.LE.50) THEN
IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
& MERR=MERR+1
EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
ELSE
DO 160 J=1,4
IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
160 CONTINUE
IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
ENDIF
IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
& (PFIN(J),J=1,4),PFIN(6)
C...Check that all KF codes are known ones, and that partons/particles
C...satisfy energy-momentum-mass relation. Store particle statistics.
DO 170 I=1,N
IF(K(I,1).GT.20) GOTO 170
IF(PYCOMP(K(I,2)).EQ.0) THEN
WRITE(MSTU(11),5100) I
MERR=MERR+1
ENDIF
PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
& THEN
WRITE(MSTU(11),5200) I
MERR=MERR+1
ENDIF
170 CONTINUE
IF(MTEST.GE.1) CALL PYTABU(21)
C...List all erroneous events and some normal ones.
IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
IF(MERR.GE.1) WRITE(MSTU(11),6400)
CALL PYLIST(2)
ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
CALL PYLIST(1)
ENDIF
C...Stop execution if too many errors.
IF(MERR.NE.0) NERR=NERR+1
IF(NERR.GE.10) THEN
WRITE(MSTU(11),6300)
CALL PYLIST(1)
CALL PYSTOP(9)
ENDIF
180 CONTINUE
C...Summarize result of run.
IF(MTEST.GE.1) CALL PYTABU(22)
C...Reset commonblock variables changed during run.
MSTJ(1)=MSTJ1
MSTJ(3)=MSTJ3
MSTJ(11)=MSTJ11
MSTJ(42)=MSTJ42
MSTJ(43)=MSTJ43
MSTJ(44)=MSTJ44
PARJ(17)=PARJ17
PARJ(22)=PARJ22
PARJ(43)=PARJ43
PARJ(54)=PARJ54
MSTJ(101)=MST101
MSTJ(104)=MST104
MSTJ(105)=MST105
MSTJ(107)=MST107
MSTJ(116)=MST116
C...Second part: complete events of various kinds.
C...Common initial values. Loop over initiating conditions.
MSTP(122)=MAX(0,MIN(2,MTEST))
MDCY(PYCOMP(111),1)=0
DO 230 IPROC=1,8
C...Reset process type, kinematics cuts, and the flags used.
MSEL=0
DO 190 ISUB=1,500
MSUB(ISUB)=0
190 CONTINUE
CKIN(1)=2D0
CKIN(3)=0D0
MSTP(2)=1
MSTP(11)=0
MSTP(33)=0
MSTP(81)=1
MSTP(82)=1
MSTP(111)=1
MSTP(131)=0
MSTP(133)=0
PARP(131)=0.01D0
C...Prompt photon production at fixed target.
IF(IPROC.EQ.1) THEN
PZSUM=300D0
PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
PQSUM=2D0
MSEL=10
CKIN(3)=5D0
CALL PYINIT('FIXT','pi+','p',PZSUM)
C...QCD processes at ISR energies.
ELSEIF(IPROC.EQ.2) THEN
PESUM=63D0
PZSUM=0D0
PQSUM=2D0
MSEL=1
CKIN(3)=5D0
CALL PYINIT('CMS','p','p',PESUM)
C...W production + multiple interactions at CERN Collider.
ELSEIF(IPROC.EQ.3) THEN
PESUM=630D0
PZSUM=0D0
PQSUM=0D0
MSEL=12
CKIN(1)=20D0
MSTP(82)=4
MSTP(2)=2
MSTP(33)=3
CALL PYINIT('CMS','p','pbar',PESUM)
C...W/Z gauge boson pairs + pileup events at the Tevatron.
ELSEIF(IPROC.EQ.4) THEN
PESUM=1800D0
PZSUM=0D0
PQSUM=0D0
MSUB(22)=1
MSUB(23)=1
MSUB(25)=1
CKIN(1)=200D0
MSTP(111)=0
MSTP(131)=1
MSTP(133)=2
PARP(131)=0.04D0
CALL PYINIT('CMS','p','pbar',PESUM)
C...Higgs production at LHC.
ELSEIF(IPROC.EQ.5) THEN
PESUM=15400D0
PZSUM=0D0
PQSUM=2D0
MSUB(3)=1
MSUB(102)=1
MSUB(123)=1
MSUB(124)=1
PMAS(25,1)=300D0
CKIN(1)=200D0
MSTP(81)=0
MSTP(111)=0
CALL PYINIT('CMS','p','p',PESUM)
C...Z' production at SSC.
ELSEIF(IPROC.EQ.6) THEN
PESUM=40000D0
PZSUM=0D0
PQSUM=2D0
MSEL=21
PMAS(32,1)=600D0
CKIN(1)=400D0
MSTP(81)=0
MSTP(111)=0
CALL PYINIT('CMS','p','p',PESUM)
C...W pair production at 1 TeV e+e- collider.
ELSEIF(IPROC.EQ.7) THEN
PESUM=1000D0
PZSUM=0D0
PQSUM=0D0
MSUB(25)=1
MSUB(69)=1
MSTP(11)=1
CALL PYINIT('CMS','e+','e-',PESUM)
C...Deep inelastic scattering at a LEP+LHC ep collider.
ELSEIF(IPROC.EQ.8) THEN
P(1,1)=0D0
P(1,2)=0D0
P(1,3)=8000D0
P(2,1)=0D0
P(2,2)=0D0
P(2,3)=-80D0
PESUM=8080D0
PZSUM=7920D0
PQSUM=0D0
MSUB(10)=1
CKIN(3)=50D0
MSTP(111)=0
CALL PYINIT('3MOM','p','e-',PESUM)
ENDIF
C...Generate 20 events of each required type.
DO 220 IEV=1,20
CALL PYEVNT
PESUMM=PESUM
IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
C...Check conservation of energy/momentum/flavour.
PINI(1)=0D0
PINI(2)=0D0
PINI(3)=PZSUM
PINI(4)=PESUMM
PINI(6)=PQSUM
DO 200 J=1,4
PFIN(J)=PYP(0,J)
200 CONTINUE
PFIN(6)=PYP(0,6)
MERR=0
DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
DEVQ=ABS(PFIN(6)-PINI(6))
IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
& DEVQ.GT.0.1D0) MERR=1
IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
& (PFIN(J),J=1,4),PFIN(6)
C...Check that all KF codes are known ones, and that partons/particles
C...satisfy energy-momentum-mass relation.
DO 210 I=1,N
IF(K(I,1).GT.20) GOTO 210
IF(PYCOMP(K(I,2)).EQ.0) THEN
WRITE(MSTU(11),5100) I
MERR=MERR+1
ENDIF
PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
& SIGN(1D0,P(I,5))
IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
& .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
WRITE(MSTU(11),5200) I
MERR=MERR+1
ENDIF
210 CONTINUE
C...Listing of erroneous events, and first event of each type.
IF(MERR.GE.1) NERR=NERR+1
IF(NERR.GE.10) THEN
WRITE(MSTU(11),6300)
CALL PYLIST(1)
CALL PYSTOP(9)
ENDIF
IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
IF(MERR.GE.1) WRITE(MSTU(11),6400)
CALL PYLIST(1)
ENDIF
220 CONTINUE
C...List statistics for each process type.
IF(MTEST.GE.1) CALL PYSTAT(1)
230 CONTINUE
C...Summarize result of run.
IF(NERR.EQ.0) WRITE(MSTU(11),6500)
IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
C...Format statements for output.
5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
&'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
&'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
&4(1X,F12.5),1X,F8.2)
5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
&'kinematics')
6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
&'wrong.'/5X,'Execution will be stopped after listing of event.')
6400 FORMAT(5X,'Faulty event follows:')
6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
&5X,'This should not have happened!')
RETURN
END
C*********************************************************************
C...PYHEPC
C...Converts PYTHIA event record contents to or from
C...the standard event record commonblock.
SUBROUTINE PYHEPC(MCONV)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...HEPEVT commonblock.
PARAMETER (NMXHEP=4000)
COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
&JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
DOUBLE PRECISION PHEP,VHEP
SAVE /HEPEVT/
C...Store HEPEVT commonblock size (for interfacing issues).
MSTU(8)=NMXHEP
C...Initialize variable(s)
INEW = 1
C...Conversion from PYTHIA to standard, the easy part.
IF(MCONV.EQ.1) THEN
NEVHEP=0
IF(N.GT.NMXHEP) CALL PYERRM(8,
& '(PYHEPC:) no more space in /HEPEVT/')
NHEP=MIN(N,NMXHEP)
DO 150 I=1,NHEP
ISTHEP(I)=0
IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
IDHEP(I)=K(I,2)
JMOHEP(1,I)=K(I,3)
JMOHEP(2,I)=0
IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
JDAHEP(1,I)=K(I,4)
JDAHEP(2,I)=K(I,5)
ELSE
JDAHEP(1,I)=0
JDAHEP(2,I)=0
ENDIF
DO 100 J=1,5
PHEP(J,I)=P(I,J)
100 CONTINUE
DO 110 J=1,4
VHEP(J,I)=V(I,J)
110 CONTINUE
C...Check if new event (from pileup).
IF(I.EQ.1) THEN
INEW=1
ELSE
IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
ENDIF
C...Fill in missing mother information.
IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
IMO1=I-2
120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
& THEN
IMO1=IMO1-1
GOTO 120
ENDIF
JMOHEP(1,I)=IMO1
JMOHEP(2,I)=IMO1+1
ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
I1=K(I,3)-1
130 I1=I1+1
IF(I1.GE.I) CALL PYERRM(8,
& '(PYHEPC:) translation of inconsistent event history')
IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
KC=PYCOMP(K(I1,2))
IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
JMOHEP(2,I)=I1
ELSEIF(K(I,2).EQ.94) THEN
NJET=2
IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
& MOD(K(I+1,4)/MSTU(5),MSTU(5))
ENDIF
C...Fill in missing daughter information.
IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
JDAHEP(1,I2)=I
140 CONTINUE
ENDIF
IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
I1=JMOHEP(1,I)
IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
IF(JDAHEP(1,I1).EQ.0) THEN
JDAHEP(1,I1)=I
ELSE
JDAHEP(2,I1)=I
ENDIF
150 CONTINUE
DO 160 I=1,NHEP
IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
160 CONTINUE
C...Conversion from standard to PYTHIA, the easy part.
ELSE
IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
& '(PYHEPC:) no more space in /PYJETS/')
N=MIN(NHEP,MSTU(4))
NKQ=0
KQSUM=0
DO 190 I=1,N
K(I,1)=0
IF(ISTHEP(I).EQ.1) K(I,1)=1
IF(ISTHEP(I).EQ.2) THEN
K(I,1)=11
IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND.
$ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND.
$ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12
ENDIF
IF(ISTHEP(I).EQ.3) K(I,1)=21
K(I,2)=IDHEP(I)
K(I,3)=JMOHEP(1,I)
K(I,4)=JDAHEP(1,I)
K(I,5)=JDAHEP(2,I)
DO 170 J=1,5
P(I,J)=PHEP(J,I)
170 CONTINUE
DO 180 J=1,4
V(I,J)=VHEP(J,I)
180 CONTINUE
V(I,5)=0D0
IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
I1=JDAHEP(1,I)
IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
& PHEP(5,I)/PHEP(4,I)
ENDIF
C...Fill in missing information on colour connection in jet systems.
IF(ISTHEP(I).EQ.1) THEN
KC=PYCOMP(K(I,2))
KQ=0
IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
IF(KQ.NE.0) NKQ=NKQ+1
IF(KQ.NE.2) KQSUM=KQSUM+KQ
IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
K(I,1)=2
ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
IF(K(I+1,2).EQ.21) K(I,1)=2
ENDIF
ENDIF
190 CONTINUE
IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
& '(PYHEPC:) input parton configuration not colour singlet')
ENDIF
END
C*********************************************************************
C...PYINIT
C...Initializes the generation procedure; finds maxima of the
C...differential cross-sections to be used for weighting.
SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
C...Local arrays and character variables.
DIMENSION ALAMIN(20),NFIN(20)
CHARACTER*(*) FRAME,BEAM,TARGET
CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
C...Interface to PDFLIB.
COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
COMMON/W50512/QCDL4,QCDL5
SAVE /W50511/,/W50512/
DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
CHARACTER*20 PARM(20)
DATA VALUE/20*0D0/,PARM/20*' '/
C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
common/pdfas/pdfalphas
double precision pdfalphas
C...Data:Lambda and n_f values for parton distributions..
DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
&0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
&NFIN/20*4/
DATA CHLH/'lepton','hadron'/
C...Check that BLOCK DATA PYDATA has been loaded.
CALL PYCKBD
-
+
C...Reset MINT and VINT arrays. Write headers.
MSTI(53)=0
DO 100 J=1,400
MINT(J)=0
VINT(J)=0D0
100 CONTINUE
IF(MSTU(12).NE.12345) CALL PYLIST(0)
IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
C...Reset error counters.
MSTU(23)=0
MSTU(27)=0
MSTU(30)=0
C...Reset processes that should not be on.
MSUB(96)=0
MSUB(97)=0
C...Select global FSR/ISR/UE parameter set = 'tune'
C...See routine PYTUNE for details
IF (MSTP(5).NE.0) THEN
MSTP5=MSTP(5)
CALL PYTUNE(MSTP5)
ENDIF
C...Call user process initialization routine.
IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
MSEL=0
CALL UPINIT
MSEL=0
ENDIF
C...Maximum 4 generations; set maximum number of allowed flavours.
MSTP(1)=MIN(4,MSTP(1))
MSTU(114)=MIN(MSTU(114),2*MSTP(1))
MSTP(58)=MIN(MSTP(58),2*MSTP(1))
C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
DO 120 I=-20,20
VINT(180+I)=0D0
IA=IABS(I)
IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
DO 110 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
& VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
110 CONTINUE
ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
VINT(180+I)=1D0
ENDIF
120 CONTINUE
C...Initialize parton distributions: PDFLIB.
IF(MSTP(52).EQ.2) THEN
PARM(1)='NPTYPE'
VALUE(1)=1
PARM(2)='NGROUP'
VALUE(2)=MSTP(51)/1000
PARM(3)='NSET'
VALUE(3)=MOD(MSTP(51),1000)
PARM(4)='TMAS'
VALUE(4)=PMAS(6,1)
call setlhaparm('SILENT')
CALL PDFSET(PARM,VALUE)
MINT(93)=1000000+MSTP(51)
ENDIF
C...Choose Lambda value to use in alpha-strong.
MSTU(111)=MSTP(2)
IF(MSTP(3).GE.2) THEN
ALAM=0.2D0
NF=4
IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
ALAM=ALAMIN(MSTP(51))
NF=NFIN(MSTP(51))
ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
ALAM=QCDL5
NF=5
ELSEIF(MSTP(52).EQ.2) THEN
ALAM=QCDL4
NF=4
ENDIF
C...Set alpha_s(M_Z) by hand if communication with LHAPDF doesn't work
if (alam.eq.0.) then
write(*,*)'Attention: value of alpha_s(M_Z) in pdf set '//
&'manually to ',pdfalphas
alam = pdfalphas
endif
PARP(1)=ALAM
PARP(61)=ALAM
PARP(72)=ALAM
PARU(112)=ALAM
MSTU(112)=NF
IF(MSTP(3).EQ.3) PARJ(81)=ALAM
ENDIF
C...Initialize the UED masses and widths
IF (IUED(1).EQ.1) CALL PYXDIN
C...Initialize the SUSY generation: couplings, masses,
C...decay modes, branching ratios, and so on.
CALL PYMSIN
C...Initialize widths and partial widths for resonances.
CALL PYINRE
C...Set Z0 mass and width for e+e- routines.
PARJ(123)=PMAS(23,1)
PARJ(124)=PMAS(23,2)
C...Identify beam and target particles and frame of process.
CHFRAM=FRAME//' '
CHBEAM=BEAM//' '
CHTARG=TARGET//' '
CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
IF(MINT(65).EQ.1) GOTO 170
C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
C...For e-gamma allow 2 alternatives.
MINT(121)=1
IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
& (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
& (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
& (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
& (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
& (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
ENDIF
MINT(123)=MSTP(14)
IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
&MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
IF(MSTP(14).EQ.11) MINT(123)=0
IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
IF(MSTP(14).EQ.15) MINT(123)=2
IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
IF(MSTP(14).EQ.19) MINT(123)=3
ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
IF(MSTP(14).EQ.21) MINT(123)=0
IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
IF(MSTP(14).EQ.24) MINT(123)=1
ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
ENDIF
C...Set up kinematics of process.
CALL PYINKI(0)
C...Set up kinematics for photons inside leptons.
IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
C...Precalculate flavour selection weights.
CALL PYKFIN
C...Loop over gamma-p or gamma-gamma alternatives.
CKIN3=CKIN(3)
MSAV48=0
DO 160 IGA=1,MINT(121)
CKIN(3)=CKIN3
MINT(122)=IGA
C...Select partonic subprocesses to be included in the simulation.
CALL PYINPR
MINT(101)=1
MINT(102)=1
MINT(103)=MINT(11)
MINT(104)=MINT(12)
C...Count number of subprocesses on.
MINT(48)=0
DO 130 ISUB=1,500
IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
& MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
MSUB(ISUB)=0
ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
& MSUB(ISUB).EQ.1) THEN
WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
CALL PYSTOP(1)
ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
WRITE(MSTU(11),5300) ISUB
CALL PYSTOP(1)
ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
WRITE(MSTU(11),5400) ISUB
CALL PYSTOP(1)
ELSEIF(MSUB(ISUB).EQ.1) THEN
MINT(48)=MINT(48)+1
ENDIF
130 CONTINUE
C...Stop or raise warning flag if no subprocesses on.
IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
IF(MSTP(127).NE.1) THEN
WRITE(MSTU(11),5500)
CALL PYSTOP(1)
ELSE
WRITE(MSTU(11),5700)
MSTI(53)=1
ENDIF
ENDIF
MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
MSAV48=MSAV48+MINT(48)
C...Reset variables for cross-section calculation.
DO 150 I=0,500
DO 140 J=1,3
NGEN(I,J)=0
XSEC(I,J)=0D0
140 CONTINUE
150 CONTINUE
C...Find parametrized total cross-sections.
CALL PYXTOT
VINT(318)=VINT(317)
C...Maxima of differential cross-sections.
IF(MSTP(121).LE.1) CALL PYMAXI
C...Initialize possibility of pileup events.
IF(MINT(121).GT.1) MSTP(131)=0
IF(MSTP(131).NE.0) CALL PYPILE(1)
C...Initialize multiple interactions with variable impact parameter.
IF(MINT(50).EQ.1) THEN
PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
& ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
MINT(35)=1
CALL PYMULT(1)
MINT(35)=3
CALL PYMIGN(1)
ENDIF
ENDIF
C...Save results for gamma-p and gamma-gamma alternatives.
IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
160 CONTINUE
C...Initialization finished.
IF(MSAV48.EQ.0) THEN
IF(MSTP(127).NE.1) THEN
WRITE(MSTU(11),5500)
CALL PYSTOP(1)
ELSE
WRITE(MSTU(11),5700)
MSTI(53)=1
ENDIF
ENDIF
170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
C...Formats for initialization information.
5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
&'routines',1X,17('*'))
5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
&'-',A6,' interactions.'/1X,'Execution stopped!')
5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
&1X,'Execution stopped!')
5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
&1X,'Execution stopped!')
5500 FORMAT(1X,'Error: no subprocess switched on.'/
&1X,'Execution stopped.')
5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
&22('*'))
5700 FORMAT(1X,'Error: no subprocess switched on.'/
&1X,'Execution will stop if you try to generate events.')
RETURN
END
C*********************************************************************
C...PYEVNT
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines.
SUBROUTINE PYEVNT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
C...Local array.
DIMENSION VTX(4)
C...Optionally let PYEVNW do the whole job.
IF(MSTP(81).GE.20) THEN
CALL PYEVNW
RETURN
ENDIF
C...Stop if no subprocesses on.
IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
WRITE(MSTU(11),5100)
CALL PYSTOP(1)
ENDIF
C...Initial values for some counters.
MSTU(1)=0
MSTU(2)=0
N=0
MINT(5)=MINT(5)+1
MINT(7)=0
MINT(8)=0
MINT(30)=0
MINT(83)=0
MINT(84)=MSTP(126)
MSTU(24)=0
MSTU70=0
MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
NCT=0
MINT(33)=0
C...Let called routines know call is from PYEVNT (not PYEVNW).
MINT(35)=1
IF (MSTP(81).GE.10) MINT(35)=2
C...If variable energies: redo incoming kinematics and cross-section.
MSTI(61)=0
IF(MSTP(171).EQ.1) THEN
CALL PYINKI(1)
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(121).GT.1) CALL PYSAVE(3,1)
CALL PYXTOT
ENDIF
C...Loop over number of pileup events; check space left.
IF(MSTP(131).LE.0) THEN
NPILE=1
ELSE
CALL PYPILE(2)
NPILE=MINT(81)
ENDIF
DO 270 IPILE=1,NPILE
IF(MINT(84)+100.GE.MSTU(4)) THEN
CALL PYERRM(11,
& '(PYEVNT:) no more space in PYJETS for pileup events')
IF(MSTU(21).GE.1) GOTO 280
ENDIF
MINT(82)=IPILE
C...Generate variables of hard scattering.
MINT(51)=0
MSTI(52)=0
100 CONTINUE
IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
MINT(31)=0
MINT(39)=0
MINT(51)=0
MINT(57)=0
CALL PYRAND
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(51).EQ.2) RETURN
ISUB=MINT(1)
IF(MSTP(111).EQ.-1) GOTO 260
C...Loopback point if PYPREP fails, especially for junction topologies.
NPREP=0
MNT31S=MINT(31)
110 NPREP=NPREP+1
MINT(31)=MNT31S
IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
MINT31=MINT(31)
120 MINT(31)=MINT31
MINT(51)=0
CALL PYSCAT
IF(MINT(51).EQ.1) GOTO 100
IPU1=MINT(84)+1
IPU2=MINT(84)+2
IF(ISUB.EQ.95) GOTO 140
C...Reset statistics on activity in event.
DO 130 J=351,359
MINT(J)=0
VINT(J)=0D0
130 CONTINUE
C...Showering of initial state partons (optional).
NFIN=N
ALAMSV=PARJ(81)
PARJ(81)=PARP(72)
IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
& CALL PYSSPA(IPU1,IPU2)
PARJ(81)=ALAMSV
IF(MINT(51).EQ.1) GOTO 100
C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
PTMAX=0.5*SQRT(PARP(71))*VINT(55)
CALL PYPTFS(3,PTMAX,0D0,PTGEN)
ENDIF
C...Showering of final state partons (optional).
ALAMSV=PARJ(81)
PARJ(81)=PARP(72)
IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
& THEN
IPU3=MINT(84)+3
IPU4=MINT(84)+4
IF(ISET(ISUB).EQ.5) IPU4=-3
QMAX=VINT(55)
IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
CALL PYSHOW(IPU3,IPU4,QMAX)
ELSEIF(ISET(ISUB).EQ.11) THEN
CALL PYADSH(NFIN)
ENDIF
PARJ(81)=ALAMSV
C...Allow possibility for user to abort event generation.
IVETO=0
IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
IF(IVETO.EQ.1) GOTO 100
C...Decay of final state resonances.
MINT(32)=0
IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
IF(MINT(51).EQ.1) GOTO 100
MINT(52)=N
C...Multiple interactions - PYTHIA 6.3 intermediate style.
140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
CALL PYMIGN(6)
IF(MINT(51).EQ.1) GOTO 100
MINT(53)=N
C...Beam remnant flavour and colour assignments - new scheme.
CALL PYMIHK
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
& GOTO 120
IF(MINT(51).EQ.1) GOTO 100
C...Primordial kT and beam remnant momentum sharing - new scheme.
CALL PYMIRM
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
& GOTO 120
IF(MINT(51).EQ.1) GOTO 100
IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
C...Multiple interactions - PYTHIA 6.2 style.
ELSEIF(MINT(111).NE.12) THEN
IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
CALL PYMULT(6)
MINT(53)=N
ENDIF
C...Hadron remnants and primordial kT.
CALL PYREMN(IPU1,IPU2)
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
& 110
IF(MINT(51).EQ.1) GOTO 100
ENDIF
ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
CALL PYDIFF
ELSE
C...DIS scattering (photon flux external).
CALL PYDISG
IF(MINT(51).EQ.1) GOTO 100
ENDIF
C...Check that no odd resonance left undecayed.
MINT(54)=N
IF(MSTP(111).GE.1) THEN
NFIX=N
DO 150 I=MINT(84)+1,NFIX
IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
& K(I,2).NE.22) THEN
KCA=PYCOMP(K(I,2))
IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
CALL PYRESD(I)
IF(MINT(51).EQ.1) GOTO 100
ENDIF
ENDIF
150 CONTINUE
ENDIF
C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
C...Recalculate energies from momenta and masses (if desired).
IF(MSTP(113).GE.1) THEN
DO 160 I=MINT(83)+1,N
IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
& P(I,2)**2+P(I,3)**2+P(I,5)**2)
160 CONTINUE
NRECAL=N
ENDIF
C...Colour reconnection before string formation
IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
C...Rearrange partons along strings, check invariant mass cuts.
MSTU(28)=0
IF(MSTP(111).LE.0) MSTJ(14)=-1
CALL PYPREP(MINT(84)+1)
MSTJ(14)=MSTJ14
IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
MSTU(24)=0
GOTO 100
ENDIF
IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
IF (MINT(51).EQ.1) GOTO 100
IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
DO 190 I=MINT(84)+1,N
IF(K(I,2).EQ.94) THEN
DO 180 I1=I+1,MIN(N,I+10)
IF(K(I1,3).EQ.I) THEN
K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
IF(K(I1,3).EQ.0) THEN
DO 170 II=MINT(84)+1,I-1
IF(K(II,2).EQ.K(I1,2)) THEN
IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
& MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
ENDIF
170 CONTINUE
IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
ENDIF
ENDIF
180 CONTINUE
ENDIF
190 CONTINUE
CALL PYEDIT(12)
CALL PYEDIT(14)
IF(MSTP(125).EQ.0) CALL PYEDIT(15)
IF(MSTP(125).EQ.0) MINT(4)=0
DO 210 I=MINT(83)+1,N
IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
DO 200 I1=I+1,N
IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
IF(K(I1,3).EQ.I) K(I,5)=I1
200 CONTINUE
ENDIF
210 CONTINUE
ENDIF
C...Introduce separators between sections in PYLIST event listing.
IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
MSTU70=1
MSTU(71)=N
ELSEIF(IPILE.EQ.1) THEN
MSTU70=3
MSTU(71)=2
MSTU(72)=MINT(4)
MSTU(73)=N
ENDIF
C...Go back to lab frame (needed for vertices, also in fragmentation).
CALL PYFRAM(1)
C...Set nonvanishing production vertex (optional).
IF(MSTP(151).EQ.1) THEN
DO 220 J=1,4
VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
& SIN(PARU(2)*PYR(0))
220 CONTINUE
DO 240 I=MINT(83)+1,N
DO 230 J=1,4
V(I,J)=V(I,J)+VTX(J)
230 CONTINUE
240 CONTINUE
ENDIF
C...Perform hadronization (if desired).
IF(MSTP(111).GE.1) THEN
CALL PYEXEC
IF(MSTU(24).NE.0) GOTO 100
ENDIF
IF(MSTP(113).GE.1) THEN
DO 250 I=NRECAL,N
IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
& P(I,2)**2+P(I,3)**2+P(I,5)**2)
250 CONTINUE
ENDIF
IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
260 IF(IPILE.EQ.1) CALL PYDOCU
C...Set counters for current pileup event and loop to next one.
MSTI(41)=IPILE
IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
IF(MSTU70.LT.10) THEN
MSTU70=MSTU70+1
MSTU(70+MSTU70)=N
ENDIF
MINT(83)=N
MINT(84)=N+MSTP(126)
IF(IPILE.LT.NPILE) CALL PYFRAM(2)
270 CONTINUE
C...Generic information on pileup events. Reconstruct missing history.
IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
PARI(91)=VINT(132)
PARI(92)=VINT(133)
PARI(93)=VINT(134)
IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
ENDIF
CALL PYEDIT(16)
C...Transform to the desired coordinate frame.
280 CALL PYFRAM(MSTP(124))
MSTU(70)=MSTU70
PARU(21)=VINT(1)
C...Error messages
5100 FORMAT(1X,'Error: no subprocess switched on.'/
&1X,'Execution stopped.')
RETURN
END
C*********************************************************************
C...PYEVNW
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines for the new multiple interactions and
C...showering framework.
SUBROUTINE PYEVNW
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
& /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
C...Local arrays.
DIMENSION VTX(4)
C...Stop if no subprocesses on.
IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
WRITE(MSTU(11),5100)
CALL PYSTOP(1)
ENDIF
C...Initial values for some counters.
MSTU(1)=0
MSTU(2)=0
N=0
MINT(5)=MINT(5)+1
MINT(7)=0
MINT(8)=0
MINT(30)=0
MINT(83)=0
MINT(84)=MSTP(126)
MSTU(24)=0
MSTU70=0
MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCT/.
NCT=0
MINT(33)=0
C...Zero counters for pT-ordered showers (failsafe)
NPART=0
NPARTD=0
C...Let called routines know call is from PYEVNW (not PYEVNT).
MINT(35)=3
C...If variable energies: redo incoming kinematics and cross-section.
MSTI(61)=0
IF(MSTP(171).EQ.1) THEN
CALL PYINKI(1)
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(121).GT.1) CALL PYSAVE(3,1)
CALL PYXTOT
ENDIF
C...Loop over number of pileup events; check space left.
IF(MSTP(131).LE.0) THEN
NPILE=1
ELSE
CALL PYPILE(2)
NPILE=MINT(81)
ENDIF
DO 300 IPILE=1,NPILE
IF(MINT(84)+100.GE.MSTU(4)) THEN
CALL PYERRM(11,
& '(PYEVNW:) no more space in PYJETS for pileup events')
IF(MSTU(21).GE.1) GOTO 310
ENDIF
MINT(82)=IPILE
C...Generate variables of hard scattering.
MINT(51)=0
MSTI(52)=0
LOOPHS =0
100 CONTINUE
LOOPHS = LOOPHS + 1
IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
IF(LOOPHS.GE.10) THEN
CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
& //'multiple interactions. Returning.')
MINT(51)=1
RETURN
ENDIF
MINT(31)=0
MINT(39)=0
MINT(36)=0
MINT(51)=0
MINT(57)=0
CALL PYRAND
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(51).EQ.2) RETURN
ISUB=MINT(1)
IF(MSTP(111).EQ.-1) GOTO 290
C...Loopback point if PYPREP fails, especially for junction topologies.
NPREP=0
MNT31S=MINT(31)
110 NPREP=NPREP+1
MINT(31)=MNT31S
IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
MINT31=MINT(31)
120 MINT(31)=MINT31
MINT(51)=0
CALL PYSCAT
IF(MINT(51).EQ.1) GOTO 100
NPARTD=N
NFIN=N
C...Intertwined initial state showers and multiple interactions.
C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
MSTP61=MSTP(61)
IF (MINT(47).LT.2) MSTP(61)=0
MSTP81=MSTP(81)
IF (MINT(50).EQ.0) MSTP(81)=0
IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
& MINT(111).NE.12) THEN
C...Absolute max pT2 scale for evolution: phase space limit.
PT2MXS=0.25D0*VINT(2)
C...Check if more constrained by ISR and MI max scales:
PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
C...Loopback point in case of failure in evolution.
LOOP=0
130 LOOP=LOOP+1
MINT(51)=0
IF(LOOP.GT.100) THEN
CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
& //'multiple interactions. Trying new point.')
MINT(51)=1
RETURN
ENDIF
C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
C...once per event. (E.g. compute constants and save variables to be
C...restored later in case of failure.)
IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
C...Initialize interleaved MI/ISR/JI evolution.
C...PT2MAX: absolute upper limit for evolution - Initialization may
C... return a PT2MAX which is lower than this.
C...PT2MIN: absolute lower limit for evolution - Initialization may
C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
PT2MAX=PT2MXS
PT2MIN=0D0
CALL PYEVOL(0,PT2MAX,PT2MIN)
C...If failed to initialize evolution, generate a new hard process
IF (MINT(51).EQ.1) GOTO 100
C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
C...In principle factorized, so can be stopped and restarted.
C...Example: stop/start at pT=10 GeV. (Commented out for now.)
C PT2MED=MAX(10D0**2,PT2MIN)
C CALL PYEVOL(1,PT2MAX,PT2MED)
C IF (MINT(51).EQ.1) GOTO 160
C PT2MAX=PT2MED
CALL PYEVOL(1,PT2MAX,PT2MIN)
C...If fatal error (e.g., massive hard-process initiator, but no available
C...phase space for creation), generate a new hard process
IF (MINT(51).EQ.2) GOTO 100
C...If smaller error, just try running evolution again
IF (MINT(51).EQ.1) GOTO 130
C...Finalize interleaved MI/ISR/JI evolution.
CALL PYEVOL(2,PT2MAX,PT2MIN)
IF (MINT(51).EQ.1) GOTO 130
ENDIF
MSTP(61)=MSTP61
MSTP(81)=MSTP81
IF(MINT(51).EQ.1) GOTO 100
C...(MINT(52) is actually obsolete in this routine. Set anyway
C...to ensure PYDOCU stable.)
MINT(52)=N
MINT(53)=N
C...Beam remnants - new scheme.
140 IF(MINT(50).EQ.1) THEN
IF (ISUB.EQ.95) MINT(31)=1
C...Beam remnant flavour and colour assignments - new scheme.
CALL PYMIHK
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
& GOTO 120
IF(MINT(51).EQ.1) GOTO 100
C...Primordial kT and beam remnant momentum sharing - new scheme.
CALL PYMIRM
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
& GOTO 120
IF(MINT(51).EQ.1) GOTO 100
IF (ISUB.EQ.95) MINT(31)=0
ELSEIF(MINT(111).NE.12) THEN
C...Hadron remnants and primordial kT - old model.
C...Happens e.g. for direct photon on one side.
IPU1=IMI(1,1,1)
IPU2=IMI(2,1,1)
CALL PYREMN(IPU1,IPU2)
IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
& 110
IF(MINT(51).EQ.1) GOTO 100
C...PYREMN does not set colour tags for BRs, so needs to be done now.
DO 160 I=MINT(53)+1,N
DO 150 KCS=4,5
IDA=MOD(K(I,KCS),MSTU(5))
IF (IDA.NE.0) THEN
MCT(I,KCS-3)=MCT(IDA,6-KCS)
ELSE
MCT(I,KCS-3)=0
ENDIF
150 CONTINUE
160 CONTINUE
C...Instruct PYPREP to use colour tags
MINT(33)=1
DO 360 MQGST=1,2
DO 350 I=MINT(84)+1,N
C...Look for coloured string endpoint, or (later) leftover gluon.
IF (K(I,1).NE.3) GOTO 350
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 350
KQ=KCHG(KC,2)
IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
C... Pick up loose string end with no previous tag.
KCS=4
IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
IF(MCT(I,KCS-3).NE.0) GOTO 350
CALL PYCTTR(I,KCS,I)
IF(MINT(51).NE.0) RETURN
350 CONTINUE
360 CONTINUE
C...Now delete any colour processing information if set (since partons
C...otherwise not FS showered!)
DO 170 I=MINT(84)+1,N
IF (I.LE.N) THEN
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
ENDIF
170 CONTINUE
ENDIF
C...Showering of final state partons (optional).
ALAMSV=PARJ(81)
PARJ(81)=PARP(72)
IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
& THEN
QMAX=VINT(55)
IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
CALL PYPTFS(1,QMAX,0D0,PTGEN)
C...External processes: handle successive showers.
ELSEIF(ISET(ISUB).EQ.11) THEN
CALL PYADSH(NFIN)
ENDIF
PARJ(81)=ALAMSV
C...Allow possibility for user to abort event generation.
IVETO=0
IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
IF(IVETO.EQ.1) THEN
C...........No reason to count this as an error
LOOPHS = LOOPHS-1
GOTO 100
ENDIF
C...Decay of final state resonances.
MINT(32)=0
IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
CALL PYRESD(0)
IF(MINT(51).NE.0) GOTO 100
ENDIF
IF(MINT(51).EQ.1) GOTO 100
ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
CALL PYDIFF
ELSE
C...DIS scattering (photon flux external).
CALL PYDISG
IF(MINT(51).EQ.1) GOTO 100
ENDIF
C...Check that no odd resonance left undecayed.
MINT(54)=N
IF(MSTP(111).GE.1) THEN
NFIX=N
DO 180 I=MINT(84)+1,NFIX
IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
& K(I,2).NE.22) THEN
KCA=PYCOMP(K(I,2))
IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
CALL PYRESD(I)
IF(MINT(51).EQ.1) GOTO 100
ENDIF
ENDIF
180 CONTINUE
ENDIF
C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
C...Recalculate energies from momenta and masses (if desired).
IF(MSTP(113).GE.1) THEN
DO 190 I=MINT(83)+1,N
IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
& P(I,2)**2+P(I,3)**2+P(I,5)**2)
190 CONTINUE
NRECAL=N
ENDIF
C...Colour reconnection before string formation
CALL PYFSCR(MINT(84)+1)
C...Rearrange partons along strings, check invariant mass cuts.
MSTU(28)=0
IF(MSTP(111).LE.0) MSTJ(14)=-1
CALL PYPREP(MINT(84)+1)
MSTJ(14)=MSTJ14
IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
MSTU(24)=0
GOTO 100
ENDIF
IF(MINT(51).EQ.1) GOTO 110
IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
DO 220 I=MINT(84)+1,N
IF(K(I,2).EQ.94) THEN
DO 210 I1=I+1,MIN(N,I+10)
IF(K(I1,3).EQ.I) THEN
K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
IF(K(I1,3).EQ.0) THEN
DO 200 II=MINT(84)+1,I-1
IF(K(II,2).EQ.K(I1,2)) THEN
IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
& MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
ENDIF
200 CONTINUE
IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
ENDIF
ENDIF
210 CONTINUE
C...Also collapse particles decaying to themselves (if same KS)
C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
C...problem with history point-backs in new shower, where a particle is
C...copied with a new momentum when it is the recoiler.
C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
C & .AND.K(I,4).LT.N) THEN
C IDA=K(I,4)
C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
C K(I,1)=0
C ENDIF
ENDIF
220 CONTINUE
CALL PYEDIT(12)
CALL PYEDIT(14)
IF(MSTP(125).EQ.0) CALL PYEDIT(15)
IF(MSTP(125).EQ.0) MINT(4)=0
DO 240 I=MINT(83)+1,N
IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
DO 230 I1=I+1,N
IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
IF(K(I1,3).EQ.I) K(I,5)=I1
230 CONTINUE
ENDIF
240 CONTINUE
ENDIF
C...Introduce separators between sections in PYLIST event listing.
IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
MSTU70=1
MSTU(71)=N
ELSEIF(IPILE.EQ.1) THEN
MSTU70=3
MSTU(71)=2
MSTU(72)=MINT(4)
MSTU(73)=N
ENDIF
C...Go back to lab frame (needed for vertices, also in fragmentation).
CALL PYFRAM(1)
C...Set nonvanishing production vertex (optional).
IF(MSTP(151).EQ.1) THEN
DO 250 J=1,4
VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
& SIN(PARU(2)*PYR(0))
250 CONTINUE
DO 270 I=MINT(83)+1,N
DO 260 J=1,4
V(I,J)=V(I,J)+VTX(J)
260 CONTINUE
270 CONTINUE
ENDIF
C...Perform hadronization (if desired).
IF(MSTP(111).GE.1) THEN
CALL PYEXEC
IF(MSTU(24).NE.0) GOTO 100
ENDIF
IF(MSTP(113).GE.1) THEN
DO 280 I=NRECAL,N
IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
& P(I,2)**2+P(I,3)**2+P(I,5)**2)
280 CONTINUE
ENDIF
IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
290 IF(IPILE.EQ.1) CALL PYDOCU
C...Set counters for current pileup event and loop to next one.
MSTI(41)=IPILE
IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
IF(MSTU70.LT.10) THEN
MSTU70=MSTU70+1
MSTU(70+MSTU70)=N
ENDIF
MINT(83)=N
MINT(84)=N+MSTP(126)
IF(IPILE.LT.NPILE) CALL PYFRAM(2)
300 CONTINUE
C...Generic information on pileup events. Reconstruct missing history.
IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
PARI(91)=VINT(132)
PARI(92)=VINT(133)
PARI(93)=VINT(134)
IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
ENDIF
CALL PYEDIT(16)
C...Transform to the desired coordinate frame.
310 CALL PYFRAM(MSTP(124))
MSTU(70)=MSTU70
PARU(21)=VINT(1)
C...Error messages
5100 FORMAT(1X,'Error: no subprocess switched on.'/
&1X,'Execution stopped.')
RETURN
END
C***********************************************************************
C...PYSTAT
C...Prints out information about cross-sections, decay widths, branching
C...ratios, kinematical limits, status codes and parameter values.
SUBROUTINE PYSTAT(MSTAT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
PARAMETER (EPS=1D-3)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28, CHTMP*16
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
C...Local arrays, character variables and data.
DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
&CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
&PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
CHARACTER*24 CHD0, CHDC(10)
CHARACTER*6 DNAME(3)
DATA PROGA/
&'VMD/hadron * VMD ','VMD/hadron * direct ',
&'VMD/hadron * anomalous ','direct * direct ',
&'direct * anomalous ','anomalous * anomalous '/
DATA DISGA/'e * VMD','e * anomalous'/
DATA PROGG9/
&'direct * direct ','direct * VMD ',
&'direct * anomalous ','VMD * direct ',
&'VMD * VMD ','VMD * anomalous ',
&'anomalous * direct ','anomalous * VMD ',
&'anomalous * anomalous ','DIS * VMD ',
&'DIS * anomalous ','VMD * DIS ',
&'anomalous * DIS '/
DATA PROGG4/
&'direct * direct ','direct * resolved ',
&'resolved * direct ','resolved * resolved '/
DATA PROGG2/
&'direct * hadron ','resolved * hadron '/
DATA PROGP4/
&'VMD * hadron ','direct * hadron ',
&'anomalous * hadron ','DIS * hadron '/
DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
&CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
&'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
&' y*_small ',' eta*_large ',' eta*_small ',
&'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
&' x_2 ',' x_F ',' cos(theta_hard) ',
&'m''_hard (GeV/c^2) ',' tau ',' y* ',
&'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
&' tau'' '/
DATA DNAME /'q ','lepton','nu '/
C...Cross-sections.
IF(MSTAT.LE.1) THEN
IF(MINT(121).GT.1) CALL PYSAVE(5,0)
WRITE(MSTU(11),5000)
WRITE(MSTU(11),5100)
WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
DO 100 I=1,500
IF(MSUB(I).NE.1) GOTO 100
WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
100 CONTINUE
IF(MINT(121).GT.1) THEN
WRITE(MSTU(11),5300)
DO 110 IGA=1,MINT(121)
CALL PYSAVE(3,IGA)
IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ELSEIF(MINT(121).EQ.4) THEN
WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ELSEIF(MINT(121).EQ.2) THEN
WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ELSE
WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
& XSEC(0,3)
ENDIF
110 CONTINUE
CALL PYSAVE(5,0)
ENDIF
WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
& 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
C...Decay widths and branching ratios.
ELSEIF(MSTAT.EQ.2) THEN
WRITE(MSTU(11),5500)
WRITE(MSTU(11),5600)
DO 140 KC=1,500
KF=KCHG(KC,4)
CALL PYNAME(KF,CHKF)
IOFF=0
IF(KC.LE.22) THEN
IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
ELSE
IF(MWID(KC).LE.0) GOTO 140
IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
& KF/KSUSY1.EQ.2)) GOTO 140
ENDIF
C...Off-shell branchings.
IF(IOFF.EQ.1) THEN
NGP=0
IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
& PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
DO 120 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
NGP1=0
IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
& (MOD(IABS(KFDP(IDC,1)),10)+1)/2
NGP2=0
IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
& (MOD(IABS(KFDP(IDC,2)),10)+1)/2
CALL PYNAME(KFDP(IDC,1),CHD1)
CALL PYNAME(KFDP(IDC,2),CHD2)
IF(KFDP(IDC,3).EQ.0) THEN
IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
& NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
& CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
ELSE
CALL PYNAME(KFDP(IDC,3),CHD3)
IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
& NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
& CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
ENDIF
120 CONTINUE
C...On-shell decays.
ELSE
CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
BRFIN=1D0
IF(WDTE(0,0).LE.0D0) BRFIN=0D0
WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
& STATE(MDCY(KC,1)),BRFIN
DO 130 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
NGP1=0
IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
& (MOD(IABS(KFDP(IDC,1)),10)+1)/2
NGP2=0
IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
& (MOD(IABS(KFDP(IDC,2)),10)+1)/2
BRPRI=0D0
IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
BRFIN=0D0
IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
CALL PYNAME(KFDP(IDC,1),CHD1)
CALL PYNAME(KFDP(IDC,2),CHD2)
IF(KFDP(IDC,3).EQ.0) THEN
IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
& WRITE(MSTU(11),5800) IDC,CHD1(1:10),
& CHD2(1:10),WDTP(J),BRPRI,
& STATE(MDME(IDC,1)),BRFIN
ELSE
CALL PYNAME(KFDP(IDC,3),CHD3)
IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
& WRITE(MSTU(11),5900) IDC,CHD1(1:10),
& CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
& STATE(MDME(IDC,1)),BRFIN
ENDIF
130 CONTINUE
ENDIF
140 CONTINUE
WRITE(MSTU(11),6000)
C...Allowed incoming partons/particles at hard interaction.
ELSEIF(MSTAT.EQ.3) THEN
WRITE(MSTU(11),6100)
CALL PYNAME(MINT(11),CHAU)
CHIN(1)=CHAU(1:12)
CALL PYNAME(MINT(12),CHAU)
CHIN(2)=CHAU(1:12)
WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
DO 150 I=-20,22
IF(I.EQ.0) GOTO 150
IA=IABS(I)
IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
CALL PYNAME(I,CHAU)
WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
& STATE(KFIN(2,I))
150 CONTINUE
WRITE(MSTU(11),6400)
C...User-defined limits on kinematical variables.
ELSEIF(MSTAT.EQ.4) THEN
WRITE(MSTU(11),6500)
WRITE(MSTU(11),6600)
SHRMAX=CKIN(2)
IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
PTHMIN=MAX(CKIN(3),CKIN(5))
PTHMAX=CKIN(4)
IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
DO 160 I=4,14
WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
160 CONTINUE
SPRMAX=CKIN(32)
IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
WRITE(MSTU(11),7000)
C...Status codes and parameter values.
ELSEIF(MSTAT.EQ.5) THEN
WRITE(MSTU(11),7100)
WRITE(MSTU(11),7200)
DO 170 I=1,100
WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
& PARP(100+I)
170 CONTINUE
C...List of all processes implemented in the program.
ELSEIF(MSTAT.EQ.6) THEN
WRITE(MSTU(11),7400)
WRITE(MSTU(11),7500)
DO 180 I=1,500
IF(ISET(I).LT.0) GOTO 180
WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
180 CONTINUE
WRITE(MSTU(11),7700)
ELSEIF(MSTAT.EQ.7) THEN
WRITE (MSTU(11),8000)
NMODES(0)=0
NMODES(10)=0
NMODES(9)=0
DO 290 ILR=1,2
DO 280 KFSM=1,16
KFSUSY=ILR*KSUSY1+KFSM
NRVDC=0
C...SDOWN DECAYS
IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
NRVDC=3
DO 190 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
190 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 200 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
IF (KFDP(IDC,3).EQ.0) THEN
IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
PBRAT(3)=PBRAT(3)+BRAT(IDC)
NMODES(3)=NMODES(3)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
ENDIF
200 CONTINUE
ENDIF
C...SUP DECAYS
IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
NRVDC=2
DO 210 I=1,NRVDC
NMODES(I)=0
PBRAT(I)=0D0
210 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 220 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
IF (KFDP(IDC,3).EQ.0) THEN
IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
ENDIF
220 CONTINUE
ENDIF
C...SLEPTON DECAYS
IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
NRVDC=2
DO 230 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
230 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 240 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
IF (KFDP(IDC,3).EQ.0) THEN
IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
& .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
ENDIF
240 CONTINUE
ENDIF
C...SNEUTRINO DECAYS
IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
& THEN
NRVDC=2
DO 250 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
250 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 260 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
IF (KFDP(IDC,3).EQ.0) THEN
IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
& .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
NMODES(2)=NMODES(2)+1
PBRAT(2)=PBRAT(2)+BRAT(IDC)
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
ENDIF
260 CONTINUE
ENDIF
IF (NRVDC.NE.0) THEN
DO 270 I=1,NRVDC
WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
NMODES(0)=NMODES(0)+NMODES(I)
270 CONTINUE
ENDIF
280 CONTINUE
290 CONTINUE
DO 370 KFSM=21,37
KFSUSY=KSUSY1+KFSM
NRVDC=0
C...NEUTRALINO DECAYS
IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
NRVDC=4
DO 300 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
300 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 310 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
ID3=IABS(KFDP(IDC,3))
IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
& .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
& .ID3.EQ.13.OR.ID3.EQ.15)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
& .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
& .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(3)=PBRAT(3)+BRAT(IDC)
NMODES(3)=NMODES(3)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
& .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(4)=PBRAT(4)+BRAT(IDC)
NMODES(4)=NMODES(4)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
310 CONTINUE
ENDIF
C...CHARGINO DECAYS
IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
NRVDC=5
DO 320 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
320 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 330 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
ID3=IABS(KFDP(IDC,3))
IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
& .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
& .ID3.EQ.14.OR.ID3.EQ.16)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
& .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
& .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
& .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
& .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
PBRAT(3)=PBRAT(3)+BRAT(IDC)
NMODES(3)=NMODES(3)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
& .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(3)=PBRAT(3)+BRAT(IDC)
NMODES(3)=NMODES(3)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
& .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
PBRAT(4)=PBRAT(4)+BRAT(IDC)
NMODES(4)=NMODES(4)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
& .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(4)=PBRAT(4)+BRAT(IDC)
NMODES(4)=NMODES(4)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
& .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(5)=PBRAT(5)+BRAT(IDC)
NMODES(5)=NMODES(5)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
& .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(5)=PBRAT(5)+BRAT(IDC)
NMODES(5)=NMODES(5)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
330 CONTINUE
ENDIF
C...GLUINO DECAYS
IF (KFSM.EQ.21) THEN
NRVDC=3
DO 340 I=1,NRVDC
PBRAT(I)=0D0
NMODES(I)=0
340 CONTINUE
CALL PYNAME(KFSUSY,CHTMP)
CHD0=CHTMP//' '
CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
KC=PYCOMP(KFSUSY)
DO 350 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
ID1=IABS(KFDP(IDC,1))
ID2=IABS(KFDP(IDC,2))
ID3=IABS(KFDP(IDC,3))
IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
& .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
& .ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(1)=PBRAT(1)+BRAT(IDC)
NMODES(1)=NMODES(1)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
& .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
& .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(2)=PBRAT(2)+BRAT(IDC)
NMODES(2)=NMODES(2)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
& .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
& .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
PBRAT(3)=PBRAT(3)+BRAT(IDC)
NMODES(3)=NMODES(3)+1
IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
ENDIF
350 CONTINUE
ENDIF
IF (NRVDC.NE.0) THEN
DO 360 I=1,NRVDC
WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
NMODES(0)=NMODES(0)+NMODES(I)
360 CONTINUE
ENDIF
370 CONTINUE
WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
WRITE (MSTU(11),8500)
DO 400 IRV=1,3
DO 390 JRV=1,3
DO 380 KRV=1,3
WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
& ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
380 CONTINUE
390 CONTINUE
400 CONTINUE
WRITE (MSTU(11),8600)
ENDIF
ENDIF
C...Formats for printouts.
5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
&'Events and Cross-sections',1X,9('*'))
5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
&'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
&'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
&'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
&'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
&'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
&'I',12X,'I')
5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
&D10.3,1X,'I')
5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
&1X,'I',34X,'I',28X,'I',12X,'I')
5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
&1X,'********* Total number of errors, excluding junctions =',
&1X,I8,' *************'/
&1X,'********* Total number of errors, including junctions =',
&1X,I8,' *************'/
&1X,'********* Total number of warnings = ',
&1X,I8,' *************'/
&1X,'********* Fraction of events that fail fragmentation ',
&'cuts =',1X,F8.5,' *********'/)
5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
&'Ratios',1X,27('*'))
5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
&1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
&'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
&'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
&1X,98('='))
5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
&I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
&'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
&1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
&1P,D10.3,0P,1X,'I')
5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
&1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
&1P,D10.3,0P,1X,'I')
6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
&'Particles at Hard Interaction',1X,7('*'))
6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
&'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
&'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
&'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
&78('=')/1X,'I',38X,'I',37X,'I')
6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
&'Kinematical Variables',1X,12('*'))
6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
&16X,'I')
6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
&1X,'<',1X,1P,D10.3,0P,16X,'I')
6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
&'Parameter Values',1X,12('*'))
7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
&'PARP(I)'/)
7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
&1X,13('*'))
7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
&'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
&'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
8000 FORMAT(1X/ 1X/
& 17X,'Sums over R-Violating branching ratios',1X/ 1X
& /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
& ,'Mother --> Sum over final state flavours',4X,'I',2X
& ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
& /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
& ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
& 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
& ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
& /1X,70('='))
8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
& 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
8500 FORMAT(1X/ 1X/
& 1X,'R-Violating couplings',1X/ 1X /
& 1X,55('=')/
& 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
& ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
& ,'I',15X,'I',15X,'I',15X,'I')
8600 FORMAT(1X,55('='))
8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
& ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
RETURN
END
C*********************************************************************
C...PYUPEV
C...Administers the hard-process generation required for output to the
C...Les Houches event record.
SUBROUTINE PYUPEV
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT4/
C...HEPEUP for output.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Stop if no subprocesses on.
IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
WRITE(MSTU(11),5100)
STOP
ENDIF
C...Special flags for hard-process generation only.
MSTP71=MSTP(71)
MSTP(71)=0
MST128=MSTP(128)
MSTP(128)=1
C...Initial values for some counters.
N=0
MINT(5)=MINT(5)+1
MINT(7)=0
MINT(8)=0
MINT(30)=0
MINT(83)=0
MINT(84)=MSTP(126)
MSTU(24)=0
MSTU70=0
MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
MINT(33)=0
C...If variable energies: redo incoming kinematics and cross-section.
MSTI(61)=0
IF(MSTP(171).EQ.1) THEN
CALL PYINKI(1)
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(121).GT.1) CALL PYSAVE(3,1)
CALL PYXTOT
ENDIF
C...Do not allow pileup events.
MINT(82)=1
C...Generate variables of hard scattering.
MINT(51)=0
MSTI(52)=0
100 CONTINUE
IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
MINT(31)=0
MINT(51)=0
MINT(57)=0
CALL PYRAND
IF(MSTI(61).EQ.1) THEN
MINT(5)=MINT(5)-1
RETURN
ENDIF
IF(MINT(51).EQ.2) RETURN
ISUB=MINT(1)
IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
MINT31=MINT(31)
110 MINT(31)=MINT31
MINT(51)=0
CALL PYSCAT
IF(MINT(51).EQ.1) GOTO 100
IPU1=MINT(84)+1
IPU2=MINT(84)+2
C...Decay of final state resonances.
MINT(32)=0
IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
& CALL PYRESD(0)
IF(MINT(51).EQ.1) GOTO 100
MINT(52)=N
C...Longitudinal boost of hard scattering.
BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
CALL PYDIFF
ELSE
C...DIS scattering (photon flux external).
CALL PYDISG
IF(MINT(51).EQ.1) GOTO 100
ENDIF
C...Check that no odd resonance left undecayed.
MINT(54)=N
NFIX=N
DO 120 I=MINT(84)+1,NFIX
IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
& K(I,2).NE.22) THEN
KCA=PYCOMP(K(I,2))
IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
CALL PYRESD(I)
IF(MINT(51).EQ.1) GOTO 100
ENDIF
ENDIF
120 CONTINUE
C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
130 CALL PYDOCU
C...Transform to the desired coordinate frame.
140 CALL PYFRAM(MSTP(124))
MSTU(70)=MSTU70
PARU(21)=VINT(1)
C...Restore special flags for hard-process generation only.
MSTP(71)=MSTP71
MSTP(128)=MST128
C...Trace colour tags; convert to LHA style labels.
NCT=100
DO 150 I=MINT(84)+1,N
MCT(I,1)=0
MCT(I,2)=0
150 CONTINUE
DO 160 I=MINT(84)+1,N
KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
& THEN
IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
IDA=MOD(K(I,4),MSTU(5))
IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
& MCT(IMO,2).NE.0) THEN
MCT(I,1)=MCT(IMO,2)
ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
& MCT(IMO,1).NE.0) THEN
MCT(I,1)=MCT(IMO,1)
ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
& MCT(IDA,2).NE.0) THEN
MCT(I,1)=MCT(IDA,2)
ELSE
NCT=NCT+1
MCT(I,1)=NCT
ENDIF
ENDIF
IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
& THEN
IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
IDA=MOD(K(I,5),MSTU(5))
IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
& MCT(IMO,1).NE.0) THEN
MCT(I,2)=MCT(IMO,1)
ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
& MCT(IMO,2).NE.0) THEN
MCT(I,2)=MCT(IMO,2)
ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
& MCT(IDA,1).NE.0) THEN
MCT(I,2)=MCT(IDA,1)
ELSE
NCT=NCT+1
MCT(I,2)=NCT
ENDIF
ENDIF
ENDIF
160 CONTINUE
C...Put event in HEPEUP commonblock.
NUP=N-MINT(84)
IDPRUP=MINT(1)
XWGTUP=1D0
SCALUP=VINT(53)
AQEDUP=VINT(57)
AQCDUP=VINT(58)
DO 180 I=1,NUP
IDUP(I)=K(I+MINT(84),2)
IF(I.LE.2) THEN
ISTUP(I)=-1
MOTHUP(1,I)=0
MOTHUP(2,I)=0
ELSEIF(K(I+4,3).EQ.0) THEN
ISTUP(I)=1
MOTHUP(1,I)=1
MOTHUP(2,I)=2
ELSE
ISTUP(I)=1
MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
MOTHUP(2,I)=0
ENDIF
IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
& ISTUP(K(I+MINT(84),3)-MINT(84))=2
ICOLUP(1,I)=MCT(I+MINT(84),1)
ICOLUP(2,I)=MCT(I+MINT(84),2)
DO 170 J=1,5
PUP(J,I)=P(I+MINT(84),J)
170 CONTINUE
VTIMUP(I)=V(I,5)
SPINUP(I)=9D0
180 CONTINUE
C...Optionally write out event to disk. Minimal size for time/spin fields.
IF(MSTP(162).GT.0) THEN
WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
DO 190 I=1,NUP
IF(VTIMUP(I).EQ.0D0) THEN
WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
& MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
& ' 0. 9.'
ELSE
WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
& MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
& VTIMUP(I),' 9.'
ENDIF
190 CONTINUE
C...Optional extra line with parton-density information.
IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
& PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
ENDIF
C...Error messages and other print formats.
5100 FORMAT(1X,'Error: no subprocess switched on.'/
&1X,'Execution stopped.')
5200 FORMAT(1P,2I6,4E14.6)
5300 FORMAT(1P,I8,5I5,5E18.10,A6)
5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
RETURN
END
C*********************************************************************
C...PYUPIN
C...Fills the HEPRUP commonblock with info on incoming beams and allowed
C...processes, and optionally stores that information on file.
SUBROUTINE PYUPIN
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Store info on incoming beams.
IDBMUP(1)=K(1,2)
IDBMUP(2)=K(2,2)
EBMUP(1)=P(1,4)
EBMUP(2)=P(2,4)
PDFGUP(1)=0
PDFGUP(2)=0
PDFSUP(1)=MSTP(51)
PDFSUP(2)=MSTP(51)
C...Event weighting strategy.
IDWTUP=3
C...Info on individual processes.
NPRUP=0
DO 100 ISUB=1,500
IF(MSUB(ISUB).EQ.1) THEN
NPRUP=NPRUP+1
XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
XMAXUP(NPRUP)=1D0
LPRUP(NPRUP)=ISUB
ENDIF
100 CONTINUE
C...Write info to file.
IF(MSTP(161).GT.0) THEN
WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
& PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
DO 110 IPR=1,NPRUP
WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
& LPRUP(IPR)
110 CONTINUE
ENDIF
C...Formats for printout.
5100 FORMAT(1P,2I8,2E14.6,6I6)
5200 FORMAT(1P,3E14.6,I6)
RETURN
END
C*********************************************************************
C...Combine the two old-style Pythia initialization and event files
C...into a single Les Houches Event File.
SUBROUTINE PYLHEF
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...PYTHIA commonblock: only used to provide read/write units and version.
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYPARS/
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...User process event common block.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Lines to read in assumed never longer than 200 characters.
PARAMETER (MAXLEN=200)
CHARACTER*(MAXLEN) STRING
C...Format for reading lines.
CHARACTER*6 STRFMT
STRFMT='(A000)'
WRITE(STRFMT(3:5),'(I3)') MAXLEN
C...Rewind initialization and event files.
REWIND MSTP(161)
REWIND MSTP(162)
C...Write header info.
WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
WRITE(MSTP(163),'(A)') '<!--'
WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
&MSTP(181),'.',MSTP(182)
WRITE(MSTP(163),'(A)') '-->'
C...Read first line of initialization info and get number of processes.
READ(MSTP(161),'(A)',END=400,ERR=400) STRING
READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
&EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
C...Copy initialization lines, omitting trailing blanks.
C...Embed in <init> ... </init> block.
WRITE(MSTP(163),'(A)') '<init>'
DO 140 IPR=0,NPRUP
IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
LEN=MAXLEN+1
120 LEN=LEN-1
IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
140 CONTINUE
WRITE(MSTP(163),'(A)') '</init>'
C...Begin event loop. Read first line of event info or already done.
READ(MSTP(162),'(A)',END=320,ERR=400) STRING
200 CONTINUE
C...Look at first line to know number of particles in event.
READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
C...Begin an <event> block. Copy event lines, omitting trailing blanks.
WRITE(MSTP(163),'(A)') '<event>'
DO 240 I=0,NUP
IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
LEN=MAXLEN+1
220 LEN=LEN-1
IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
240 CONTINUE
C...Copy trailing comment lines - with a # in the first column - as is.
260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
IF(STRING(1:1).EQ.'#') THEN
LEN=MAXLEN+1
280 LEN=LEN-1
IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
GOTO 260
ENDIF
C..End the <event> block. Loop back to look for next event.
WRITE(MSTP(163),'(A)') '</event>'
GOTO 200
C...Successfully reached end of event loop: write closing tag
C...and remove temporary intermediate files (unless asked not to).
300 WRITE(MSTP(163),'(A)') '</event>'
320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
IF(MSTP(164).EQ.1) RETURN
CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
RETURN
C...Error exit.
400 WRITE(*,*) ' PYLHEF file joining failed!'
RETURN
END
C*********************************************************************
C...PYINRE
C...Calculates full and effective widths of gauge bosons, stores
C...masses and widths, rescales coefficients to be used for
C...resonance production generation.
SUBROUTINE PYINRE
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
C...Local arrays and data.
CHARACTER PRTMP*9
DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
&WDTEM(0:400,0:5),KCORD(500),PMORD(500)
C...Born level couplings in MSSM Higgs doublet sector.
XW=PARU(102)
XWV=XW
IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
XW1=1D0-XW
IF(MSTP(4).EQ.2) THEN
TANBE=PARU(141)
RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
SQMH=PMAS(25,1)**2
SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
SQMHC=SQMA+SQMW
IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
WRITE(MSTU(11),5000)
CALL PYSTOP(101)
ENDIF
PMAS(35,1)=SQRT(SQMHP)
PMAS(36,1)=SQRT(SQMA)
PMAS(37,1)=SQRT(SQMHC)
ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
& (SQMA-SQMZ)))
BESU=ATAN(TANBE)
PARU(142)=1D0
PARU(143)=1D0
PARU(161)=-SIN(ALSU)/COS(BESU)
PARU(162)=COS(ALSU)/SIN(BESU)
PARU(163)=PARU(161)
PARU(164)=SIN(BESU-ALSU)
PARU(165)=PARU(164)
PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
PARU(171)=COS(ALSU)/COS(BESU)
PARU(172)=SIN(ALSU)/SIN(BESU)
PARU(173)=PARU(171)
PARU(174)=COS(BESU-ALSU)
PARU(175)=PARU(174)
PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
& SIN(BESU+ALSU)
PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
PARU(181)=TANBE
PARU(182)=1D0/TANBE
PARU(183)=PARU(181)
PARU(184)=0D0
PARU(185)=PARU(184)
PARU(186)=COS(BESU-ALSU)
PARU(187)=SIN(BESU-ALSU)
PARU(188)=PARU(186)
PARU(189)=PARU(187)
PARU(190)=0D0
PARU(195)=COS(BESU-ALSU)
ENDIF
C...Reset effective widths of gauge bosons.
DO 110 I=1,500
DO 100 J=1,5
WIDS(I,J)=1D0
100 CONTINUE
110 CONTINUE
C...Order resonances by increasing mass (except Z0 and W+/-).
NRES=0
DO 140 KC=1,500
KF=KCHG(KC,4)
IF(KF.EQ.0) GOTO 140
IF(MWID(KC).EQ.0) GOTO 140
IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
IF(MSTP(1).LE.3) GOTO 140
ENDIF
IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
IF(IMSS(1).LE.0) GOTO 140
ENDIF
NRES=NRES+1
PMRES=PMAS(KC,1)
IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
DO 120 I1=NRES-1,1,-1
IF(PMRES.GE.PMORD(I1)) GOTO 130
KCORD(I1+1)=KCORD(I1)
PMORD(I1+1)=PMORD(I1)
120 CONTINUE
130 KCORD(I1+1)=KC
PMORD(I1+1)=PMRES
140 CONTINUE
C...Loop over possible resonances.
DO 180 I=1,NRES
KC=KCORD(I)
KF=KCHG(KC,4)
C...Check that no fourth generation channels on by mistake.
IF(MSTP(1).LE.3) THEN
DO 150 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
KFA1=IABS(KFDP(IDC,1))
KFA2=IABS(KFDP(IDC,2))
IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
& KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
& MDME(IDC,1)=-1
150 CONTINUE
ENDIF
C...Check that no supersymmetric channels on by mistake.
IF(IMSS(1).LE.0) THEN
DO 160 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
KFA1S=IABS(KFDP(IDC,1))/KSUSY1
KFA2S=IABS(KFDP(IDC,2))/KSUSY1
IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
& MDME(IDC,1)=-1
160 CONTINUE
ENDIF
C...Find mass and evaluate width.
PMR=PMAS(KC,1)
IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
IF(MWID(KC).EQ.3) MINT(63)=1
CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
MINT(51)=0
C...Evaluate suppression factors due to non-simulated channels.
IF(KCHG(KC,3).EQ.0) THEN
WDTP0I=0D0
IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
& 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
& 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
WIDS(KC,3)=0D0
WIDS(KC,4)=0D0
WIDS(KC,5)=0D0
ELSE
IF(MWID(KC).EQ.3) MINT(63)=1
CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
MINT(51)=0
WDTP0I=0D0
IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
& (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
& (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
& WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
& 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
& 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
& 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
& 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
ENDIF
C...Set resonance widths and branching ratios;
C...also on/off switch for decays.
IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
PMAS(KC,2)=WDTP(0)
PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
DO 170 J=1,MDCY(KC,3)
IDC=J+MDCY(KC,2)-1
BRAT(IDC)=0D0
IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
170 CONTINUE
ENDIF
180 CONTINUE
C...Flavours of leptoquark: redefine charge and name.
KFLQQ=KFDP(MDCY(42,2),1)
KFLQL=KFDP(MDCY(42,2),2)
KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
&KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
LL=1
IF(IABS(KFLQL).EQ.13) LL=2
IF(IABS(KFLQL).EQ.15) LL=3
CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
&CHAF(IABS(KFLQL),1)(1:LL)//' '
CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
C...Special cases in treatment of gamma*/Z0: redefine process name.
IF(MSTP(43).EQ.1) THEN
PROC(1)='f + fbar -> gamma*'
PROC(15)='f + fbar -> g + gamma*'
PROC(19)='f + fbar -> gamma + gamma*'
PROC(30)='f + g -> f + gamma*'
PROC(35)='f + gamma -> f + gamma*'
ELSEIF(MSTP(43).EQ.2) THEN
PROC(1)='f + fbar -> Z0'
PROC(15)='f + fbar -> g + Z0'
PROC(19)='f + fbar -> gamma + Z0'
PROC(30)='f + g -> f + Z0'
PROC(35)='f + gamma -> f + Z0'
ELSEIF(MSTP(43).EQ.3) THEN
PROC(1)='f + fbar -> gamma*/Z0'
PROC(15)='f + fbar -> g + gamma*/Z0'
PROC(19)='f+ fbar -> gamma + gamma*/Z0'
PROC(30)='f + g -> f + gamma*/Z0'
PROC(35)='f + gamma -> f + gamma*/Z0'
ENDIF
C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
IF(MSTP(44).EQ.1) THEN
PROC(141)='f + fbar -> gamma*'
ELSEIF(MSTP(44).EQ.2) THEN
PROC(141)='f + fbar -> Z0'
ELSEIF(MSTP(44).EQ.3) THEN
PROC(141)='f + fbar -> Z''0'
ELSEIF(MSTP(44).EQ.4) THEN
PROC(141)='f + fbar -> gamma*/Z0'
ELSEIF(MSTP(44).EQ.5) THEN
PROC(141)='f + fbar -> gamma*/Z''0'
ELSEIF(MSTP(44).EQ.6) THEN
PROC(141)='f + fbar -> Z0/Z''0'
ELSEIF(MSTP(44).EQ.7) THEN
PROC(141)='f + fbar -> gamma*/Z0/Z''0'
ENDIF
C...Special cases in treatment of WW -> WW: redefine process name.
IF(MSTP(45).EQ.1) THEN
PROC(77)='W+ + W+ -> W+ + W+'
ELSEIF(MSTP(45).EQ.2) THEN
PROC(77)='W+ + W- -> W+ + W-'
ELSEIF(MSTP(45).EQ.3) THEN
PROC(77)='W+/- + W+/- -> W+/- + W+/-'
ENDIF
C...Initialize Generic Processes
KFGEN=9900001
KCGEN=PYCOMP(KFGEN)
IF(KCGEN.GT.0) THEN
IDCY=MDCY(KCGEN,2)
IF(IDCY.GT.0) THEN
KFF1=KFDP(IDCY+1,1)
KFF2=KFDP(IDCY+1,2)
KCF1=PYCOMP(KFF1)
KCF2=PYCOMP(KFF2)
IJ1=1
IJ2=1
KCI1=PYCOMP(KFDP(IDCY,1))
IF(KFDP(IDCY,1).LT.0) IJ1=2
KCI2=PYCOMP(KFDP(IDCY,2))
IF(KFDP(IDCY,2).LT.0) IJ2=2
ITMP1=0
190 ITMP1=ITMP1+1
IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
& GOTO 190
ITMP2=0
200 ITMP2=ITMP2+1
IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
& GOTO 200
PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
ITMP3=0
205 ITMP3=ITMP3+1
IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
& GOTO 205
PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
IJ1=1
IJ2=1
IF(KFF1.LT.0) IJ1=2
IF(KFF2.LT.0) IJ2=2
ITMP1=0
210 ITMP1=ITMP1+1
IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
& GOTO 210
ITMP2=0
220 ITMP2=ITMP2+1
IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
& GOTO 220
PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
& '+'//CHAF(KCF2,IJ2)(1:ITMP2)
ENDIF
ENDIF
C...Format for error information.
5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
&'combination'/1X,'Execution stopped!')
RETURN
END
C*********************************************************************
C...PYINBM
C...Identifies the two incoming particles and the choice of frame.
SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
C...Local arrays, character variables and data.
CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
&CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
DIMENSION LEN(3),KCDE(39),PM(2)
DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
&'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
DATA CHCDE/ 'e- ','e+ ','nu_e ',
&'nu_ebar ','mu- ','mu+ ','nu_mu ',
&'nu_mubar ','tau- ','tau+ ','nu_tau ',
&'nu_taubar ','pi+ ','pi- ','n0 ',
&'nbar0 ','p+ ','pbar- ','gamma ',
&'lambda0 ','sigma- ','sigma0 ','sigma+ ',
&'xi- ','xi0 ','omega- ','pi0 ',
&'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
&'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
&'k+ ','k- ','ks0 ','kl0 '/
DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
&211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
&3312,3322,3334,111,110,990,6*22,321,-321,310,130/
C...Store initial energy. Default frame.
VINT(290)=WIN
MINT(111)=0
C...Special user process initialization; convert to normal input.
IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
MINT(111)=11
IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
CALL PYNAME(IDBMUP(1),CHNAME)
CHBEAM=CHNAME(1:12)
CALL PYNAME(IDBMUP(2),CHNAME)
CHTARG=CHNAME(1:12)
ENDIF
C...Convert character variables to lowercase and find their length.
CHCOM(1)=CHFRAM
CHCOM(2)=CHBEAM
CHCOM(3)=CHTARG
DO 130 I=1,3
LEN(I)=12
DO 110 LL=12,1,-1
IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
DO 100 LA=1,26
IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
& CHALP(1)(LA:LA)
100 CONTINUE
110 CONTINUE
CHIDNT(I)=CHCOM(I)
C...Fix up bar, underscore and charge in particle name (if needed).
DO 120 LL=1,10
IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
CHTEMP=CHIDNT(I)
CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
ENDIF
120 CONTINUE
IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
CHTEMP=CHIDNT(I)
CHIDNT(I)='nu_'//CHTEMP(3:7)
ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
CHIDNT(I)(1:3)='n0 '
ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
CHIDNT(I)(1:5)='nbar0'
ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
CHIDNT(I)(1:3)='p+ '
ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
& CHIDNT(I)(1:2).EQ.'p-') THEN
CHIDNT(I)(1:5)='pbar-'
ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
CHIDNT(I)(7:7)='0'
ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
CHIDNT(I)(1:7)='reggeon'
ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
CHIDNT(I)(1:7)='pomeron'
ENDIF
130 CONTINUE
C...Identify free initialization.
IF(CHCOM(1)(1:2).EQ.'no') THEN
MINT(65)=1
RETURN
ENDIF
C...Identify incoming beam and target particles.
DO 160 I=1,2
DO 140 J=1,39
IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
140 CONTINUE
PM(I)=PYMASS(MINT(10+I))
VINT(2+I)=PM(I)
MINT(140+I)=0
IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
CHTEMP=CHIDNT(I+1)(7:12)//' '
DO 150 J=1,12
IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
150 CONTINUE
PM(I)=PYMASS(MINT(140+I))
VINT(302+I)=PM(I)
ENDIF
160 CONTINUE
IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
C...Identify choice of frame and input energies.
CHINIT=' '
C...Events defined in the CM frame.
IF(CHCOM(1)(1:2).EQ.'cm') THEN
MINT(111)=1
S=WIN**2
IF(MSTP(122).GE.1) THEN
IF(CHCOM(2)(1:1).NE.'e') THEN
LOFFS=(31-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' collider'//' '
ELSE
LOFFS=(30-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' collider'//' '
ENDIF
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),5300) WIN
ENDIF
C...Events defined in fixed target frame.
ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
MINT(111)=2
S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
IF(MSTP(122).GE.1) THEN
LOFFS=(29-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' fixed target'//' '
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),5400) WIN
WRITE(MSTU(11),5500) SQRT(S)
ENDIF
C...Frame defined by user three-vectors.
ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
MINT(111)=3
P(1,5)=PM(1)
P(2,5)=PM(2)
P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
& (P(1,3)+P(2,3))**2
IF(MSTP(122).GE.1) THEN
LOFFS=(22-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' user configuration'//' '
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),5600)
WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
ENDIF
C...Frame defined by user four-vectors.
ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
MINT(111)=4
PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
& (P(1,3)+P(2,3))**2
IF(MSTP(122).GE.1) THEN
LOFFS=(22-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' user configuration'//' '
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),5600)
WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
ENDIF
C...Frame defined by user five-vectors.
ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
MINT(111)=5
S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
& (P(1,3)+P(2,3))**2
IF(MSTP(122).GE.1) THEN
LOFFS=(22-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' user configuration'//' '
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),5600)
WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
ENDIF
C...Frame defined by HEPRUP common block.
ELSEIF(MINT(111).GE.11) THEN
S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
& SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
IF(MSTP(122).GE.1) THEN
LOFFS=(22-(LEN(2)+LEN(3)))/2
CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
& CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
& ' user configuration'//' '
WRITE(MSTU(11),5200) CHINIT
WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
ENDIF
C...Unknown frame. Error for too low CM energy.
ELSE
WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
CALL PYSTOP(7)
ENDIF
IF(S.LT.PARP(2)**2) THEN
WRITE(MSTU(11),5900) SQRT(S)
CALL PYSTOP(7)
ENDIF
C...Formats for initialization and error information.
5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
&1X,'Execution stopped!')
5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
&1X,'Execution stopped!')
5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
&19X,'I'/1X,'I',76X,'I'/1X,78('='))
5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
&'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
&'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
&1X,'Execution stopped!')
5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
&'generation.'/1X,'Execution stopped!')
6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
&'GeV beam energies',13X,'I')
RETURN
END
C*********************************************************************
C...PYINKI
C...Sets up kinematics, including rotations and boosts to/from CM frame.
SUBROUTINE PYINKI(MODKI)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
C...Set initial flavour state.
N=2
DO 100 I=1,2
K(I,1)=1
K(I,2)=MINT(10+I)
IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
100 CONTINUE
C...Reset boost. Do kinematics for various cases.
DO 110 J=6,10
VINT(J)=0D0
110 CONTINUE
C...Set up kinematics for events defined in CM frame.
IF(MINT(111).EQ.1) THEN
WIN=VINT(290)
IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
S=WIN**2
P(1,5)=VINT(3)
P(2,5)=VINT(4)
IF(MINT(141).NE.0) P(1,5)=VINT(303)
IF(MINT(142).NE.0) P(2,5)=VINT(304)
P(1,1)=0D0
P(1,2)=0D0
P(2,1)=0D0
P(2,2)=0D0
P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
& (4D0*S))
P(2,3)=-P(1,3)
P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
C...Set up kinematics for fixed target events.
ELSEIF(MINT(111).EQ.2) THEN
WIN=VINT(290)
IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
P(1,5)=VINT(3)
P(2,5)=VINT(4)
IF(MINT(141).NE.0) P(1,5)=VINT(303)
IF(MINT(142).NE.0) P(2,5)=VINT(304)
P(1,1)=0D0
P(1,2)=0D0
P(2,1)=0D0
P(2,2)=0D0
P(1,3)=WIN
P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
P(2,3)=0D0
P(2,4)=P(2,5)
S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
VINT(10)=P(1,3)/(P(1,4)+P(2,4))
CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
C...Set up kinematics for events in user-defined frame.
ELSEIF(MINT(111).EQ.3) THEN
P(1,5)=VINT(3)
P(2,5)=VINT(4)
IF(MINT(141).NE.0) P(1,5)=VINT(303)
IF(MINT(142).NE.0) P(2,5)=VINT(304)
P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
DO 120 J=1,3
VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
120 CONTINUE
CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
VINT(7)=PYANGL(P(1,1),P(1,2))
CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
VINT(6)=PYANGL(P(1,3),P(1,1))
CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
C...Set up kinematics for events with user-defined four-vectors.
ELSEIF(MINT(111).EQ.4) THEN
PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
DO 130 J=1,3
VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
130 CONTINUE
CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
VINT(7)=PYANGL(P(1,1),P(1,2))
CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
VINT(6)=PYANGL(P(1,3),P(1,1))
CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
S=(P(1,4)+P(2,4))**2
C...Set up kinematics for events with user-defined five-vectors.
ELSEIF(MINT(111).EQ.5) THEN
DO 140 J=1,3
VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
140 CONTINUE
CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
VINT(7)=PYANGL(P(1,1),P(1,2))
CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
VINT(6)=PYANGL(P(1,3),P(1,1))
CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
S=(P(1,4)+P(2,4))**2
C...Set up kinematics for events with external user processes.
ELSEIF(MINT(111).GE.11) THEN
P(1,5)=VINT(3)
P(2,5)=VINT(4)
IF(MINT(141).NE.0) P(1,5)=VINT(303)
IF(MINT(142).NE.0) P(2,5)=VINT(304)
P(1,1)=0D0
P(1,2)=0D0
P(2,1)=0D0
P(2,2)=0D0
P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
P(1,4)=EBMUP(1)
P(2,4)=EBMUP(2)
VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
S=(P(1,4)+P(2,4))**2
ENDIF
C...Return or error for too low CM energy.
IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
IF(MSTP(172).LE.1) THEN
CALL PYERRM(23,
& '(PYINKI:) too low invariant mass in this event')
ELSE
MSTI(61)=1
RETURN
ENDIF
ENDIF
C...Save information on incoming particles.
VINT(1)=SQRT(S)
VINT(2)=S
IF(MINT(111).GE.4) THEN
IF(MINT(141).EQ.0) THEN
VINT(3)=P(1,5)
IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
ELSE
VINT(303)=P(1,5)
ENDIF
IF(MINT(142).EQ.0) THEN
VINT(4)=P(2,5)
IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
ELSE
VINT(304)=P(2,5)
ENDIF
ENDIF
VINT(5)=P(1,3)
IF(MODKI.EQ.0) VINT(289)=S
DO 150 J=1,5
V(1,J)=0D0
V(2,J)=0D0
VINT(290+J)=P(1,J)
VINT(295+J)=P(2,J)
150 CONTINUE
C...Store pT cut-off and related constants to be used in generation.
IF(MODKI.EQ.0) VINT(285)=CKIN(3)
IF(MSTP(82).LE.1) THEN
PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
ELSE
PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
ENDIF
VINT(149)=4D0*PTMN**2/S
VINT(154)=PTMN
RETURN
END
C*********************************************************************
C...PYINPR
C...Selects partonic subprocesses to be included in the simulation.
SUBROUTINE PYINPR
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Commonblocks and character variables.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT6/
CHARACTER CHIPR*10
C...Reset processes to be included.
IF(MSEL.NE.0) THEN
DO 100 I=1,500
MSUB(I)=0
100 CONTINUE
ENDIF
C...Set running pTmin scale.
IF(MSTP(82).LE.1) THEN
PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
ELSE
PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
ENDIF
C...Begin by assuming incoming photon to enter subprocess.
IF(MINT(11).EQ.22) MINT(15)=22
IF(MINT(12).EQ.22) MINT(16)=22
C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
MSUB(10)=1
MINT(123)=MINT(122)+1
C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
C...allow mixture.
C...Here also set a few parameters otherwise normally not touched.
ELSEIF(MINT(121).GT.1) THEN
C...Parton distributions dampened at small Q2; go to low energies,
C...alpha_s <1; no minimum pT cut-off a priori.
IF(MSTP(18).EQ.2) THEN
MSTP(57)=3
PARP(2)=2D0
PARU(115)=1D0
CKIN(5)=0.2D0
CKIN(6)=0.2D0
ENDIF
C...Define pT cut-off parameters and whether run involves low-pT.
PTMVMD=PTMRUN
VINT(154)=PTMVMD
PTMDIR=PTMVMD
IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
PTMANO=PTMVMD
IF(MSTP(15).EQ.5) PTMANO=0.60D0+
& 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
IPTL=1
IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
IF(MSEL.EQ.2) IPTL=1
C...Set up for p/gamma * gamma; real or virtual photons.
IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
& MSTP(14).EQ.30)) THEN
C...Set up for p/VMD * VMD.
IF(MINT(122).EQ.1) THEN
MINT(123)=2
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
C...Set up for p/VMD * direct gamma.
ELSEIF(MINT(122).EQ.2) THEN
MINT(123)=0
IF(MINT(121).EQ.6) MINT(123)=5
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for p/VMD * anomalous gamma.
ELSEIF(MINT(122).EQ.3) THEN
MINT(123)=3
IF(MINT(121).EQ.6) MINT(123)=7
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
C...Set up for DIS * p.
ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
& IABS(MINT(12)).GT.100)) THEN
MINT(123)=8
IF(IPTL.EQ.1) MSUB(99)=1
C...Set up for direct * direct gamma (switch off leptons).
ELSEIF(MINT(122).EQ.4) THEN
MINT(123)=0
MSUB(137)=1
MSUB(138)=1
MSUB(139)=1
MSUB(140)=1
DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
110 CONTINUE
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for direct * anomalous gamma.
ELSEIF(MINT(122).EQ.5) THEN
MINT(123)=6
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMANO
C...Set up for anomalous * anomalous gamma.
ELSEIF(MINT(122).EQ.6) THEN
MINT(123)=3
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
ENDIF
C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
C...Set up for direct * direct gamma (switch off leptons).
IF(MINT(122).EQ.1) THEN
MINT(123)=0
MSUB(137)=1
MSUB(138)=1
MSUB(139)=1
MSUB(140)=1
DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
120 CONTINUE
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for direct * VMD and VMD * direct gamma.
ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
MINT(123)=5
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for direct * anomalous and anomalous * direct gamma.
ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
MINT(123)=6
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMANO
C...Set up for VMD*VMD.
ELSEIF(MINT(122).EQ.5) THEN
MINT(123)=2
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
C...Set up for VMD * anomalous and anomalous * VMD gamma.
ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
MINT(123)=7
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
C...Set up for anomalous * anomalous gamma.
ELSEIF(MINT(122).EQ.9) THEN
MINT(123)=3
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
C...Set up for DIS * VMD and VMD * DIS gamma.
ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
MINT(123)=8
IF(IPTL.EQ.1) MSUB(99)=1
C...Set up for DIS * anomalous and anomalous * DIS gamma.
ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
MINT(123)=9
IF(IPTL.EQ.1) MSUB(99)=1
ENDIF
C...Set up for gamma* * p; virtual photons = dir, res.
ELSEIF(MINT(121).EQ.2) THEN
C...Set up for direct * p.
IF(MINT(122).EQ.1) THEN
MINT(123)=0
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for resolved * p.
ELSEIF(MINT(122).EQ.2) THEN
MINT(123)=1
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
ENDIF
C...Set up for gamma* * gamma*; virtual photons = dir, res.
ELSEIF(MINT(121).EQ.4) THEN
C...Set up for direct * direct gamma (switch off leptons).
IF(MINT(122).EQ.1) THEN
MINT(123)=0
MSUB(137)=1
MSUB(138)=1
MSUB(139)=1
MSUB(140)=1
DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
130 CONTINUE
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for direct * resolved and resolved * direct gamma.
ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
MINT(123)=5
MSUB(131)=1
MSUB(132)=1
MSUB(135)=1
MSUB(136)=1
IF(IPTL.EQ.1) CKIN(3)=PTMDIR
C...Set up for resolved * resolved gamma.
ELSEIF(MINT(122).EQ.4) THEN
MINT(123)=2
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
IF(IPTL.EQ.1) MSUB(95)=1
IF(MSEL.EQ.2) THEN
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
ENDIF
IF(IPTL.EQ.1) CKIN(3)=0D0
ENDIF
C...End of special set up for gamma-p and gamma-gamma.
ENDIF
CKIN(1)=2D0*CKIN(3)
ENDIF
C...Flavour information for individual beams.
DO 140 I=1,2
MINT(40+I)=1
IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
MINT(44+I)=MINT(40+I)
IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
& IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
140 CONTINUE
C...If two real gammas, whereof one direct, pick the first.
C...For two virtual photons, keep requested order.
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
MINT(41)=1
MINT(45)=1
ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
& MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
MINT(41)=1
MINT(45)=1
ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
& MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
MINT(42)=1
MINT(46)=1
ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
& .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
MINT(41)=1
MINT(45)=1
ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
& .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
MINT(42)=1
MINT(46)=1
ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
MINT(41)=1
MINT(45)=1
ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
MINT(42)=1
MINT(46)=1
ENDIF
ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
IF(MINT(11).EQ.22) THEN
MINT(41)=1
MINT(45)=1
ELSE
MINT(42)=1
MINT(46)=1
ENDIF
ENDIF
IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
& '(PYINPR:) unallowed MSTP(14) code for single photon')
ENDIF
C...Flavour information on combination of incoming particles.
MINT(43)=2*MINT(41)+MINT(42)-2
MINT(44)=MINT(43)
IF(MINT(123).LE.0) THEN
IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
ELSEIF(MINT(123).LE.3) THEN
IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
MINT(43)=4
MINT(44)=1
ENDIF
MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
MINT(50)=0
IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
MINT(107)=0
MINT(108)=0
IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
& MINT(107)=2
IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
& MINT(107)=3
IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
& MINT(122).EQ.10) MINT(108)=2
IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
& MINT(122).EQ.11) MINT(108)=3
IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
IF(MINT(122).GE.3) MINT(107)=1
IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
ELSEIF(MINT(121).EQ.2) THEN
IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
ELSE
IF(MINT(11).EQ.22) THEN
MINT(107)=MINT(123)
IF(MINT(123).GE.4) MINT(107)=0
IF(MINT(123).EQ.7) MINT(107)=2
IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
IF(MSTP(14).EQ.28) MINT(107)=2
IF(MSTP(14).EQ.29) MINT(107)=3
IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
& MINT(107)=4
ENDIF
IF(MINT(12).EQ.22) THEN
MINT(108)=MINT(123)
IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
IF(MINT(123).EQ.7) MINT(108)=3
IF(MSTP(14).EQ.26) MINT(108)=2
IF(MSTP(14).EQ.27) MINT(108)=3
IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
& MINT(108)=4
ENDIF
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
& MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
MINTTP=MINT(107)
MINT(107)=MINT(108)
MINT(108)=MINTTP
ENDIF
ENDIF
IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
C...Select default processes according to incoming beams
C...(already done for gamma-p and gamma-gamma with
C...MSTP(14) = 10, 20, 25 or 30).
IF(MINT(121).GT.1) THEN
ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
IF(MINT(43).EQ.1) THEN
C...Lepton + lepton -> gamma/Z0 or W.
IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
& (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
C...Unresolved photon + lepton: Compton scattering.
MSUB(133)=1
MSUB(134)=1
ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
& .OR.MINT(12).EQ.22)) THEN
C...DIS as pure gamma* + f -> f process.
MSUB(99)=1
ELSEIF(MINT(43).LE.3) THEN
C...Lepton + hadron: deep inelastic scattering.
MSUB(10)=1
ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
& MINT(12).EQ.22) THEN
C...Two unresolved photons: fermion pair production,
C...exclude lepton pairs.
DO 150 ISUB=137,140
MSUB(ISUB)=1
150 CONTINUE
DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
160 CONTINUE
PTMDIR=PTMRUN
IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
& .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
& MINT(12).EQ.22)) THEN
C...Unresolved photon + hadron: photon-parton scattering.
DO 170 ISUB=131,136
MSUB(ISUB)=1
170 CONTINUE
ELSEIF(MSEL.EQ.1) THEN
C...High-pT QCD processes:
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
PTMN=PTMRUN
VINT(154)=PTMN
IF(CKIN(3).LT.PTMN) MSUB(95)=1
IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
ELSE
C...All QCD processes:
MSUB(11)=1
MSUB(12)=1
MSUB(13)=1
MSUB(28)=1
MSUB(53)=1
MSUB(68)=1
MSUB(91)=1
MSUB(92)=1
MSUB(93)=1
MSUB(94)=1
MSUB(95)=1
ENDIF
ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
C...Heavy quark production.
MSUB(81)=1
MSUB(82)=1
MSUB(84)=1
DO 180 J=1,MIN(8,MDCY(21,3))
MDME(MDCY(21,2)+J-1,1)=0
180 CONTINUE
MDME(MDCY(21,2)+MSEL-1,1)=1
MSUB(85)=1
DO 190 J=1,MIN(12,MDCY(22,3))
MDME(MDCY(22,2)+J-1,1)=0
190 CONTINUE
MDME(MDCY(22,2)+MSEL-1,1)=1
ELSEIF(MSEL.EQ.10) THEN
C...Prompt photon production:
MSUB(14)=1
MSUB(18)=1
MSUB(29)=1
ELSEIF(MSEL.EQ.11) THEN
C...Z0/gamma* production:
MSUB(1)=1
ELSEIF(MSEL.EQ.12) THEN
C...W+/- production:
MSUB(2)=1
ELSEIF(MSEL.EQ.13) THEN
C...Z0 + jet:
MSUB(15)=1
MSUB(30)=1
ELSEIF(MSEL.EQ.14) THEN
C...W+/- + jet:
MSUB(16)=1
MSUB(31)=1
ELSEIF(MSEL.EQ.15) THEN
C...Z0 & W+/- pair production:
MSUB(19)=1
MSUB(20)=1
MSUB(22)=1
MSUB(23)=1
MSUB(25)=1
ELSEIF(MSEL.EQ.16) THEN
C...h0 production:
MSUB(3)=1
MSUB(102)=1
MSUB(103)=1
MSUB(123)=1
MSUB(124)=1
ELSEIF(MSEL.EQ.17) THEN
C...h0 & Z0 or W+/- pair production:
MSUB(24)=1
MSUB(26)=1
ELSEIF(MSEL.EQ.18) THEN
C...h0 production; interesting processes in e+e-.
MSUB(24)=1
MSUB(103)=1
MSUB(123)=1
MSUB(124)=1
ELSEIF(MSEL.EQ.19) THEN
C...h0, H0 and A0 production; interesting processes in e+e-.
MSUB(24)=1
MSUB(103)=1
MSUB(123)=1
MSUB(124)=1
MSUB(153)=1
MSUB(171)=1
MSUB(173)=1
MSUB(174)=1
MSUB(158)=1
MSUB(176)=1
MSUB(178)=1
MSUB(179)=1
ELSEIF(MSEL.EQ.21) THEN
C...Z'0 production:
MSUB(141)=1
ELSEIF(MSEL.EQ.22) THEN
C...W'+/- production:
MSUB(142)=1
ELSEIF(MSEL.EQ.23) THEN
C...H+/- production:
MSUB(143)=1
ELSEIF(MSEL.EQ.24) THEN
C...R production:
MSUB(144)=1
ELSEIF(MSEL.EQ.25) THEN
C...LQ (leptoquark) production.
MSUB(145)=1
MSUB(162)=1
MSUB(163)=1
MSUB(164)=1
ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
C...Production of one heavy quark (W exchange):
MSUB(83)=1
DO 200 J=1,MIN(8,MDCY(21,3))
MDME(MDCY(21,2)+J-1,1)=0
200 CONTINUE
MDME(MDCY(21,2)+MSEL-31,1)=1
CMRENNA++Define SUSY alternatives.
ELSEIF(MSEL.EQ.39) THEN
C...Turn on all SUSY processes.
IF(MINT(43).EQ.4) THEN
C...Hadron-hadron processes.
DO 210 I=201,296
IF(ISET(I).GE.0) MSUB(I)=1
210 CONTINUE
ELSEIF(MINT(43).EQ.1) THEN
C...Lepton-lepton processes: QED production of squarks.
DO 220 I=201,214
MSUB(I)=1
220 CONTINUE
MSUB(210)=0
MSUB(211)=0
MSUB(212)=0
DO 230 I=216,228
MSUB(I)=1
230 CONTINUE
DO 240 I=261,263
MSUB(I)=1
240 CONTINUE
MSUB(277)=1
MSUB(278)=1
ENDIF
ELSEIF(MSEL.EQ.40) THEN
C...Gluinos and squarks.
IF(MINT(43).EQ.4) THEN
MSUB(243)=1
MSUB(244)=1
MSUB(258)=1
MSUB(259)=1
MSUB(261)=1
MSUB(262)=1
MSUB(264)=1
MSUB(265)=1
DO 250 I=271,296
MSUB(I)=1
250 CONTINUE
ELSEIF(MINT(43).EQ.1) THEN
MSUB(277)=1
MSUB(278)=1
ENDIF
ELSEIF(MSEL.EQ.41) THEN
C...Stop production.
MSUB(261)=1
MSUB(262)=1
MSUB(263)=1
IF(MINT(43).EQ.4) THEN
MSUB(264)=1
MSUB(265)=1
ENDIF
ELSEIF(MSEL.EQ.42) THEN
C...Slepton production.
DO 260 I=201,214
MSUB(I)=1
260 CONTINUE
IF(MINT(43).NE.4) THEN
MSUB(210)=0
MSUB(211)=0
MSUB(212)=0
ENDIF
ELSEIF(MSEL.EQ.43) THEN
C...Neutralino/Chargino + Gluino/Squark.
IF(MINT(43).EQ.4) THEN
DO 270 I=237,242
MSUB(I)=1
270 CONTINUE
DO 280 I=246,254
MSUB(I)=1
280 CONTINUE
MSUB(256)=1
ENDIF
ELSEIF(MSEL.EQ.44) THEN
C...Neutralino/Chargino pair production.
IF(MINT(43).EQ.4) THEN
DO 290 I=216,236
MSUB(I)=1
290 CONTINUE
ELSEIF(MINT(43).EQ.1) THEN
DO 300 I=216,228
MSUB(I)=1
300 CONTINUE
ENDIF
ELSEIF(MSEL.EQ.45) THEN
C...Sbottom production.
MSUB(287)=1
MSUB(288)=1
IF(MINT(43).EQ.4) THEN
DO 310 I=281,296
MSUB(I)=1
310 CONTINUE
ENDIF
ELSEIF(MSEL.EQ.50) THEN
C...Pair production of technipions and gauge bosons.
DO 320 I=361,368
MSUB(I)=1
320 CONTINUE
IF(MINT(43).EQ.4) THEN
DO 330 I=370,377
MSUB(I)=1
330 CONTINUE
ENDIF
ELSEIF(MSEL.EQ.51) THEN
C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
DO 340 I=381,386
MSUB(I)=1
340 CONTINUE
ELSEIF(MSEL.EQ.61) THEN
C...Charmonium production in colour octet model, with recoiling parton.
DO 342 I=421,439
MSUB(I)=1
342 CONTINUE
ELSEIF(MSEL.EQ.62) THEN
C...Bottomonium production in colour octet model, with recoiling parton.
DO 344 I=461,479
MSUB(I)=1
344 CONTINUE
ELSEIF(MSEL.EQ.63) THEN
C...Charmonium and bottomonium production in colour octet model.
DO 346 I=421,439
MSUB(I)=1
MSUB(I+40)=1
346 CONTINUE
ENDIF
C...Find heaviest new quark flavour allowed in processes 81-84.
KFLQM=1
DO 350 I=1,MIN(8,MDCY(21,3))
IDC=I+MDCY(21,2)-1
IF(MDME(IDC,1).LE.0) GOTO 350
KFLQM=I
350 CONTINUE
IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
&KFLQM=MSTP(7)
MINT(55)=KFLQM
KFPR(81,1)=KFLQM
KFPR(81,2)=KFLQM
KFPR(82,1)=KFLQM
KFPR(82,2)=KFLQM
KFPR(83,1)=KFLQM
KFPR(84,1)=KFLQM
KFPR(84,2)=KFLQM
C...Find heaviest new fermion flavour allowed in process 85.
KFLFM=1
DO 360 I=1,MIN(12,MDCY(22,3))
IDC=I+MDCY(22,2)-1
IF(MDME(IDC,1).LE.0) GOTO 360
KFLFM=KFDP(IDC,1)
360 CONTINUE
IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
&MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
MINT(56)=KFLFM
KFPR(85,1)=KFLFM
KFPR(85,2)=KFLFM
C...Initialize Generic Processes
KFGEN=9900001
KCGEN=PYCOMP(KFGEN)
IF(KCGEN.GT.0) THEN
IDCY=MDCY(KCGEN,2)
IF(IDCY.GT.0) THEN
KFF1=KFDP(IDCY+1,1)
KFF2=KFDP(IDCY+1,2)
KCF1=PYCOMP(KFF1)
KCF2=PYCOMP(KFF2)
JCOL1=IABS(KCHG(KCF1,2))
IF(JCOL1.EQ.1) THEN
KF1=KFF1
KF2=KFF2
ELSE
KF1=KFF2
KF2=KFF1
ENDIF
KFPR(481,1)=KF1
KFPR(481,2)=KF2
KFPR(482,1)=KF1
KFPR(482,2)=KF2
ENDIF
IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
KFIN(1,0)=1
KFIN(2,0)=1
ENDIF
ENDIF
C...Import relevant information on external user processes.
IF(MINT(111).GE.11) THEN
IPYPR=0
DO 390 IUP=1,NPRUP
C...Find next empty PYTHIA process number slot and enable it.
370 IPYPR=IPYPR+1
IF(IPYPR.GT.500) CALL PYERRM(26,
& '(PYINPR.) no more empty slots for user processes')
IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
ISET(IPYPR)=11
C...Overwrite KFPR with references back to process number and ID.
KFPR(IPYPR,1)=IUP
KFPR(IPYPR,2)=LPRUP(IUP)
C...Process title.
WRITE(CHIPR,'(I10)') LPRUP(IUP)
ICHIN=1
DO 380 ICH=1,9
IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
380 CONTINUE
PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
C...Switch on process.
MSUB(IPYPR)=1
390 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYXTOT
C...Parametrizes total, elastic and diffractive cross-sections
C...for different energies and beams. Donnachie-Landshoff for
C...total and Schuler-Sjostrand for elastic and diffractive.
C...Process code IPROC:
C...= 1 : p + p;
C...= 2 : pbar + p;
C...= 3 : pi+ + p;
C...= 4 : pi- + p;
C...= 5 : pi0 + p;
C...= 6 : phi + p;
C...= 7 : J/psi + p;
C...= 11 : rho + rho;
C...= 12 : rho + phi;
C...= 13 : rho + J/psi;
C...= 14 : phi + phi;
C...= 15 : phi + J/psi;
C...= 16 : J/psi + J/psi;
C...= 21 : gamma + p (DL);
C...= 22 : gamma + p (VDM).
C...= 23 : gamma + pi (DL);
C...= 24 : gamma + pi (VDM);
C...= 25 : gamma + gamma (DL);
C...= 26 : gamma + gamma (VDM).
SUBROUTINE PYXTOT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
C...Local arrays.
DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
&PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
&CEFFD(10,9),SIGTMP(6,0:5)
C...Common constants.
DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
&PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
&FACDD/0.0084D0/
C...Number of multiple processes to be evaluated (= 0 : undefined).
DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
&8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
&0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
DATA YPAR/
&56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
&13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
&0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
C...Beam and target hadron class:
C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
C...Characteristic class masses, slope parameters, beta = sqrt(X).
DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
C...Fitting constants used in parametrizations of diffractive results.
DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
&0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
&0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
&0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
&0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
&0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
&0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
&0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
&0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
&0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
&0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
&3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
&-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
&0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
&3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
&-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
&0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
&3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
&-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
&0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
&3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
&-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
&0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
&3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
&-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
&0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
C...Parameters. Combinations of the energy.
AEM=PARU(101)
PMTH=PARP(102)
S=VINT(2)
SRT=VINT(1)
SEPS=S**EPS
SETA=S**ETA
SLOG=LOG(S)
C...Ratio of gamma/pi (for rescaling in parton distributions).
VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
&(XPAR(5)*SEPS+YPAR(5)*SETA)
VINT(317)=1D0
IF(MINT(50).NE.1) RETURN
C...Order flavours of incoming particles: KF1 < KF2.
IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
KF1=IABS(MINT(11))
KF2=IABS(MINT(12))
IORD=1
ELSE
KF1=IABS(MINT(12))
KF2=IABS(MINT(11))
IORD=2
ENDIF
ISGN12=ISIGN(1,MINT(11)*MINT(12))
C...Find process number (for lookup tables).
IF(KF1.GT.1000) THEN
IPROC=1
IF(ISGN12.LT.0) IPROC=2
ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
IPROC=3
IF(ISGN12.LT.0) IPROC=4
IF(KF1.EQ.111) IPROC=5
ELSEIF(KF1.GT.100) THEN
IPROC=11
ELSEIF(KF2.GT.1000) THEN
IPROC=21
IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
ELSEIF(KF2.GT.100) THEN
IPROC=23
IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
ELSE
IPROC=25
IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
ENDIF
C... Number of multiple processes to be stored; beam/target side.
NPR=NPROC(IPROC)
MINT(101)=1
MINT(102)=1
IF(NPR.EQ.3) THEN
MINT(100+IORD)=4
ELSEIF(NPR.EQ.6) THEN
MINT(101)=4
MINT(102)=4
ENDIF
N1=0
IF(MINT(101).EQ.4) N1=4
N2=0
IF(MINT(102).EQ.4) N2=4
C...Do not do any more for user-set or undefined cross-sections.
IF(MSTP(31).LE.0) RETURN
IF(NPR.EQ.0) CALL PYERRM(26,
&'(PYXTOT:) cross section for this process not yet implemented')
C...Parameters. Combinations of the energy.
AEM=PARU(101)
PMTH=PARP(102)
S=VINT(2)
SRT=VINT(1)
SEPS=S**EPS
SETA=S**ETA
SLOG=LOG(S)
C...Loop over multiple processes (for VDM).
DO 110 I=1,NPR
IF(NPR.EQ.1) THEN
IPR=IPROC
ELSEIF(NPR.EQ.3) THEN
IPR=I+4
IF(KF2.LT.1000) IPR=I+10
ELSEIF(NPR.EQ.6) THEN
IPR=I+10
ENDIF
C...Evaluate hadron species, mass, slope contribution and fit number.
IHA=IHADA(IPR)
IHB=IHADB(IPR)
PMA=PMHAD(IHA)
PMB=PMHAD(IHB)
BHA=BHAD(IHA)
BHB=BHAD(IHB)
ISD=IFITSD(IPR)
IDD=IFITDD(IPR)
C...Skip if energy too low relative to masses.
DO 100 J=0,5
SIGTMP(I,J)=0D0
100 CONTINUE
IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
C...Total cross-section. Elastic slope parameter and cross-section.
SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
C...Diffractive scattering A + B -> X + B.
BSD=2D0*BHB
SQML=(PMA+PMTH)**2
SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
& (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
& (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
C...Diffractive scattering A + B -> A + X.
BSD=2D0*BHA
SQML=(PMB+PMTH)**2
SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
& (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
& (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
C...Order single diffractive correctly.
IF(IORD.EQ.2) THEN
SIGSAV=SIGTMP(I,2)
SIGTMP(I,2)=SIGTMP(I,3)
SIGTMP(I,3)=SIGSAV
ENDIF
C...Double diffractive scattering A + B -> X1 + X2.
YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
IF(YEFF.LE.0) SUM1=0D0
SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
& (2D0*ALP)
SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
& (2D0*ALP)
BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
& LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
C...Non-diffractive by unitarity.
SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
& SIGTMP(I,4)
110 CONTINUE
C...Put temporary results in output array: only one process.
IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
DO 120 J=0,5
SIGT(0,0,J)=SIGTMP(1,J)
120 CONTINUE
C...Beam multiple processes.
ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
IF(MINT(107).EQ.2) THEN
VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
ELSE
VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
& ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
ENDIF
IF(MSTP(20).GT.0) THEN
VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
ENDIF
DO 140 I=1,4
IF(MINT(107).EQ.2) THEN
CONV=(AEM/PARP(160+I))*VINT(317)
ELSEIF(VINT(154).GT.PARP(15)) THEN
CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
& (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
ELSE
CONV=0D0
ENDIF
I1=MAX(1,I-1)
DO 130 J=0,5
SIGT(I,0,J)=CONV*SIGTMP(I1,J)
130 CONTINUE
140 CONTINUE
DO 150 J=0,5
SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
150 CONTINUE
C...Target multiple processes.
ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
IF(MINT(108).EQ.2) THEN
VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
ELSE
VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
& ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
ENDIF
IF(MSTP(20).GT.0) THEN
VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
ENDIF
DO 170 I=1,4
IF(MINT(108).EQ.2) THEN
CONV=(AEM/PARP(160+I))*VINT(317)
ELSEIF(VINT(154).GT.PARP(15)) THEN
CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
& (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
ELSE
CONV=0D0
ENDIF
IV=MAX(1,I-1)
DO 160 J=0,5
SIGT(0,I,J)=CONV*SIGTMP(IV,J)
160 CONTINUE
170 CONTINUE
DO 180 J=0,5
SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
180 CONTINUE
C...Both beam and target multiple processes.
ELSE
IF(MINT(107).EQ.2) THEN
VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
ELSE
VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
& ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
ENDIF
IF(MINT(108).EQ.2) THEN
VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
ELSE
VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
& ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
ENDIF
IF(MSTP(20).GT.0) THEN
VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
& VINT(308)))**MSTP(20)
ENDIF
DO 210 I1=1,4
DO 200 I2=1,4
IF(MINT(107).EQ.2) THEN
CONV=(AEM/PARP(160+I1))*VINT(317)
ELSEIF(VINT(154).GT.PARP(15)) THEN
CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
& (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
ELSE
CONV=0D0
ENDIF
IF(MINT(108).EQ.2) THEN
CONV=CONV*(AEM/PARP(160+I2))
ELSEIF(VINT(154).GT.PARP(15)) THEN
CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
& (1D0/PARP(15)**2-1D0/VINT(154)**2)
ELSE
CONV=0D0
ENDIF
IF(I1.LE.2) THEN
IV=MAX(1,I2-1)
ELSEIF(I2.LE.2) THEN
IV=MAX(1,I1-1)
ELSEIF(I1.EQ.I2) THEN
IV=2*I1-2
ELSE
IV=5
ENDIF
DO 190 J=0,5
JV=J
IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
190 CONTINUE
200 CONTINUE
210 CONTINUE
DO 230 J=0,5
DO 220 I=1,4
SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
220 CONTINUE
SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
230 CONTINUE
ENDIF
C...Scale up uniformly for Donnachie-Landshoff parametrization.
IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
DO 260 I1=0,N1
DO 250 I2=0,N2
DO 240 J=0,5
SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
240 CONTINUE
250 CONTINUE
260 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYMAXI
C...Finds optimal set of coefficients for kinematical variable selection
C...and the maximum of the part of the differential cross-section used
C...in the event weighting.
SUBROUTINE PYMAXI
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYTCCO/COEFX(194:380,2)
COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
&/PYTCSM/,/TCPARA/
C...Local arrays, character variables and data.
LOGICAL IOK
CHARACTER CVAR(4)*4
DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
&NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
&IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
&IQ(9),IP(9)
DATA CVAR/'tau ','tau''','y* ','cth '/
DATA SIGSSM/3*0D0/
C...Initial values and loop over subprocesses.
NPOSI=0
VINT(143)=1D0
VINT(144)=1D0
XSEC(0,1)=0D0
ITECH=0
DO 460 ISUB=1,500
MINT(1)=ISUB
MINT(51)=0
C...Find maximum weight factors for photon flux.
IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
ENDIF
C...Select subprocess to study: skip cases not applicable.
IF(ISET(ISUB).EQ.11) THEN
IF(MSUB(ISUB).NE.1) GOTO 460
C...User process intialization: cross section model dependent.
IF(IABS(IDWTUP).EQ.1) THEN
IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
& PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
ELSE
IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
& XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
& PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
& PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
ENDIF
IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
& WTGAGA*XSEC(ISUB,1)
NPOSI=NPOSI+1
GOTO 450
ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
CALL PYSIGH(NCHN,SIGS)
XSEC(ISUB,1)=SIGS
IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
& WTGAGA*XSEC(ISUB,1)
IF(MSUB(ISUB).NE.1) GOTO 460
NPOSI=NPOSI+1
GOTO 450
ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
CALL PYSIGH(NCHN,SIGS)
XSEC(ISUB,1)=SIGS
IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
& WTGAGA*XSEC(ISUB,1)
IF(XSEC(ISUB,1).EQ.0D0) THEN
MSUB(ISUB)=0
ELSE
NPOSI=NPOSI+1
ENDIF
GOTO 450
ELSEIF(ISUB.EQ.96) THEN
IF(MINT(50).EQ.0) GOTO 460
IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
& GOTO 460
IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
& ISUB.EQ.53.OR.ISUB.EQ.68) THEN
IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
ELSE
IF(MSUB(ISUB).NE.1) GOTO 460
ENDIF
ISTSB=ISET(ISUB)
IF(ISUB.EQ.96) ISTSB=2
IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
MWTXS=0
IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
& MSUB(94)+MSUB(95).EQ.0) MWTXS=1
C...Find resonances (explicit or implicit in cross-section).
MINT(72)=0
KFR1=0
IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
KFR1=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
& .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
KFR1=23
ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
& .OR.ISUB.EQ.177) THEN
KFR1=24
ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
KFR1=25
IF(MSTP(46).EQ.5) THEN
KFR1=89
PMAS(89,1)=PARP(45)
PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
ENDIF
ELSEIF(ISUB.EQ.481) THEN
KFR1=9900001
ENDIF
CKMX=CKIN(2)
IF(CKMX.LE.0D0) CKMX=VINT(1)
KCR1=PYCOMP(KFR1)
IF(KCR1.EQ.0) KFR1=0
IF(KFR1.NE.0) THEN
IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
& CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
ENDIF
IF(KFR1.NE.0) THEN
TAUR1=PMAS(KCR1,1)**2/VINT(2)
GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
ENDIF
KFR2=0
KFR3=0
IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
$ (ISUB.GE.361.AND.ISUB.LE.380))
$ THEN
KFR2=23
IF(ISUB.EQ.141) THEN
KCR2=PYCOMP(KFR2)
IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
& CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
KFR2=0
ELSE
TAUR2=PMAS(KCR2,1)**2/VINT(2)
GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
MINT(72)=2
MINT(74)=KFR2
VINT(75)=TAUR2
VINT(76)=GAMR2
ENDIF
ELSEIF(ITECH.EQ.0) THEN
ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
ITECH=1
KFR1=KTECHN+113
KCR1=PYCOMP(KFR1)
KFR2=KTECHN+223
KCR2=PYCOMP(KFR2)
KFR3=KTECHN+115
KCR3=PYCOMP(KFR3)
IRES=0
C...Order the resonances
IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
KCT=KCR3
KCR3=KCR2
KCR2=KCT
ENDIF
IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
KCT=KCR3
KCR3=KCR1
KCR1=KCT
ENDIF
IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
KCT=KCR2
KCR2=KCR1
KCR1=KCT
ENDIF
DO 101 I=1,3
IF(I.EQ.1) THEN
SHN0=PMAS(KCR1,1)**2
ELSEIF(I.EQ.2) THEN
IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
SHN0=PMAS(KCR2,1)**2
ELSEIF(I.EQ.3) THEN
IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
SHN0=PMAS(KCR3,1)**2
ENDIF
AEM=PYALEM(SHN0)
FAR=SQRT(AEM/ALPRHT)
SHN=SHN0*(1D0-FAR)
CALL PYTECM(SHN,S1,WIDO,1)
RES=SHN-S1
SHN=S1*.99D0
SHSTEP=2D0
102 SHN=SHN+SHSTEP
CALL PYTECM(SHN,S1,WIDO,1)
IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
IOK=.FALSE.
IF(IRES.GT.0) THEN
IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
ELSEIF(IRES.EQ.0) THEN
IOK=.TRUE.
ENDIF
IF(IOK) THEN
IRES=IRES+1
XMAS(IRES)=SQRT(S1)
XWID(IRES)=WIDO
ENDIF
ENDIF
RES=SHN-S1
IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
101 CONTINUE
JRES=0
KFR1=KTECHN+213
KCR1=PYCOMP(KFR1)
KFR2=KTECHN+215
KCR2=PYCOMP(KFR2)
IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
KCT=KCR2
KCR2=KCR1
KCR1=KCT
ENDIF
DO 103 I=1,2
IF(I.EQ.1) THEN
SHN0=PMAS(KCR1,1)**2
ELSEIF(I.EQ.2) THEN
IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
SHN0=PMAS(KCR2,1)**2
ENDIF
AEM=PYALEM(SHN0)
FAR=SQRT(AEM/ALPRHT)
SHN=SHN0*(1D0-FAR)
CALL PYTECM(SHN,S1,WIDO,2)
RES=SHN-S1
SHN=S1*.99D0
SHSTEP=2D0
104 SHN=SHN+SHSTEP
CALL PYTECM(SHN,S1,WIDO,2)
IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
IOK=.FALSE.
IF(JRES.GT.0) THEN
IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
ELSEIF(JRES.EQ.0) THEN
IOK=.TRUE.
ENDIF
IF(IOK) THEN
JRES=JRES+1
YMAS(JRES)=SQRT(S1)
YWID(JRES)=WIDO
ENDIF
ENDIF
RES=SHN-S1
IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
103 CONTINUE
ENDIF
IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
& ISUB.EQ.379.OR.ISUB.EQ.380) THEN
MINT(72)=IRES
IF(IRES.GE.1) THEN
VINT(73)=XMAS(1)**2/VINT(2)
VINT(74)=XMAS(1)*XWID(1)/VINT(2)
TAUR1=VINT(73)
GAMR1=VINT(74)
XM1=XMAS(1)
XG1=XWID(1)
KFR1=1
ENDIF
IF(IRES.GE.2) THEN
VINT(75)=XMAS(2)**2/VINT(2)
VINT(76)=XMAS(2)*XWID(2)/VINT(2)
TAUR2=VINT(75)
GAMR2=VINT(76)
XM2=XMAS(2)
XG2=XWID(2)
KFR2=2
ENDIF
IF(IRES.EQ.3) THEN
VINT(77)=XMAS(3)**2/VINT(2)
VINT(78)=XMAS(3)*XWID(3)/VINT(2)
TAUR3=VINT(77)
GAMR3=VINT(78)
XM3=XMAS(3)
XG3=XWID(3)
KFR3=3
ENDIF
C...Charged current: rho+- and a+-
ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
MINT(72)=IRES
IF(JRES.GE.1) THEN
VINT(73)=YMAS(1)**2/VINT(2)
VINT(74)=YMAS(1)*YWID(1)/VINT(2)
KFR1=1
TAUR1=VINT(73)
GAMR1=VINT(74)
XM1=YMAS(1)
XG1=YWID(1)
ENDIF
IF(JRES.GE.2) THEN
VINT(75)=YMAS(2)**2/VINT(2)
VINT(76)=YMAS(2)*YWID(2)/VINT(2)
KFR2=2
TAUR2=VINT(73)
GAMR2=VINT(74)
XM2=YMAS(2)
XG2=YWID(2)
ENDIF
KFR3=0
ENDIF
IF(ISUB.NE.141) THEN
IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
& .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
& .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
& .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
MINT(72)=2
ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
MINT(72)=2
MINT(74)=KFR3
VINT(75)=TAUR3
VINT(76)=GAMR3
ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
MINT(72)=2
MINT(73)=KFR2
VINT(73)=TAUR2
VINT(74)=GAMR2
MINT(74)=KFR3
VINT(75)=TAUR3
VINT(76)=GAMR3
ELSEIF(KFR1.NE.0) THEN
MINT(72)=1
ELSEIF(KFR2.NE.0) THEN
MINT(72)=1
MINT(73)=KFR2
VINT(73)=TAUR2
VINT(74)=GAMR2
ELSEIF(KFR3.NE.0) THEN
MINT(72)=1
MINT(73)=KFR3
VINT(73)=TAUR3
VINT(74)=GAMR3
ELSE
MINT(72)=0
ENDIF
ELSE
IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
ELSEIF(KFR2.NE.0) THEN
KFR1=KFR2
TAUR1=TAUR2
GAMR1=GAMR2
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
KFR2=0
ELSE
MINT(72)=0
ENDIF
ENDIF
ENDIF
C...Find product masses and minimum pT of process.
SQM3=0D0
SQM4=0D0
MINT(71)=0
VINT(71)=CKIN(3)
VINT(80)=1D0
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
NBW=0
DO 110 I=1,2
PMMN(I)=0D0
IF(KFPR(ISUB,I).EQ.0) THEN
ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
& PARP(41)) THEN
IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
ELSE
NBW=NBW+1
C...This prevents SUSY/t particles from becoming too light.
KFLW=KFPR(ISUB,I)
IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
KCW=PYCOMP(KFLW)
PMMN(I)=PMAS(KCW,1)
DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
& PMAS(PYCOMP(KFDP(IDC,2)),1)
IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
& PMAS(PYCOMP(KFDP(IDC,3)),1)
PMMN(I)=MIN(PMMN(I),PMSUM)
ENDIF
100 CONTINUE
ELSEIF(KFLW.EQ.6) THEN
PMMN(I)=PMAS(24,1)+PMAS(5,1)
ENDIF
ENDIF
110 CONTINUE
IF(NBW.GE.1) THEN
CKIN41=CKIN(41)
CKIN43=CKIN(43)
CKIN(41)=MAX(PMMN(1),CKIN(41))
CKIN(43)=MAX(PMMN(2),CKIN(43))
CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
CKIN(41)=CKIN41
CKIN(43)=CKIN43
IF(MINT(51).EQ.1) THEN
WRITE(MSTU(11),5100) ISUB
MSUB(ISUB)=0
GOTO 460
ENDIF
SQM3=PQM3**2
SQM4=PQM4**2
ENDIF
IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
ELSEIF(ISUB.EQ.96) THEN
VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
ENDIF
ENDIF
VINT(63)=SQM3
VINT(64)=SQM4
C...Prepare for additional variable choices in 2 -> 3.
IF(ISTSB.EQ.5) THEN
VINT(201)=0D0
IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
VINT(206)=VINT(201)
IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
VINT(204)=PMAS(23,1)
IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
& .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
& VINT(204)=VINT(201)
VINT(209)=VINT(204)
IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
ENDIF
C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
IPEAK7=0
NPTS(1)=2+2*MINT(72)
IF(MINT(47).EQ.1) THEN
IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
ELSEIF(MINT(47).GE.5) THEN
IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
NPTS(1)=NPTS(1)+1
IPEAK7=1
ENDIF
ENDIF
NPTS(2)=1
IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
IF(MINT(47).GE.2) NPTS(2)=2
IF(MINT(47).GE.5) NPTS(2)=3
ENDIF
NPTS(3)=1
IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
NPTS(3)=3
IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
ENDIF
NPTS(4)=1
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
C...Reset coefficients of cross-section weighting.
DO 120 J=1,20
COEF(ISUB,J)=0D0
120 CONTINUE
IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
& .AND.ISUB.LE.380)) THEN
DO 125 J=1,2
COEFX(ISUB,J)=0D0
125 CONTINUE
ENDIF
COEF(ISUB,1)=1D0
COEF(ISUB,8)=0.5D0
COEF(ISUB,9)=0.5D0
COEF(ISUB,13)=1D0
COEF(ISUB,18)=1D0
MCTH=0
MTAUP=0
METAUP=0
VINT(23)=0D0
VINT(26)=0D0
SIGSAM=0D0
C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
C...in grid of phase space points.
CALL PYKLIM(1)
METAU=MINT(51)
NACC=0
DO 150 ITRY=1,NTRY
MINT(51)=0
IF(METAU.EQ.1) GOTO 150
IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
MTAU=7
ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
MTAU=MTAU+1
ENDIF
RTAU=0.5D0
C...Special case when both resonances have same mass,
C...as is often the case in process 194.
c IF(MINT(72).GE.2) THEN
c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
c RTAU=0.4D0
c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
c RTAU=0.6D0
c ENDIF
c ENDIF
c ENDIF
CALL PYKMAP(1,MTAU,RTAU)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
METAUP=MINT(51)
ENDIF
IF(METAUP.EQ.1) GOTO 150
IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
& .EQ.0) THEN
MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
CALL PYKMAP(4,MTAUP,0.5D0)
ENDIF
IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
CALL PYKLIM(2)
MEYST=MINT(51)
ENDIF
IF(MEYST.EQ.1) GOTO 150
IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
CALL PYKMAP(2,MYST,0.5D0)
CALL PYKLIM(3)
MECTH=MINT(51)
ENDIF
IF(MECTH.EQ.1) GOTO 150
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
MCTH=1+MOD(ITRY-1,NPTS(4))
CALL PYKMAP(3,MCTH,0.5D0)
ENDIF
IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
C...Store position and limits.
MINT(51)=0
CALL PYKLIM(0)
IF(MINT(51).EQ.1) GOTO 150
NACC=NACC+1
MVARPT(NACC,1)=MTAU
MVARPT(NACC,2)=MTAUP
MVARPT(NACC,3)=MYST
MVARPT(NACC,4)=MCTH
DO 130 J=1,30
VINTPT(NACC,J)=VINT(10+J)
130 CONTINUE
C...Normal case: calculate cross-section.
IF(ISTSB.NE.5) THEN
CALL PYSIGH(NCHN,SIGS)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGS=WTXS*SIGS
ENDIF
C..2 -> 3: find highest value out of a number of tries.
ELSE
SIGS=0D0
DO 140 IKIN3=1,MSTP(129)
CALL PYKMAP(5,0,0D0)
IF(MINT(51).EQ.1) GOTO 140
CALL PYSIGH(NCHN,SIGTMP)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGTMP=WTXS*SIGTMP
ENDIF
IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
140 CONTINUE
ENDIF
C...Store cross-section.
SIGSPT(NACC)=SIGS
IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
& VINT(21),VINT(22),VINT(23),VINT(26),SIGS
150 CONTINUE
IF(NACC.EQ.0) THEN
WRITE(MSTU(11),5100) ISUB
MSUB(ISUB)=0
GOTO 460
ELSEIF(SIGSAM.EQ.0D0) THEN
WRITE(MSTU(11),5300) ISUB
MSUB(ISUB)=0
GOTO 460
ENDIF
IF(ISUB.NE.96) NPOSI=NPOSI+1
C...Calculate integrals in tau over maximal phase space limits.
TAUMIN=VINT(11)
TAUMAX=VINT(31)
ATAU1=LOG(TAUMAX/TAUMIN)
IF(NPTS(1).GE.2) THEN
ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
ENDIF
IF(NPTS(1).GE.4) THEN
ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
& GAMR1
ENDIF
IF(NPTS(1).GE.6) THEN
ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
& GAMR2
ENDIF
IF(NPTS(1).GE.8) THEN
ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
& GAMR3
ENDIF
IF(IPEAK7.EQ.1) THEN
ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
ENDIF
C...Reset. Sum up cross-sections in points calculated.
DO 320 IVAR=1,4
IF(NPTS(IVAR).EQ.1) GOTO 320
IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
NBIN=NPTS(IVAR)
DO 170 J1=1,NBIN
NAREL(J1)=0
WTREL(J1)=0D0
COEFU(J1)=0D0
DO 160 J2=1,NBIN
WTMAT(J1,J2)=0D0
160 CONTINUE
170 CONTINUE
DO 180 IACC=1,NACC
IBIN=MVARPT(IACC,IVAR)
IF(IVAR.EQ.1) THEN
IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
IBIN=IBIN-1
ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
IBIN=3+2*MINT(72)
ENDIF
ENDIF
IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
NAREL(IBIN)=NAREL(IBIN)+1
WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
C...Sum up tau cross-section pieces in points used.
IF(IVAR.EQ.1) THEN
TAU=VINTPT(IACC,11)
WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
IF(NBIN.GE.4) THEN
WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
& ((TAU-TAUR1)**2+GAMR1**2)
ENDIF
IF(NBIN.GE.6) THEN
WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
& ((TAU-TAUR2)**2+GAMR2**2)
ENDIF
IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
& +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
WTMAT(IBIN,7)=WTMAT(IBIN,7)
& +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
ENDIF
IF(MINT(72).EQ.3) THEN
WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
& +(ATAU1/ATAU8)/(TAU+TAUR3)
WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
& +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
ENDIF
C...Sum up tau' cross-section pieces in points used.
ELSEIF(IVAR.EQ.2) THEN
TAU=VINTPT(IACC,11)
TAUP=VINTPT(IACC,16)
TAUPMN=VINTPT(IACC,6)
TAUPMX=VINTPT(IACC,26)
ATAUP1=LOG(TAUPMX/TAUPMN)
ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
& (1D0-TAU/TAUP)**3/TAUP
IF(NBIN.GE.3) THEN
ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
& TAUP/MAX(2D-10,1D0-TAUP)
ENDIF
C...Sum up y* cross-section pieces in points used.
ELSEIF(IVAR.EQ.3) THEN
YST=VINTPT(IACC,12)
YSTMIN=VINTPT(IACC,2)
YSTMAX=VINTPT(IACC,22)
AYST0=YSTMAX-YSTMIN
AYST1=0.5D0*(YSTMAX-YSTMIN)**2
AYST2=AYST1
AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
IF(MINT(45).EQ.3) THEN
TAUE=VINTPT(IACC,11)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
YST0=-0.5D0*LOG(TAUE)
AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
& MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
& MAX(1D-10,1D0-EXP(YST-YST0))
ENDIF
IF(MINT(46).EQ.3) THEN
TAUE=VINTPT(IACC,11)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
YST0=-0.5D0*LOG(TAUE)
AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
& MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
& MAX(1D-10,1D0-EXP(-YST-YST0))
ENDIF
C...Sum up cos(theta-hat) cross-section pieces in points used.
ELSE
RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
RSQM=1D0+RM34
CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
CTHMIN=-CTHMAX
IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
& (TAUMAX*VINT(2)))
ACTH1=CTHMAX-CTHMIN
ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
CTH=VINTPT(IACC,13)
WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
& MAX(RM34,RSQM-CTH)
WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
& MAX(RM34,RSQM+CTH)
WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
& MAX(RM34,RSQM-CTH)**2
WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
& MAX(RM34,RSQM+CTH)**2
ENDIF
180 CONTINUE
C...Check that equation system solvable.
IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
MSOLV=1
WTRELS=0D0
DO 190 IBIN=1,NBIN
IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
& IRED=1,NBIN),WTREL(IBIN)
IF(NAREL(IBIN).EQ.0) MSOLV=0
WTRELS=WTRELS+WTREL(IBIN)
190 CONTINUE
IF(ABS(WTRELS).LT.1D-20) MSOLV=0
C...Solve to find relative importance of cross-section pieces.
IF(MSOLV.EQ.1) THEN
DO 200 IBIN=1,NBIN
WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
WTRSAV(IBIN)=WTREL(IBIN)
200 CONTINUE
C...Auxiliary vectors to record order of permutations
DO I=1,NBIN
IP(I) = I
IQ(I) = I
ENDDO
DO 230 IRED=1,NBIN-1
MROW=IRED
RESMAX=ABS(WTREL(MROW))
C...Find row with largest residual
DO JBIN=IRED+1,NBIN
IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
MROW=JBIN
RESMAX=ABS(WTREL(MROW))
ENDIF
ENDDO
IF(RESMAX.LT.1D-20) THEN
MSOLV=0
GOTO 260
ENDIF
MCOL = IRED
AMAX = ABS(WTMAT(MROW,MCOL))
C...Find column with largest entry
DO JBIN=IRED+1,NBIN
IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
MCOL = JBIN
AMAX = ABS(WTMAT(MROW,MCOL))
ENDIF
ENDDO
C...Swap rows if necessary
IF(MROW.NE.IRED) THEN
DO JBIN=1,NBIN
TMPE=WTMAT(IRED,JBIN)
WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
WTMAT(MROW,JBIN)=TMPE
ENDDO
TMPE=WTREL(IRED)
WTREL(IRED)=WTREL(MROW)
WTREL(MROW)=TMPE
MTMP=IQ(IRED)
IQ(IRED)=IQ(MROW)
IQ(MROW)=MTMP
ENDIF
C...Swap columns if necessary
IF(MCOL.NE.IRED) THEN
DO JBIN=1,NBIN
TMPE=WTMAT(JBIN,IRED)
WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
WTMAT(JBIN,MCOL)=TMPE
ENDDO
MTMP=IP(IRED)
IP(IRED)=IP(MCOL)
IP(MCOL)=MTMP
ENDIF
C...Begin eliminating equations
DO 220 IBIN=IRED+1,NBIN
IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
MSOLV=0
GOTO 260
ENDIF
C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
RQTU=WTMAT(IBIN,IRED)
RQTL=WTMAT(IRED,IRED)
C...Switch order of operations
WTREL(IBIN)=WTREL(IBIN)-RQTU*
$ (WTREL(IRED)/RQTL)
DO 210 ICOE=IRED,NBIN
WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
$ RQTU*(WTMAT(IRED,ICOE)/RQTL)
210 CONTINUE
220 CONTINUE
230 CONTINUE
DO 250 IRED=NBIN,1,-1
DO 240 ICOE=IRED+1,NBIN
WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
240 CONTINUE
IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
MSOLV=0
GOTO 260
ENDIF
COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
TEMPC(IRED)=COEFU(IRED)
250 CONTINUE
C...Return to original order
DO IBIN=1,NBIN
MTMP=IP(IBIN)
COEFU(MTMP)=TEMPC(IBIN)
ENDDO
ENDIF
C...Share evenly if failure.
260 IF(MSOLV.EQ.0) THEN
DO 270 IBIN=1,NBIN
COEFU(IBIN)=1D0
WTRELN(IBIN)=0.1D0
IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
& WTRSAV(IBIN)/WTRELS)
270 CONTINUE
ENDIF
C...Normalize coefficients, with piece shared democratically.
COEFSU=0D0
WTRELS=0D0
DO 280 IBIN=1,NBIN
COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
COEFSU=COEFSU+COEFU(IBIN)
WTRELS=WTRELS+WTRELN(IBIN)
280 CONTINUE
IF(COEFSU.GT.0D0) THEN
DO 290 IBIN=1,NBIN
COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
& (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
290 CONTINUE
ELSE
DO 300 IBIN=1,NBIN
COEFO(IBIN)=1D0/NBIN
300 CONTINUE
ENDIF
IF(IVAR.EQ.1) IOFF=0
IF(IVAR.EQ.2) IOFF=17
IF(IVAR.EQ.3) IOFF=7
IF(IVAR.EQ.4) IOFF=12
DO 310 IBIN=1,NBIN
ICOF=IOFF+IBIN
IF(IVAR.EQ.1) THEN
IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
ICOF=7
ENDIF
ENDIF
IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
ELSE
COEF(ISUB,ICOF)=COEFO(IBIN)
ENDIF
310 CONTINUE
IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
& (COEFO(IBIN),IBIN=1,NBIN)
320 CONTINUE
C...Find two most promising maxima among points previously determined.
DO 330 J=1,4
IACCMX(J)=0
SIGSMX(J)=0D0
330 CONTINUE
NMAX=0
DO 390 IACC=1,NACC
DO 340 J=1,30
VINT(10+J)=VINTPT(IACC,J)
340 CONTINUE
IF(ISTSB.NE.5) THEN
CALL PYSIGH(NCHN,SIGS)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGS=WTXS*SIGS
ENDIF
ELSE
SIGS=0D0
DO 350 IKIN3=1,MSTP(129)
CALL PYKMAP(5,0,0D0)
IF(MINT(51).EQ.1) GOTO 350
CALL PYSIGH(NCHN,SIGTMP)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGTMP=WTXS*SIGTMP
ENDIF
IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
350 CONTINUE
ENDIF
IEQ=0
DO 360 IMV=1,NMAX
IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
360 CONTINUE
IF(IEQ.EQ.0) THEN
DO 370 IMV=NMAX,1,-1
IIN=IMV+1
IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
IACCMX(IMV+1)=IACCMX(IMV)
SIGSMX(IMV+1)=SIGSMX(IMV)
370 CONTINUE
IIN=1
380 IACCMX(IIN)=IACC
SIGSMX(IIN)=SIGS
IF(NMAX.LE.1) NMAX=NMAX+1
ENDIF
390 CONTINUE
C...Read out starting position for search.
IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
SIGSAM=SIGSMX(1)
DO 440 IMAX=1,NMAX
IACC=IACCMX(IMAX)
MTAU=MVARPT(IACC,1)
MTAUP=MVARPT(IACC,2)
MYST=MVARPT(IACC,3)
MCTH=MVARPT(IACC,4)
VTAU=0.5D0
VYST=0.5D0
VCTH=0.5D0
VTAUP=0.5D0
C...Starting point and step size in parameter space.
DO 430 IRPT=1,2
DO 420 IVAR=1,4
IF(NPTS(IVAR).EQ.1) GOTO 420
IF(IVAR.EQ.1) VVAR=VTAU
IF(IVAR.EQ.2) VVAR=VTAUP
IF(IVAR.EQ.3) VVAR=VYST
IF(IVAR.EQ.4) VVAR=VCTH
IF(IVAR.EQ.1) MVAR=MTAU
IF(IVAR.EQ.2) MVAR=MTAUP
IF(IVAR.EQ.3) MVAR=MYST
IF(IVAR.EQ.4) MVAR=MCTH
IF(IRPT.EQ.1) VDEL=0.1D0
IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
& 0.98D0-VVAR))
IF(IRPT.EQ.1) VMAR=0.02D0
IF(IRPT.EQ.2) VMAR=0.002D0
IMOV0=1
IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
DO 410 IMOV=IMOV0,8
C...Define new point in parameter space.
IF(IMOV.EQ.0) THEN
INEW=2
VNEW=VVAR
ELSEIF(IMOV.EQ.1) THEN
INEW=3
VNEW=VVAR+VDEL
ELSEIF(IMOV.EQ.2) THEN
INEW=1
VNEW=VVAR-VDEL
ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
& VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
VVAR=VVAR+VDEL
SIGSSM(1)=SIGSSM(2)
SIGSSM(2)=SIGSSM(3)
INEW=3
VNEW=VVAR+VDEL
ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
& VVAR-2D0*VDEL.GT.VMAR) THEN
VVAR=VVAR-VDEL
SIGSSM(3)=SIGSSM(2)
SIGSSM(2)=SIGSSM(1)
INEW=1
VNEW=VVAR-VDEL
ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
VDEL=0.5D0*VDEL
VVAR=VVAR+VDEL
SIGSSM(1)=SIGSSM(2)
INEW=2
VNEW=VVAR
ELSE
VDEL=0.5D0*VDEL
VVAR=VVAR-VDEL
SIGSSM(3)=SIGSSM(2)
INEW=2
VNEW=VVAR
ENDIF
C...Convert to relevant variables and find derived new limits.
ILERR=0
IF(IVAR.EQ.1) THEN
VTAU=VNEW
CALL PYKMAP(1,MTAU,VTAU)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
CALL PYKLIM(4)
IF(MINT(51).EQ.1) ILERR=1
ENDIF
ENDIF
IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
& ILERR.EQ.0) THEN
IF(IVAR.EQ.2) VTAUP=VNEW
CALL PYKMAP(4,MTAUP,VTAUP)
ENDIF
IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
CALL PYKLIM(2)
IF(MINT(51).EQ.1) ILERR=1
ENDIF
IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
IF(IVAR.EQ.3) VYST=VNEW
CALL PYKMAP(2,MYST,VYST)
CALL PYKLIM(3)
IF(MINT(51).EQ.1) ILERR=1
ENDIF
IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
& ILERR.EQ.0) THEN
IF(IVAR.EQ.4) VCTH=VNEW
CALL PYKMAP(3,MCTH,VCTH)
ENDIF
IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
C...Evaluate cross-section. Save new maximum. Final maximum.
IF(ILERR.NE.0) THEN
SIGS=0.
ELSEIF(ISTSB.NE.5) THEN
CALL PYSIGH(NCHN,SIGS)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGS=WTXS*SIGS
ENDIF
ELSE
SIGS=0D0
DO 400 IKIN3=1,MSTP(129)
CALL PYKMAP(5,0,0D0)
IF(MINT(51).EQ.1) GOTO 400
CALL PYSIGH(NCHN,SIGTMP)
IF(MWTXS.EQ.1) THEN
CALL PYEVWT(WTXS)
SIGTMP=WTXS*SIGTMP
ENDIF
IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
400 CONTINUE
ENDIF
SIGSSM(INEW)=SIGS
IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
& IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
410 CONTINUE
420 CONTINUE
430 CONTINUE
440 CONTINUE
IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
XSEC(ISUB,1)=1.05D0*SIGSAM
C...Add extra headroom for UED
IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
& WTGAGA*XSEC(ISUB,1)
450 CONTINUE
IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
& PARP(174)*XSEC(ISUB,1)
IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
460 CONTINUE
MINT(51)=0
C...Print summary table.
IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
IF(MSTP(127).NE.1) THEN
WRITE(MSTU(11),5900)
CALL PYSTOP(1)
ELSE
WRITE(MSTU(11),6400)
MSTI(53)=1
ENDIF
ENDIF
IF(MSTP(122).GE.1) THEN
WRITE(MSTU(11),6000)
WRITE(MSTU(11),6100)
DO 470 ISUB=1,500
IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
& GOTO 470
IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
& .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
470 CONTINUE
WRITE(MSTU(11),6300)
ENDIF
C...Format statements for maximization results.
5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
&'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
&'cth',9X,'tau''',7X,'sigma')
5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
&'phase space.'/1X,'Process switched off!')
5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
&'cross-section.'/1X,'Process switched off!')
5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5500 FORMAT(1X,1P,10D11.3)
5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
&'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
&'cross-section.'/1X,'Execution stopped!')
6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
&'cross-section maximum search',1X,8('*'))
6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
&'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
&17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
&'cross-section.'/
&1X,'Execution will stop if you try to generate events.')
RETURN
END
C*********************************************************************
C...PYPILE
C...Initializes multiplicity distribution and selects mutliplicity
C...of pileup events, i.e. several events occuring at the same
C...beam crossing.
SUBROUTINE PYPILE(MPILE)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
C...Local arrays and saved variables.
DIMENSION WTI(0:200)
SAVE IMIN,IMAX,WTI,WTS
C...Sum of allowed cross-sections for pileup events.
IF(MPILE.EQ.1) THEN
VINT(131)=SIGT(0,0,5)
IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
IF(MSTP(133).LE.0) RETURN
C...Initialize multiplicity distribution at maximum.
XNAVE=VINT(131)*PARP(131)
IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
INAVE=MAX(1,MIN(200,NINT(XNAVE)))
WTI(INAVE)=1D0
WTS=WTI(INAVE)
WTN=WTI(INAVE)*INAVE
C...Find shape of multiplicity distribution below maximum.
IMIN=INAVE
DO 100 I=INAVE-1,1,-1
IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
IF(WTI(I).LT.1D-6) GOTO 110
WTS=WTS+WTI(I)
WTN=WTN+WTI(I)*I
IMIN=I
100 CONTINUE
C...Find shape of multiplicity distribution above maximum.
110 IMAX=INAVE
DO 120 I=INAVE+1,200
IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
IF(WTI(I).LT.1D-6) GOTO 130
WTS=WTS+WTI(I)
WTN=WTN+WTI(I)*I
IMAX=I
120 CONTINUE
130 VINT(132)=XNAVE
VINT(133)=WTN/WTS
IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
& WTS/(WTS+WTI(1)/XNAVE)
IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
IF(MSTP(133).GE.2) VINT(134)=XNAVE
C...Pick multiplicity of pileup events.
ELSE
IF(MSTP(133).LE.0) THEN
MINT(81)=MAX(1,MSTP(134))
ELSE
WTR=WTS*PYR(0)
DO 140 I=IMIN,IMAX
MINT(81)=I
WTR=WTR-WTI(I)
IF(WTR.LE.0D0) GOTO 150
140 CONTINUE
150 CONTINUE
ENDIF
ENDIF
C...Format statement for error message.
5000 FORMAT(1X,'Warning: requested average number of events per bunch',
&'crossing too large, ',1P,D12.4)
RETURN
END
C*********************************************************************
C...PYSAVE
C...Saves and restores parameter and cross section values for the
C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
C...Also makes random choice between alternatives.
SUBROUTINE PYSAVE(ISAVE,IGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
C...Local arrays and saved variables.
DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
&NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
&INTCP(15,20),RECP(15,20)
SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
C...Save list of subprocesses and cross-section information.
IF(ISAVE.EQ.1) THEN
ICP=0
DO 120 I=1,500
IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
ICP=ICP+1
NSUBCP(IGA,ICP)=I
MSUBCP(IGA,ICP)=MSUB(I)
DO 100 J=1,20
COEFCP(IGA,ICP,J)=COEF(I,J)
100 CONTINUE
DO 110 J=1,3
NGENCP(IGA,ICP,J)=NGEN(I,J)
XSECCP(IGA,ICP,J)=XSEC(I,J)
110 CONTINUE
120 CONTINUE
NCP(IGA)=ICP
DO 130 J=1,3
NGENCP(IGA,0,J)=NGEN(0,J)
XSECCP(IGA,0,J)=XSEC(0,J)
130 CONTINUE
DO 160 I1=0,6
DO 150 I2=0,6
DO 140 J=0,5
SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
140 CONTINUE
150 CONTINUE
160 CONTINUE
C...Save various common process variables.
DO 170 J=1,10
INTCP(IGA,J)=MINT(40+J)
170 CONTINUE
INTCP(IGA,11)=MINT(101)
INTCP(IGA,12)=MINT(102)
INTCP(IGA,13)=MINT(107)
INTCP(IGA,14)=MINT(108)
INTCP(IGA,15)=MINT(123)
RECP(IGA,1)=CKIN(3)
RECP(IGA,2)=VINT(318)
C...Save cross-section information only.
ELSEIF(ISAVE.EQ.2) THEN
DO 190 ICP=1,NCP(IGA)
I=NSUBCP(IGA,ICP)
DO 180 J=1,3
NGENCP(IGA,ICP,J)=NGEN(I,J)
XSECCP(IGA,ICP,J)=XSEC(I,J)
180 CONTINUE
190 CONTINUE
DO 200 J=1,3
NGENCP(IGA,0,J)=NGEN(0,J)
XSECCP(IGA,0,J)=XSEC(0,J)
200 CONTINUE
C...Choose between allowed alternatives.
ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
IF(ISAVE.EQ.4) THEN
XSUMCP=0D0
DO 210 IG=1,MINT(121)
XSUMCP=XSUMCP+XSECCP(IG,0,1)
210 CONTINUE
XSUMCP=XSUMCP*PYR(0)
DO 220 IG=1,MINT(121)
IGA=IG
XSUMCP=XSUMCP-XSECCP(IG,0,1)
IF(XSUMCP.LE.0D0) GOTO 230
220 CONTINUE
230 CONTINUE
ENDIF
C...Restore cross-section information.
DO 240 I=1,500
MSUB(I)=0
240 CONTINUE
DO 270 ICP=1,NCP(IGA)
I=NSUBCP(IGA,ICP)
MSUB(I)=MSUBCP(IGA,ICP)
DO 250 J=1,20
COEF(I,J)=COEFCP(IGA,ICP,J)
250 CONTINUE
DO 260 J=1,3
NGEN(I,J)=NGENCP(IGA,ICP,J)
XSEC(I,J)=XSECCP(IGA,ICP,J)
260 CONTINUE
270 CONTINUE
DO 280 J=1,3
NGEN(0,J)=NGENCP(IGA,0,J)
XSEC(0,J)=XSECCP(IGA,0,J)
280 CONTINUE
DO 310 I1=0,6
DO 300 I2=0,6
DO 290 J=0,5
SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
290 CONTINUE
300 CONTINUE
310 CONTINUE
C...Restore various common process variables.
DO 320 J=1,10
MINT(40+J)=INTCP(IGA,J)
320 CONTINUE
MINT(101)=INTCP(IGA,11)
MINT(102)=INTCP(IGA,12)
MINT(107)=INTCP(IGA,13)
MINT(108)=INTCP(IGA,14)
MINT(123)=INTCP(IGA,15)
CKIN(3)=RECP(IGA,1)
CKIN(1)=2D0*CKIN(3)
VINT(318)=RECP(IGA,2)
C...Sum up cross-section info (for PYSTAT).
ELSEIF(ISAVE.EQ.5) THEN
DO 330 I=1,500
MSUB(I)=0
NGEN(I,1)=0
NGEN(I,3)=0
XSEC(I,3)=0D0
330 CONTINUE
NGEN(0,1)=0
NGEN(0,2)=0
NGEN(0,3)=0
XSEC(0,3)=0
DO 350 IG=1,MINT(121)
DO 340 ICP=1,NCP(IG)
I=NSUBCP(IG,ICP)
IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
340 CONTINUE
NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
350 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYGAGA
C...For lepton beams it gives photon-hadron or photon-photon systems
C...to be treated with the ordinary machinery and combines this with a
C...description of the lepton -> lepton + photon branching.
SUBROUTINE PYGAGA(IGAGA,WTGAGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT5/
C...Local variables and data statement.
DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
&X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
DATA EPS/1D-4/
C...Initialize generation of photons inside leptons.
IF(IGAGA.EQ.1) THEN
C...Save quantities on incoming lepton system.
VINT(301)=VINT(1)
VINT(302)=VINT(2)
PMS(1)=VINT(303)**2
IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
PMS(2)=VINT(304)**2
IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
PMC(3)=VINT(302)-PMS(1)-PMS(2)
W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
C...Calculate range of x and Q2 values allowed in generation.
DO 100 I=1,2
PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
IF(MINT(140+I).NE.0) THEN
XMIN(I)=MAX(CKIN(59+2*I),EPS)
XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
& PMC(I),1D0-EPS)
YMIN=MAX(CKIN(71+2*I),EPS)
YMAX=MIN(CKIN(72+2*I),1D0-EPS)
IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
& (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
THEMIN=MAX(CKIN(67+2*I),0D0)
THEMAX=MIN(CKIN(68+2*I),PARU(1))
IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
& ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
& 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
& ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
& 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
C...W limits when lepton on one side only.
IF(MINT(143-I).EQ.0) THEN
XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
& (CKIN(78)**2-PMS(3-I))/PMC(I))
ENDIF
ENDIF
100 CONTINUE
C...W limits when lepton on both sides.
IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
& (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
& (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
& PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
& PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
ELSE
XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
ENDIF
ENDIF
C...Q2 and W values and photon flux weight factors for initialization.
ELSEIF(IGAGA.EQ.2) THEN
ISUB=MINT(1)
MINT(15)=0
MINT(16)=0
C...W value for photon on one or both sides, and for processes
C...with gamma-gamma cross section peaked at small shat.
IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
ELSE
VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
ENDIF
VINT(1)=SQRT(MAX(0D0,VINT(2)))
C...Upper estimate of photon flux weight factor.
C...Initialization Q2 scale. Flag incoming unresolved photon.
WTGAGA=1D0
DO 110 I=1,2
IF(MINT(140+I).NE.0) THEN
WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
& LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
& THEN
Q2INIT=5D0+Q2MIN(3-I)
ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
& (ISUB.EQ.139.AND.I.EQ.1)) THEN
Q2INIT=VINT(2)/3D0
ELSEIF(ISUB.EQ.140) THEN
Q2INIT=VINT(2)/2D0
ELSE
Q2INIT=Q2MIN(I)
ENDIF
VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
& MINT(14+I)=22
VINT(306+I)=VINT(2+I)**2
ENDIF
110 CONTINUE
VINT(320)=WTGAGA
C...Update pTmin and cross section information.
IF(MSTP(82).LE.1) THEN
PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
ELSE
PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
ENDIF
VINT(149)=4D0*PTMN**2/VINT(2)
VINT(154)=PTMN
CALL PYXTOT
VINT(318)=VINT(317)
C...Generate photons inside leptons and
C...calculate photon flux weight factors.
ELSEIF(IGAGA.EQ.3) THEN
ISUB=MINT(1)
MINT(15)=0
MINT(16)=0
C...Generate phase space point and check against cuts.
LOOP=0
120 LOOP=LOOP+1
DO 130 I=1,2
IF(MINT(140+I).NE.0) THEN
C...Pick x and Q2
X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
C...Cuts on internal consistency in x and Q2.
IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
& (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
C...Cuts on y and theta.
Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
& ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
& GOTO 120
C...Phi angle isotropic. Reconstruct pT.
PHI(I)=PARU(2)*PYR(0)
PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
& PMS(I))*SIN(THETA(I))
C...Store info on variables selected, for documentation purposes.
VINT(2+I)=-SQRT(Q2(I))
VINT(304+I)=X(I)
VINT(306+I)=Q2(I)
VINT(308+I)=Y(I)
VINT(310+I)=THETA(I)
VINT(312+I)=PHI(I)
ELSE
VINT(304+I)=1D0
VINT(306+I)=0D0
VINT(308+I)=1D0
VINT(310+I)=0D0
VINT(312+I)=0D0
ENDIF
130 CONTINUE
C...Cut on W combines info from two sides.
IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
& 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
& SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
& SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
IF(W2.LT.W2MIN) GOTO 120
IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
PMS1=-Q2(1)
PMS2=-Q2(2)
ELSEIF(MINT(141).NE.0) THEN
W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
PMS1=-Q2(1)
PMS2=PMS(2)
ELSEIF(MINT(142).NE.0) THEN
W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
PMS1=PMS(1)
PMS2=-Q2(2)
ENDIF
C...Store kinematics info for photon(s) in subsystem cm frame.
VINT(2)=W2
VINT(1)=SQRT(W2)
VINT(291)=0D0
VINT(292)=0D0
VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
VINT(296)=0D0
VINT(297)=0D0
VINT(298)=-VINT(293)
VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
C...Assign weight for photon flux; different for transverse and
C...longitudinal photons. Flag incoming unresolved photon.
WTGAGA=1D0
DO 140 I=1,2
IF(MINT(140+I).NE.0) THEN
WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
& LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
IF(MSTP(16).EQ.0) THEN
XY=X(I)
ELSE
WTGAGA=WTGAGA*X(I)/Y(I)
XY=Y(I)
ENDIF
IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
WTGAGA=WTGAGA*(1D0-XY)
ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
WTGAGA=WTGAGA*(1D0-XY)
ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
WTGAGA=WTGAGA*(1D0-XY)
ELSE
WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
& PMS(I)*XY**2/Q2(I))
ENDIF
IF(MINT(106+I).EQ.0) MINT(14+I)=22
ENDIF
140 CONTINUE
VINT(319)=WTGAGA
MINT(143)=LOOP
C...Update pTmin and cross section information.
IF(MSTP(82).LE.1) THEN
PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
ELSE
PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
ENDIF
VINT(149)=4D0*PTMN**2/VINT(2)
VINT(154)=PTMN
CALL PYXTOT
C...Reconstruct kinematics of photons inside leptons.
ELSEIF(IGAGA.EQ.4) THEN
C...Make place for incoming particles and scattered leptons.
MOVE=3
IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
MINT(4)=MINT(4)+MOVE
DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
IF(K(I,1).EQ.21) THEN
DO 150 J=1,5
K(I+MOVE,J)=K(I,J)
P(I+MOVE,J)=P(I,J)
V(I+MOVE,J)=V(I,J)
150 CONTINUE
IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
& K(I+MOVE,3)=K(I,3)+MOVE
IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
& K(I+MOVE,4)=K(I,4)+MOVE
IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
& K(I+MOVE,5)=K(I,5)+MOVE
ENDIF
160 CONTINUE
DO 170 I=MINT(84)+1,N
IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
& K(I,3)=K(I,3)+MOVE
170 CONTINUE
C...Fill in incoming particles.
DO 190 I=MINT(83)+1,MINT(83)+MOVE
DO 180 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
180 CONTINUE
190 CONTINUE
DO 200 I=1,2
K(MINT(83)+I,1)=21
IF(MINT(140+I).NE.0) THEN
K(MINT(83)+I,2)=MINT(140+I)
P(MINT(83)+I,5)=VINT(302+I)
ELSE
K(MINT(83)+I,2)=MINT(10+I)
P(MINT(83)+I,5)=VINT(2+I)
ENDIF
P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
& VINT(302))*(-1D0)**(I+1)
P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
200 CONTINUE
C...New mother-daughter relations in documentation section.
IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
K(MINT(83)+1,4)=MINT(83)+3
K(MINT(83)+1,5)=MINT(83)+5
K(MINT(83)+2,4)=MINT(83)+4
K(MINT(83)+2,5)=MINT(83)+6
K(MINT(83)+3,3)=MINT(83)+1
K(MINT(83)+5,3)=MINT(83)+1
K(MINT(83)+4,3)=MINT(83)+2
K(MINT(83)+6,3)=MINT(83)+2
ELSEIF(MINT(141).NE.0) THEN
K(MINT(83)+1,4)=MINT(83)+3
K(MINT(83)+1,5)=MINT(83)+4
K(MINT(83)+2,4)=MINT(83)+5
K(MINT(83)+3,3)=MINT(83)+1
K(MINT(83)+4,3)=MINT(83)+1
K(MINT(83)+5,3)=MINT(83)+2
ELSEIF(MINT(142).NE.0) THEN
K(MINT(83)+1,4)=MINT(83)+4
K(MINT(83)+2,4)=MINT(83)+3
K(MINT(83)+2,5)=MINT(83)+5
K(MINT(83)+3,3)=MINT(83)+2
K(MINT(83)+4,3)=MINT(83)+1
K(MINT(83)+5,3)=MINT(83)+2
ENDIF
C...Fill scattered lepton(s).
DO 210 I=1,2
IF(MINT(140+I).NE.0) THEN
LSC=MINT(83)+MIN(I+2,MOVE)
K(LSC,1)=21
K(LSC,2)=MINT(140+I)
P(LSC,1)=PT(I)*COS(PHI(I))
P(LSC,2)=PT(I)*SIN(PHI(I))
P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
& (-1D0)**(I-1)
P(LSC,5)=VINT(302+I)
ENDIF
210 CONTINUE
C...Find incoming four-vectors to subprocess.
K(N+1,1)=21
IF(MINT(141).NE.0) THEN
DO 220 J=1,4
P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
220 CONTINUE
ELSE
DO 230 J=1,4
P(N+1,J)=P(MINT(83)+1,J)
230 CONTINUE
ENDIF
K(N+2,1)=21
IF(MINT(142).NE.0) THEN
DO 240 J=1,4
P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
240 CONTINUE
ELSE
DO 250 J=1,4
P(N+2,J)=P(MINT(83)+2,J)
250 CONTINUE
ENDIF
C...Define boost and rotation between hadronic subsystem and
C...collision rest frame; boost hadronic subsystem to this frame.
DO 260 J=1,3
BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
260 CONTINUE
CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
BPHI=PYANGL(P(N+1,1),P(N+1,2))
CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
BTHETA=PYANGL(P(N+1,3),P(N+1,1))
CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
& BETA(3))
C...Add on scattered leptons to final state.
DO 280 I=1,2
IF(MINT(140+I).NE.0) THEN
LSC=MINT(83)+MIN(I+2,MOVE)
N=N+1
DO 270 J=1,5
K(N,J)=K(LSC,J)
P(N,J)=P(LSC,J)
V(N,J)=V(LSC,J)
270 CONTINUE
K(N,1)=1
K(N,3)=LSC
ENDIF
280 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYRAND
C...Generates quantities characterizing the high-pT scattering at the
C...parton level according to the matrix elements. Chooses incoming,
C...reacting partons, their momentum fractions and one of the possible
C...subprocesses.
SUBROUTINE PYRAND
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...User process initialization and event commonblocks.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPRUP/,/HEPEUP/
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYTCCO/COEFX(194:380,2)
COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
&/TCPARA/
C...Local arrays.
DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
C...Parameters and data used in elastic/diffractive treatment.
DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
&SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
C...Initial values, specifically for (first) semihard interaction.
MINT(10)=0
MINT(17)=0
MINT(18)=0
VINT(143)=1D0
VINT(144)=1D0
VINT(157)=0D0
VINT(158)=0D0
MFAIL=0
IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
ISUB=0
ISTSB=0
LOOP=0
100 LOOP=LOOP+1
MINT(51)=0
MINT(143)=1
VINT(97)=1D0
C...Start by assuming incoming photon is entering subprocess.
IF(MINT(11).EQ.22) THEN
MINT(15)=22
VINT(307)=VINT(3)**2
ENDIF
IF(MINT(12).EQ.22) THEN
MINT(16)=22
VINT(308)=VINT(4)**2
ENDIF
MINT(103)=MINT(11)
MINT(104)=MINT(12)
C...Choice of process type - first event of pileup.
INMULT=0
IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
ELSEIF(MINT(82).EQ.1) THEN
C...For gamma-p or gamma-gamma first pick between alternatives.
IGA=0
IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
MINT(122)=IGA
C...For real gamma + gamma with different nature, flip at random.
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
& MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
MINTSV=MINT(41)
MINT(41)=MINT(42)
MINT(42)=MINTSV
MINTSV=MINT(45)
MINT(45)=MINT(46)
MINT(46)=MINTSV
MINTSV=MINT(107)
MINT(107)=MINT(108)
MINT(108)=MINTSV
IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
ENDIF
C...Pick process type, possibly by user process machinery.
C...(If the latter, also event will be picked here.)
IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
CALL UPEVNT
CALL PYUPRE
ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
CALL UPEVNT
CALL PYUPRE
ISUB=0
110 ISUB=ISUB+1
IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
& ISUB.LT.500) GOTO 110
ELSE
RSUB=XSEC(0,1)*PYR(0)
DO 120 I=1,500
IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
ISUB=I
RSUB=RSUB-XSEC(I,1)
IF(RSUB.LE.0D0) GOTO 130
120 CONTINUE
130 IF(ISUB.EQ.95) ISUB=96
IF(ISUB.EQ.96) INMULT=1
IF(ISET(ISUB).EQ.11) THEN
IDPRUP=KFPR(ISUB,2)
CALL UPEVNT
CALL PYUPRE
ENDIF
ENDIF
C...Choice of inclusive process type - pileup events.
ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
RSUB=VINT(131)*PYR(0)
ISUB=96
IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
& ISUB=91
IF(ISUB.EQ.96) INMULT=1
ENDIF
C...Choice of photon energy and flux factor inside lepton.
IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
CALL PYGAGA(3,WTGAGA)
IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
CKIN(3)=MAX(VINT(285),VINT(154))
CKIN(1)=2D0*CKIN(3)
ENDIF
C...When necessary set direct/resolved photon by hand.
ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
ENDIF
C...Restrict direct*resolved processes to pTmin >= Q,
C...to avoid doublecounting with DIS.
IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
IF(MINT(15).EQ.22) THEN
CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
ELSE
CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
ENDIF
CKIN(1)=2D0*CKIN(3)
ENDIF
C...Set up for multiple interactions (may include impact parameter).
IF(INMULT.EQ.1) THEN
IF(MINT(35).LE.1) CALL PYMULT(2)
IF(MINT(35).GE.2) CALL PYMIGN(2)
ENDIF
C...Loopback point for minimum bias in photon physics.
LOOP2=0
140 LOOP2=LOOP2+1
IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
&NGEN(97,1)=NGEN(97,1)+MINT(143)
MINT(1)=ISUB
ISTSB=ISET(ISUB)
C...Random choice of flavour for some SUSY processes.
IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
C...~e_L ~nu_e or ~mu_L ~nu_mu.
IF(ISUB.EQ.210) THEN
KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
KFPR(ISUB,2)=KFPR(ISUB,1)+1
C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
ELSEIF(ISUB.EQ.213) THEN
KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
& ISUB.NE.257) THEN
IF(ISUB.GE.258) THEN
RKF=4D0
ELSE
RKF=5D0
ENDIF
IF(MOD(ISUB,2).EQ.0) THEN
KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
ELSE
KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
ENDIF
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
KSU1=KSUSY1
KSU2=KSUSY1
ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
KSU1=KSUSY2
KSU2=KSUSY2
ELSEIF(PYR(0).LT.0.5D0) THEN
KSU1=KSUSY1
KSU2=KSUSY2
ELSE
KSU1=KSUSY2
KSU2=KSUSY1
ENDIF
KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
KFPR(ISUB,2)=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
KSU1=KSUSY1
KSU2=KSUSY1
ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
KSU1=KSUSY2
KSU2=KSUSY2
ELSEIF(PYR(0).LT.0.5D0) THEN
KSU1=KSUSY1
KSU2=KSUSY2
ELSE
KSU1=KSUSY2
KSU2=KSUSY1
ENDIF
IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
RKF=5D0
ELSE
RKF=4D0
ENDIF
KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
ENDIF
ENDIF
C...Random choice of flavours for some UED processes
c...The production processes can generate a doublet pair,
c...a singlet pair, or a doublet + singlet.
IF(ISUB.EQ.313)THEN
C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
IF(PYR(0).LE.0.1)THEN
KFPR(ISUB,1)=5100001
ELSE
KFPR(ISUB,1)=5100002
ENDIF
KFPR(ISUB,2)=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
IF(PYR(0).LE.0.1)THEN
KFPR(ISUB,1)=5100001
ELSE
KFPR(ISUB,1)=5100002
ENDIF
KFPR(ISUB,2)=-KFPR(ISUB,1)
ELSEIF(ISUB.EQ.316)THEN
C...qi + qbarj -> q*_Di + q*_Sbarj
IF(PYR(0).LE.0.5)THEN
KFPR(ISUB,1)=5100001
c Changed from private pythia6410_ued code
c KFPR(ISUB,2)=-5010001
KFPR(ISUB,2)=-6100002
ELSE
KFPR(ISUB,1)=5100002
c Changed from private pythia6410_ued code
c KFPR(ISUB,2)=-5010002
KFPR(ISUB,2)=-6100001
ENDIF
ELSEIF(ISUB.EQ.317)THEN
C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
IF(PYR(0).LE.0.5)THEN
KFPR(ISUB,1)=5100001
KFPR(ISUB,2)=-5100002
ELSE
KFPR(ISUB,1)=5100002
KFPR(ISUB,2)=-5100001
ENDIF
ELSEIF(ISUB.EQ.318)THEN
C...qi + qj -> q*_Di + q*_Sj
IF(PYR(0).LE.0.5)THEN
KFPR(ISUB,1)=5100001
KFPR(ISUB,2)=6100002
ELSE
KFPR(ISUB,1)=5100002
KFPR(ISUB,2)=6100001
ENDIF
ENDIF
C...Find resonances (explicit or implicit in cross-section).
MINT(72)=0
KFR1=0
IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
KFR1=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
& ISUB.EQ.171.OR.ISUB.EQ.176) THEN
KFR1=23
ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
& ISUB.EQ.177) THEN
KFR1=24
ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
KFR1=25
IF(MSTP(46).EQ.5) THEN
KFR1=89
PMAS(89,1)=PARP(45)
PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
ENDIF
ELSEIF(ISUB.EQ.481) THEN
KFR1=9900001
ENDIF
CKMX=CKIN(2)
IF(CKMX.LE.0D0) CKMX=VINT(1)
KCR1=PYCOMP(KFR1)
IF(KCR1.EQ.0) KFR1=0
IF(KFR1.NE.0) THEN
IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
& CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
ENDIF
IF(KFR1.NE.0) THEN
TAUR1=PMAS(KCR1,1)**2/VINT(2)
GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
ENDIF
KFR2=0
KFR3=0
IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
$(ISUB.GE.361.AND.ISUB.LE.380))
$THEN
KFR2=23
IF(ISUB.EQ.141) THEN
KCR2=PYCOMP(KFR2)
IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
& CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
KFR2=0
ELSE
TAUR2=PMAS(KCR2,1)**2/VINT(2)
GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
MINT(72)=2
MINT(74)=KFR2
VINT(75)=TAUR2
VINT(76)=GAMR2
ENDIF
C...3 resonances at work: rho, omega, a
ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
& .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
MINT(72)=IRES
IF(IRES.GE.1) THEN
VINT(73)=XMAS(1)**2/VINT(2)
VINT(74)=XMAS(1)*XWID(1)/VINT(2)
TAUR1=VINT(73)
GAMR1=VINT(74)
KFR1=1
ENDIF
IF(IRES.GE.2) THEN
VINT(75)=XMAS(2)**2/VINT(2)
VINT(76)=XMAS(2)*XWID(2)/VINT(2)
TAUR2=VINT(75)
GAMR2=VINT(76)
KFR2=2
ENDIF
IF(IRES.EQ.3) THEN
VINT(77)=XMAS(3)**2/VINT(2)
VINT(78)=XMAS(3)*XWID(3)/VINT(2)
TAUR3=VINT(77)
GAMR3=VINT(78)
KFR3=3
ENDIF
C...Charged current: rho+- and a+-
ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
MINT(72)=IRES
IF(JRES.GE.1) THEN
VINT(73)=YMAS(1)**2/VINT(2)
VINT(74)=YMAS(1)*YWID(1)/VINT(2)
KFR1=1
TAUR1=VINT(73)
GAMR1=VINT(74)
ENDIF
IF(JRES.GE.2) THEN
VINT(75)=YMAS(2)**2/VINT(2)
VINT(76)=YMAS(2)*YWID(2)/VINT(2)
KFR2=2
TAUR2=VINT(73)
GAMR2=VINT(74)
ENDIF
KFR3=0
ENDIF
IF(ISUB.NE.141) THEN
IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
MINT(72)=2
ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
MINT(72)=2
MINT(74)=KFR3
VINT(75)=TAUR3
VINT(76)=GAMR3
ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
MINT(72)=2
MINT(73)=KFR2
VINT(73)=TAUR2
VINT(74)=GAMR2
MINT(74)=KFR3
VINT(75)=TAUR3
VINT(76)=GAMR3
ELSEIF(KFR1.NE.0) THEN
MINT(72)=1
ELSEIF(KFR2.NE.0) THEN
MINT(72)=1
MINT(73)=KFR2
VINT(73)=TAUR2
VINT(74)=GAMR2
ELSEIF(KFR3.NE.0) THEN
MINT(72)=1
MINT(73)=KFR3
VINT(73)=TAUR3
VINT(74)=GAMR3
ELSE
MINT(72)=0
ENDIF
ELSE
IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
ELSEIF(KFR2.NE.0) THEN
KFR1=KFR2
TAUR1=TAUR2
GAMR1=GAMR2
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
KFR2=0
ELSE
MINT(72)=0
ENDIF
ENDIF
ENDIF
C...Find product masses and minimum pT of process,
C...optionally with broadening according to a truncated Breit-Wigner.
VINT(63)=0D0
VINT(64)=0D0
MINT(71)=0
VINT(71)=CKIN(3)
IF(MINT(82).GE.2) VINT(71)=0D0
VINT(80)=1D0
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
NBW=0
DO 160 I=1,2
PMMN(I)=0D0
IF(KFPR(ISUB,I).EQ.0) THEN
ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
& PARP(41)) THEN
VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
ELSE
NBW=NBW+1
C...This prevents SUSY/t particles from becoming too light.
KFLW=KFPR(ISUB,I)
IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
KCW=PYCOMP(KFLW)
PMMN(I)=PMAS(KCW,1)
DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
& PMAS(PYCOMP(KFDP(IDC,2)),1)
IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
& PMAS(PYCOMP(KFDP(IDC,3)),1)
PMMN(I)=MIN(PMMN(I),PMSUM)
ENDIF
150 CONTINUE
ELSEIF(KFLW.EQ.6) THEN
PMMN(I)=PMAS(24,1)+PMAS(5,1)
ENDIF
ENDIF
160 CONTINUE
IF(NBW.GE.1) THEN
CKIN41=CKIN(41)
CKIN43=CKIN(43)
CKIN(41)=MAX(PMMN(1),CKIN(41))
CKIN(43)=MAX(PMMN(2),CKIN(43))
CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
CKIN(41)=CKIN41
CKIN(43)=CKIN43
IF(MINT(51).EQ.1) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
VINT(63)=PQM3**2
VINT(64)=PQM4**2
ENDIF
IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
ENDIF
C...Prepare for additional variable choices in 2 -> 3.
IF(ISTSB.EQ.5) THEN
VINT(201)=0D0
IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
VINT(206)=VINT(201)
IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
VINT(204)=PMAS(23,1)
IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
& VINT(204)=PMAS(24,1)
IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
& ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
& VINT(204)=VINT(201)
VINT(209)=VINT(204)
IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
ENDIF
C...Select incoming VDM particle (rho/omega/phi/J/psi).
IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
&(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
VRN=PYR(0)*SIGT(0,0,5)
IF(MINT(101).LE.1) THEN
I1MN=0
I1MX=0
ELSE
I1MN=1
I1MX=MINT(101)
ENDIF
IF(MINT(102).LE.1) THEN
I2MN=0
I2MX=0
ELSE
I2MN=1
I2MX=MINT(102)
ENDIF
DO 180 I1=I1MN,I1MX
KFV1=110*I1+3
DO 170 I2=I2MN,I2MX
KFV2=110*I2+3
VRN=VRN-SIGT(I1,I2,5)
IF(VRN.LE.0D0) GOTO 190
170 CONTINUE
180 CONTINUE
190 IF(MINT(101).GE.2) MINT(103)=KFV1
IF(MINT(102).GE.2) MINT(104)=KFV2
ENDIF
IF(ISTSB.EQ.0) THEN
C...Elastic scattering or single or double diffractive scattering.
C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
MINT(103)=MINT(11)
MINT(104)=MINT(12)
PMM(1)=VINT(3)
PMM(2)=VINT(4)
IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
JJ=ISUB-90
VRN=PYR(0)*SIGT(0,0,JJ)
IF(MINT(101).LE.1) THEN
I1MN=0
I1MX=0
ELSE
I1MN=1
I1MX=MINT(101)
ENDIF
IF(MINT(102).LE.1) THEN
I2MN=0
I2MX=0
ELSE
I2MN=1
I2MX=MINT(102)
ENDIF
DO 210 I1=I1MN,I1MX
KFV1=110*I1+3
DO 200 I2=I2MN,I2MX
KFV2=110*I2+3
VRN=VRN-SIGT(I1,I2,JJ)
IF(VRN.LE.0D0) GOTO 220
200 CONTINUE
210 CONTINUE
220 IF(MINT(101).GE.2) THEN
MINT(103)=KFV1
PMM(1)=PYMASS(KFV1)
ENDIF
IF(MINT(102).GE.2) THEN
MINT(104)=KFV2
PMM(2)=PYMASS(KFV2)
ENDIF
ENDIF
VINT(67)=PMM(1)
VINT(68)=PMM(2)
C...Select mass for GVMD states (rejecting previous assignment).
Q0S=4D0*PARP(15)**2
Q1S=4D0*VINT(154)**2
LOOP3=0
230 LOOP3=LOOP3+1
DO 240 JT=1,2
IF(MINT(106+JT).EQ.3) THEN
PS=VINT(2+JT)**2
PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
& (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
& PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
ENDIF
240 CONTINUE
IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
& GOTO 230
GOTO 100
ENDIF
C...Side/sides of diffractive system.
MINT(17)=0
MINT(18)=0
IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
C...Find masses of particles and minimal masses of diffractive states.
DO 250 JT=1,2
PDIF(JT)=PMM(JT)
VINT(68+JT)=PDIF(JT)
IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
250 CONTINUE
SH=VINT(2)
SQM1=PMM(1)**2
SQM2=PMM(2)**2
SQM3=PDIF(1)**2
SQM4=PDIF(2)**2
SMRES1=(PMM(1)+PMRC)**2
SMRES2=(PMM(2)+PMRC)**2
C...Find elastic slope and lower limit diffractive slope.
IHA=MAX(2,IABS(MINT(103))/110)
IF(IHA.GE.5) IHA=1
IHB=MAX(2,IABS(MINT(104))/110)
IF(IHB.GE.5) IHB=1
IF(ISUB.EQ.91) THEN
BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
ELSEIF(ISUB.EQ.92) THEN
BMN=MAX(2D0,2D0*BHAD(IHB))
ELSEIF(ISUB.EQ.93) THEN
BMN=MAX(2D0,2D0*BHAD(IHA))
ELSEIF(ISUB.EQ.94) THEN
BMN=2D0*ALP*4D0
ENDIF
C...Determine maximum possible t range and coefficient of generation.
SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
& (SQM1*SQM4-SQM2*SQM3)/SH
THL=-0.5D0*(THA+THB)
THU=THC/THL
THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
C...Select diffractive mass/masses according to dm^2/m^2.
LOOP3=0
260 LOOP3=LOOP3+1
DO 270 JT=1,2
IF(MINT(16+JT).EQ.0) THEN
PDIF(2+JT)=PDIF(JT)
ELSE
PMMIN=PDIF(JT)
PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
ENDIF
270 CONTINUE
SQM3=PDIF(3)**2
SQM4=PDIF(4)**2
C..Additional mass factors, including resonance enhancement.
IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
IF(LOOP3.LT.100) GOTO 260
GOTO 100
ENDIF
IF(ISUB.EQ.92) THEN
FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
ELSEIF(ISUB.EQ.93) THEN
FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
ELSEIF(ISUB.EQ.94) THEN
FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
& (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
& (1D0+CRES*SMRES2/(SMRES2+SQM4))
IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
ENDIF
C...Select t according to exp(Bmn*t) and correct to right slope.
TH=THU+LOG(1D0+THRND*PYR(0))/BMN
IF(ISUB.GE.92) THEN
IF(ISUB.EQ.92) THEN
BADD=2D0*ALP*LOG(SH/SQM3)
IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
ELSEIF(ISUB.EQ.93) THEN
BADD=2D0*ALP*LOG(SH/SQM4)
IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
ELSEIF(ISUB.EQ.94) THEN
BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
ENDIF
IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
ENDIF
C...Check whether m^2 and t choices are consistent.
SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
IF(THB.LE.1D-8) GOTO 260
THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
& (SQM1*SQM4-SQM2*SQM3)/SH
THLM=-0.5D0*(THA+THB)
THUM=THC/THLM
IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
C...Information to output.
VINT(21)=1D0
VINT(22)=0D0
VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
VINT(45)=TH
VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
VINT(63)=PDIF(3)**2
VINT(64)=PDIF(4)**2
VINT(283)=PMM(1)**2/4D0
VINT(284)=PMM(2)**2/4D0
C...Note: in the following, by In is meant the integral over the
C...quantity multiplying coefficient cn.
C...Choose tau according to h1(tau)/tau, where
C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
C...I1/I5*c5*1/(tau+tau_R') +
C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
C...I1/I7*c7*tau/(1.-tau), and
C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
CALL PYKLIM(1)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
RTAU=PYR(0)
MTAU=1
IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
& MTAU=5
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
& COEF(ISUB,5)) MTAU=6
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
& COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
C...Additional check to handle techni-processes with extra resonance
C....Only modify tau treatment
IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
& THEN
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
& +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
& +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
& +COEFX(ISUB,1)) MTAU=9
ENDIF
CALL PYKMAP(1,MTAU,PYR(0))
C...2 -> 3, 4 processes:
C...Choose tau' according to h4(tau,tau')/tau', where
C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
CALL PYKLIM(4)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
RTAUP=PYR(0)
MTAUP=1
IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
CALL PYKMAP(4,MTAUP,PYR(0))
ENDIF
C...Choose y* according to h2(y*), where
C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
C...and c1 + c2 + c3 + c4 + c5 = 1.
CALL PYKLIM(2)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
& COEF(ISUB,11)) MYST=5
CALL PYKMAP(2,MYST,PYR(0))
C...2 -> 2 processes:
C...Choose cos(theta-hat) (cth) according to h3(cth), where
C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
C...and c0 + c1 + c2 + c3 + c4 = 1.
CALL PYKLIM(3)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
RCTH=PYR(0)
MCTH=1
IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
& COEF(ISUB,16)) MCTH=5
CALL PYKMAP(3,MCTH,PYR(0))
ENDIF
C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
IF(ISTSB.EQ.5) THEN
CALL PYKMAP(5,0,0D0)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
ENDIF
C...DIS as f + gamma* -> f process: set dummy values.
ELSEIF(ISTSB.EQ.8) THEN
VINT(21)=0.9D0
VINT(22)=0D0
VINT(23)=0D0
VINT(47)=0D0
VINT(48)=0D0
C...Low-pT or multiple interactions (first semihard interaction).
ELSEIF(ISTSB.EQ.9) THEN
IF(MINT(35).LE.1) CALL PYMULT(3)
IF(MINT(35).GE.2) CALL PYMIGN(3)
ISUB=MINT(1)
C...Study user-defined process: kinematics plus weight.
ELSEIF(ISTSB.EQ.11) THEN
IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
& PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
MSTI(51)=0
IF(NUP.LE.0) THEN
MINT(51)=2
MSTI(51)=1
IF(MINT(82).EQ.1) THEN
NGEN(0,1)=NGEN(0,1)-1
NGEN(ISUB,1)=NGEN(ISUB,1)-1
ENDIF
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
RETURN
ENDIF
C...Extract cross section event weight.
IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
SIGS=1D-9*XWGTUP
ELSE
SIGS=1D-9*XSECUP(KFPR(ISUB,1))
ENDIF
IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
VINT(97)=SIGN(1D0,XWGTUP)
ELSE
VINT(97)=1D-9*XWGTUP
ENDIF
C...Construct 'trivial' kinematical variables needed.
KFL1=IDUP(1)
KFL2=IDUP(2)
VINT(41)=PUP(4,1)/EBMUP(1)
VINT(42)=PUP(4,2)/EBMUP(2)
IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
& '(listing follows):')
CALL PYLIST(7)
ENDIF
VINT(21)=VINT(41)*VINT(42)
VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
VINT(44)=VINT(21)*VINT(2)
VINT(43)=SQRT(MAX(0D0,VINT(44)))
VINT(55)=SCALUP
IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
VINT(56)=VINT(55)**2
VINT(57)=AQEDUP
VINT(58)=AQCDUP
C...Construct other kinematical variables needed (approximately).
VINT(23)=0D0
VINT(26)=VINT(21)
VINT(45)=-0.5D0*VINT(44)
VINT(46)=-0.5D0*VINT(44)
VINT(49)=VINT(43)
VINT(50)=VINT(44)
VINT(51)=VINT(55)
VINT(52)=VINT(56)
VINT(53)=VINT(55)
VINT(54)=VINT(56)
VINT(25)=0D0
VINT(48)=0D0
IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
& '(PYRAND:) unacceptable ISTUP code for incoming particles')
DO 280 IUP=3,NUP
IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
& '(PYRAND:) unacceptable ISTUP code for particles')
IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
& PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
& PUP(2,IUP)**2)
280 CONTINUE
VINT(47)=SQRT(VINT(48))
ENDIF
C...Choose azimuthal angle.
VINT(24)=0D0
IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
C...Check against user cuts on kinematics at parton level.
MINT(51)=0
IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
IF(MINT(51).NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
MCUT=0
IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
& CALL PYKCUT(MCUT)
IF(MCUT.NE.0) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
ENDIF
IF(ISTSB.LE.10) THEN
C... If internal process, call PYSIGH
CALL PYSIGH(NCHN,SIGS)
ELSE
C... If external process, still have to set MI starting scale
IF (MSTP(86).EQ.1) THEN
C... Limit phase space by xT2 of hard interaction
C... (gives undercounting of MI when ext proc != dijets)
XT2GMX = VINT(25)
ELSE
C... All accessible phase space allowed
C... (gives double counting of MI when ext proc = dijets)
XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
ENDIF
VINT(62)=0.25D0*XT2GMX*VINT(2)
VINT(61)=SQRT(MAX(0D0,VINT(62)))
ENDIF
SIGSOR=SIGS
SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
C...Multiply cross section by lepton -> photon flux factor.
IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
SIGS=WTGAGA*SIGS
DO 290 ICHN=1,NCHN
SIGH(ICHN)=WTGAGA*SIGH(ICHN)
290 CONTINUE
SIGLPT=WTGAGA*SIGLPT
ENDIF
C...Multiply cross-section by user-defined weights.
IF(MSTP(173).EQ.1) THEN
SIGS=PARP(173)*SIGS
DO 300 ICHN=1,NCHN
SIGH(ICHN)=PARP(173)*SIGH(ICHN)
300 CONTINUE
SIGLPT=PARP(173)*SIGLPT
ENDIF
WTXS=1D0
SIGSWT=SIGS
VINT(99)=1D0
VINT(100)=1D0
IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
& MSUB(95).EQ.0) CALL PYEVWT(WTXS)
SIGSWT=WTXS*SIGS
VINT(99)=WTXS
IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
ENDIF
C...Calculations for Monte Carlo estimate of all cross-sections.
IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
IF(MSTP(142).LE.1) THEN
XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
ELSE
XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
ENDIF
ELSEIF(MINT(82).EQ.1) THEN
XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
ENDIF
IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
&MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
C...Multiple interactions: store results of cross-section calculation.
IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
VINT(153)=SIGSOR
IF(MINT(35).LE.1) CALL PYMULT(4)
IF(MINT(35).GE.2) CALL PYMIGN(4)
ENDIF
C...Ratio of actual to maximum cross section.
IF(ISTSB.NE.11) THEN
VIOL=SIGSWT/XSEC(ISUB,1)
IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
ELSE
VIOL=1D0
ENDIF
C...Check that weight not negative.
IF(MSTP(123).LE.0) THEN
IF(VIOL.LT.-1D-3) THEN
WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
& VINT(22),VINT(23),VINT(26)
CALL PYSTOP(2)
ENDIF
ELSE
IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
VINT(109)=VIOL
IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
& VINT(22),VINT(23),VINT(26)
ENDIF
ENDIF
C...Weighting using estimate of maximum of differential cross-section.
RATND=1D0
IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
IF(VIOL.LT.PYR(0)) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
GOTO 100
ENDIF
ELSEIF(MFAIL.EQ.0) THEN
RATND=SIGLPT/XSEC(95,1)
VIOL=VIOL/RATND
IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
& (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
ISUB=0
GOTO 100
ENDIF
IF(VIOL.LT.PYR(0)) THEN
GOTO 140
ENDIF
ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
IF(VIOL.LT.PYR(0)) THEN
MSTI(61)=1
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
RETURN
ENDIF
ELSE
RATND=SIGLPT/XSEC(95,1)
IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
MSTI(61)=1
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
RETURN
ENDIF
VIOL=VIOL/RATND
IF(VIOL.LT.PYR(0)) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
GOTO 100
ENDIF
ENDIF
C...Check for possible violation of estimated maximum of differential
C...cross-section used in weighting.
IF(MSTP(123).LE.0) THEN
IF(VIOL.GT.1D0) THEN
WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
& VINT(22),VINT(23),VINT(26)
CALL PYSTOP(2)
ENDIF
ELSEIF(MSTP(123).EQ.1) THEN
IF(VIOL.GT.VINT(108)) THEN
VINT(108)=VIOL
IF(VIOL.GT.1.0001D0) THEN
MINT(10)=1
WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
& VINT(22),VINT(23),VINT(26)
ENDIF
ENDIF
ELSEIF(VIOL.GT.VINT(108)) THEN
VINT(108)=VIOL
IF(VIOL.GT.1D0) THEN
MINT(10)=1
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
& THEN
XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
IF(KFPR(ISUB,1).LE.9) THEN
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
& XMAXUP(KFPR(ISUB,1))
ELSEIF(KFPR(ISUB,1).LE.99) THEN
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
& XMAXUP(KFPR(ISUB,1))
ELSE
IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
& XMAXUP(KFPR(ISUB,1))
ENDIF
ENDIF
IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
XDIF=XSEC(ISUB,1)*(VIOL-1D0)
XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
& XSEC(0,1)=XSEC(0,1)+XDIF
IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
& VINT(22),VINT(23),VINT(26)
IF(ISUB.LE.9) THEN
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
ELSEIF(ISUB.LE.99) THEN
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
ELSE
IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
ENDIF
ENDIF
VINT(108)=1D0
ENDIF
ENDIF
C...Multiple interactions: choose impact parameter (if not already done).
IF(MINT(39).EQ.0) VINT(148)=1D0
IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
&MSTP(82).GE.3) THEN
IF(MINT(35).LE.1) CALL PYMULT(5)
IF(MINT(35).GE.2) CALL PYMIGN(5)
IF(VINT(150).LT.PYR(0)) THEN
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
IF(MFAIL.EQ.1) THEN
MSTI(61)=1
RETURN
ENDIF
GOTO 100
ENDIF
ENDIF
IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
ENDIF
IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
C...Choose flavour of reacting partons (and subprocess).
IF(ISTSB.GE.11) GOTO 320
RSIGS=SIGS*PYR(0)
QT2=VINT(48)
RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
&(VINT(1)/PARP(89))**PARP(90))**2))**2)
IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
&PYR(0).GT.RQQBAR)) THEN
DO 310 ICHN=1,NCHN
KFL1=ISIG(ICHN,1)
KFL2=ISIG(ICHN,2)
MINT(2)=ISIG(ICHN,3)
RSIGS=RSIGS-SIGH(ICHN)
IF(RSIGS.LE.0D0) GOTO 320
310 CONTINUE
C...Multiple interactions: choose qqbar preferentially at small pT.
ELSEIF(ISUB.EQ.96) THEN
MINT(105)=MINT(103)
MINT(109)=MINT(107)
CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
MINT(105)=MINT(104)
MINT(109)=MINT(108)
CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
MINT(1)=11
MINT(2)=1
IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
C...Low-pT: choose string drawing configuration.
ELSE
KFL1=21
KFL2=21
RSIGS=6D0*PYR(0)
MINT(2)=1
IF(RSIGS.GT.1D0) MINT(2)=2
IF(RSIGS.GT.2D0) MINT(2)=3
ENDIF
C...Reassign QCD process. Partons before initial state radiation.
320 IF(MINT(2).GT.10) THEN
MINT(1)=MINT(2)/10
MINT(2)=MOD(MINT(2),10)
ENDIF
IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
&NGEN(MINT(1),2)+1
MINT(15)=KFL1
MINT(16)=KFL2
MINT(13)=MINT(15)
MINT(14)=MINT(16)
VINT(141)=VINT(41)
VINT(142)=VINT(42)
VINT(151)=0D0
VINT(152)=0D0
C...Calculate x value of photon for parton inside photon inside e.
DO 350 JT=1,2
MINT(18+JT)=0
VINT(154+JT)=0D0
MSPLI=0
IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
IF(MSPLI.EQ.2) THEN
KFLH=MINT(14+JT)
XHRD=VINT(140+JT)
Q2HRD=VINT(54)
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
VINT(120)=VINT(2+JT)
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
ELSE
CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
ENDIF
WTMX=4D0*XPQ(KFLH)
IF(MSTP(13).EQ.2) THEN
Q2PMS=Q2HRD/PMAS(11,1)**2
WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
ENDIF
330 XE=XHRD**PYR(0)
XG=MIN(1D0-1D-10,XHRD/XE)
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(22,XG,Q2HRD,XPQ)
ELSE
CALL PYPDFL(22,XG,Q2HRD,XPQ)
ENDIF
WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
IF(WT.LT.PYR(0)*WTMX) GOTO 330
MINT(18+JT)=1
VINT(154+JT)=XE
DO 340 KFLS=-25,25
XSFX(JT,KFLS)=XPQ(KFLS)
340 CONTINUE
ENDIF
350 CONTINUE
C...Pick scale where photon is resolved.
Q0S=PARP(15)**2
Q1S=VINT(154)**2
VINT(283)=0D0
IF(MINT(107).EQ.3) THEN
IF(MSTP(66).EQ.1) THEN
VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
ELSEIF(MSTP(66).EQ.2) THEN
PS=VINT(3)**2
Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
& EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
Q2INT=SQRT(Q0S*Q2EFF)
VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
ELSEIF(MSTP(66).EQ.3) THEN
VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
ELSEIF(MSTP(66).GE.4) THEN
PS=0.25D0*VINT(3)**2
VINT(283)=(Q0S+PS)*(Q1S+PS)/
& (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
ENDIF
ENDIF
VINT(284)=0D0
IF(MINT(108).EQ.3) THEN
IF(MSTP(66).EQ.1) THEN
VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
ELSEIF(MSTP(66).EQ.2) THEN
PS=VINT(4)**2
Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
& EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
Q2INT=SQRT(Q0S*Q2EFF)
VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
ELSEIF(MSTP(66).EQ.3) THEN
VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
ELSEIF(MSTP(66).GE.4) THEN
PS=0.25D0*VINT(4)**2
VINT(284)=(Q0S+PS)*(Q1S+PS)/
& (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
ENDIF
ENDIF
IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
C...Format statements for differential cross-section maximum violations.
5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
&'in event',1X,I7,'D0'/1X,'Execution stopped!')
5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
&D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
&'in event',1X,I7)
5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
&'in event',1X,I7,'D0'/1X,'Execution stopped!')
5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
&'in event',1X,I7)
5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
RETURN
END
C*********************************************************************
C...PYSCAT
C...Finds outgoing flavours and event type; sets up the kinematics
C...and colour flow of the hard scattering
SUBROUTINE PYSCAT
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...User process event common block.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
&/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
&/PYTCSM/,/PYPUED/
C...Local arrays and saved variables
DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
&PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
INTEGER IOKFLA(6),IIFLAV
C...UED related declarations:
C...equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
DIMENSION IUEDEQ(475),MUED(2)
DATA (IUEDEQ(I),I=451,475)/
& 6100001,6100002,6100003,6100004,6100005,6100006,
& 5100001,5100002,5100003,5100004,5100005,5100006,
& 6100011,6100013,6100015,
& 5100012,5100011,5100014,5100013,5100016,5100015,
& 5100021,5100022,5100023,5100024/
SAVE VINTSV
C...Read out process
ISUB=MINT(1)
ISUBSV=ISUB
C...Restore information for low-pT processes
IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
DO 100 J=41,66
VINT(J)=VINTSV(J)
100 CONTINUE
ENDIF
C...Convert H' or A process into equivalent H one
IHIGG=1
KFHIGG=25
IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
&ISUB.LE.190)) THEN
IHIGG=2
IF(MOD(ISUB-1,10).GE.5) IHIGG=3
KFHIGG=33+IHIGG
IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
ENDIF
IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
C...Convert bottomonium process into equivalent charmonium ones.
IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
C...Choice of subprocess, number of documentation lines
IDOC=6+ISET(ISUB)
IF(ISUB.EQ.95) IDOC=8
IF(ISET(ISUB).EQ.5) IDOC=9
IF(ISET(ISUB).EQ.11) IDOC=4+NUP
MINT(3)=IDOC-6
IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
MINT(4)=IDOC
IPU1=MINT(84)+1
IPU2=MINT(84)+2
IPU3=MINT(84)+3
IPU4=MINT(84)+4
IPU5=MINT(84)+5
IPU6=MINT(84)+6
C...Reset K, P and V vectors. Store incoming particles
DO 120 JT=1,MSTP(126)+100
I=MINT(83)+JT
IF(I.GT.MSTU(4)) GOTO 120
DO 110 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
110 CONTINUE
120 CONTINUE
DO 140 JT=1,2
I=MINT(83)+JT
K(I,1)=21
K(I,2)=MINT(10+JT)
DO 130 J=1,5
P(I,J)=VINT(285+5*JT+J)
130 CONTINUE
140 CONTINUE
MINT(6)=2
KFRES=0
C...Store incoming partons in their CM-frame. Save pdf value.
SH=VINT(44)
SHR=SQRT(SH)
SHP=VINT(26)*VINT(2)
SHPR=SQRT(SHP)
SHUSER=SHR
IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
DO 150 JT=1,2
I=MINT(84)+JT
K(I,1)=14
K(I,2)=MINT(14+JT)
K(I,3)=MINT(83)+2+JT
P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
P(I,4)=0.5D0*SHUSER
IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
VINT(38+JT)=XSFX(JT,MINT(14+JT))
ELSE
VINT(38+JT)=1D0
ENDIF
150 CONTINUE
C...Copy incoming partons to documentation lines
DO 170 JT=1,2
I1=MINT(83)+4+JT
I2=MINT(84)+JT
K(I1,1)=21
K(I1,2)=K(I2,2)
K(I1,3)=I1-2
DO 160 J=1,5
P(I1,J)=P(I2,J)
160 CONTINUE
170 CONTINUE
C...Choose new quark/lepton flavour for relevant annihilation graphs
IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
&ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
&(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
IGLGA=21
IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
DO 190 I=1,MDCY(IGLGA,3)
KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
IF(RKFL.LE.0D0) GOTO 200
190 CONTINUE
200 CONTINUE
IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
& .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
IF(KFLF.GE.4) GOTO 180
ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
& OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
KFLF=4
MINT(2)=MINT(2)-2
ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
& OR.ISUB.EQ.316) THEN
KFLF=5
MINT(2)=MINT(2)-4
ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
& .AND.IABS(KFLF).GE.3) THEN
FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
& VINT(44)**2
FACCIB=VINT(46)**2/RTCM(41)**4
IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
KFLF=5
MINT(2)=1
ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
IF(KFLF.EQ.5) GOTO 180
ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
ENDIF
ENDIF
C...Final state flavours and colour flow: default values
JS=1
MINT(21)=MINT(15)
MINT(22)=MINT(16)
MINT(23)=0
MINT(24)=0
KCC=20
KCS=ISIGN(1,MINT(15))
IF(ISET(ISUB).EQ.11) THEN
C...User-defined processes: find products
MINT(3)=0
DO 210 IUP=3,NUP
IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
MINT(21+IUP)=IDUP(IUP)
ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
& ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
ELSEIF(IDUP(IUP).EQ.0) THEN
ELSE
MINT(3)=MINT(3)+1
IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
ENDIF
210 CONTINUE
ELSEIF(ISUB.LE.10) THEN
IF(ISUB.EQ.1) THEN
C...f + fbar -> gamma*/Z0
KFRES=23
ELSEIF(ISUB.EQ.2) THEN
C...f + fbar' -> W+/-
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(24,KCH1+KCH2)
ELSEIF(ISUB.EQ.3) THEN
C...f + fbar -> h0 (or H0, or A0)
KFRES=KFHIGG
ELSEIF(ISUB.EQ.4) THEN
C...gamma + W+/- -> W+/-
ELSEIF(ISUB.EQ.5) THEN
C...Z0 + Z0 -> h0
XH=SH/SHP
MINT(21)=MINT(15)
MINT(22)=MINT(16)
PMQ(1)=PYMASS(MINT(21))
PMQ(2)=PYMASS(MINT(22))
220 JT=INT(1.5D0+PYR(0))
ZMIN=2D0*PMQ(JT)/SHPR
ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
& (SHPR*(SHPR-PMQ(3-JT)))
ZMAX=MIN(1D0-XH,ZMAX)
Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
& (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 220
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
Z(3-JT)=1D0-XH/(1D0-Z(JT))
SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 220
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
PHIR=PARU(2)*PYR(0)
CPHI=COS(PHIR)
ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
& SQRT(1D0-CTHE(2)**2)*CPHI
Z1=2D0-Z(JT)
Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
& PMQ(3-JT)**2/SHP))
ZMIN=2D0*PMQ(3-JT)/SHPR
ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
KCC=22
KFRES=25
ELSEIF(ISUB.EQ.6) THEN
C...Z0 + W+/- -> W+/-
ELSEIF(ISUB.EQ.7) THEN
C...W+ + W- -> Z0
ELSEIF(ISUB.EQ.8) THEN
C...W+ + W- -> h0
XH=SH/SHP
230 DO 260 JT=1,2
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 240 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 250
240 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
250 PMQ(JT)=PYMASS(MINT(20+JT))
260 CONTINUE
JT=INT(1.5D0+PYR(0))
ZMIN=2D0*PMQ(JT)/SHPR
ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
& (SHPR*(SHPR-PMQ(3-JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(ZMIN.GE.ZMAX) GOTO 230
Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
& (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 230
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
Z(3-JT)=1D0-XH/(1D0-Z(JT))
SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 230
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
PHIR=PARU(2)*PYR(0)
CPHI=COS(PHIR)
ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
& SQRT(1D0-CTHE(2)**2)*CPHI
Z1=2D0-Z(JT)
Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
& PMQ(3-JT)**2/SHP))
ZMIN=2D0*PMQ(3-JT)/SHPR
ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
KCC=22
KFRES=25
ELSEIF(ISUB.EQ.10) THEN
C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
IF(MINT(2).EQ.1) THEN
KCC=22
ELSE
C...W exchange: need to mix flavours according to CKM matrix
DO 280 JT=1,2
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 270 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 280
270 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
280 CONTINUE
KCC=22
ENDIF
ENDIF
ELSEIF(ISUB.LE.20) THEN
IF(ISUB.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
MINT(21)=ISIGN(KFLF,MINT(15))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
MINT(21)=21
MINT(22)=21
KCC=MINT(2)+4
ELSEIF(ISUB.EQ.14) THEN
C...f + fbar -> g + gamma; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=21
MINT(23-JS)=22
KCC=17+JS
ELSEIF(ISUB.EQ.15) THEN
C...f + fbar -> g + Z0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=21
MINT(23-JS)=23
KCC=17+JS
ELSEIF(ISUB.EQ.16) THEN
C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
MINT(20+JS)=21
MINT(23-JS)=ISIGN(24,KCH1+KCH2)
KCC=17+JS
ELSEIF(ISUB.EQ.17) THEN
C...f + fbar -> g + h0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=21
MINT(23-JS)=25
KCC=17+JS
ELSEIF(ISUB.EQ.18) THEN
C...f + fbar -> gamma + gamma; th arbitrary
MINT(21)=22
MINT(22)=22
ELSEIF(ISUB.EQ.19) THEN
C...f + fbar -> gamma + Z0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=22
MINT(23-JS)=23
ELSEIF(ISUB.EQ.20) THEN
C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
C...(p(fbar')-p(W+))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
MINT(20+JS)=22
MINT(23-JS)=ISIGN(24,KCH1+KCH2)
ENDIF
ELSEIF(ISUB.LE.30) THEN
IF(ISUB.EQ.21) THEN
C...f + fbar -> gamma + h0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=22
MINT(23-JS)=25
ELSEIF(ISUB.EQ.22) THEN
C...f + fbar -> Z0 + Z0; th arbitrary
MINT(21)=23
MINT(22)=23
ELSEIF(ISUB.EQ.23) THEN
C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
MINT(20+JS)=23
MINT(23-JS)=ISIGN(24,KCH1+KCH2)
ELSEIF(ISUB.EQ.24) THEN
C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=23
MINT(23-JS)=KFHIGG
ELSEIF(ISUB.EQ.25) THEN
C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
MINT(21)=-ISIGN(24,MINT(15))
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.26) THEN
C...f + fbar' -> W+/- + h0 (or H0, or A0);
C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
MINT(20+JS)=ISIGN(24,KCH1+KCH2)
MINT(23-JS)=KFHIGG
ELSEIF(ISUB.EQ.27) THEN
C...f + fbar -> h0 + h0
ELSEIF(ISUB.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
IF(MINT(15).EQ.21) JS=2
KCC=MINT(2)+6
IF(MINT(15).EQ.21) KCC=KCC+2
IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
ELSEIF(ISUB.EQ.29) THEN
C...f + g -> f + gamma; th = (p(f)-p(f))**2
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=22
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.30) THEN
C...f + g -> f + Z0; th = (p(f)-p(f))**2
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=23
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ENDIF
ELSEIF(ISUB.LE.40) THEN
IF(ISUB.EQ.31) THEN
C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
RVCKM=VINT(180+I)*PYR(0)
DO 290 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
MINT(20+JS)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 300
290 CONTINUE
300 KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.32) THEN
C...f + g -> f + h0; th = (p(f)-p(f))**2
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=25
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.33) THEN
C...f + gamma -> f + g; th=(p(f)-p(f))**2
IF(MINT(15).EQ.22) JS=2
MINT(23-JS)=21
KCC=24+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.34) THEN
C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
IF(MINT(15).EQ.22) JS=2
KCC=22
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.35) THEN
C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
IF(MINT(15).EQ.22) JS=2
MINT(23-JS)=23
KCC=22
ELSEIF(ISUB.EQ.36) THEN
C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
IF(MINT(15).EQ.22) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 310 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
MINT(20+JS)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 320
310 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JS)=ISIGN(IB,I)
ENDIF
320 KCC=22
ELSEIF(ISUB.EQ.37) THEN
C...f + gamma -> f + h0
ELSEIF(ISUB.EQ.38) THEN
C...f + Z0 -> f + g
ELSEIF(ISUB.EQ.39) THEN
C...f + Z0 -> f + gamma
ELSEIF(ISUB.EQ.40) THEN
C...f + Z0 -> f + Z0
ENDIF
ELSEIF(ISUB.LE.50) THEN
IF(ISUB.EQ.41) THEN
C...f + Z0 -> f' + W+/-
ELSEIF(ISUB.EQ.42) THEN
C...f + Z0 -> f + h0
ELSEIF(ISUB.EQ.43) THEN
C...f + W+/- -> f' + g
ELSEIF(ISUB.EQ.44) THEN
C...f + W+/- -> f' + gamma
ELSEIF(ISUB.EQ.45) THEN
C...f + W+/- -> f' + Z0
ELSEIF(ISUB.EQ.46) THEN
C...f + W+/- -> f' + W+/-
ELSEIF(ISUB.EQ.47) THEN
C...f + W+/- -> f' + h0
ELSEIF(ISUB.EQ.48) THEN
C...f + h0 -> f + g
ELSEIF(ISUB.EQ.49) THEN
C...f + h0 -> f + gamma
ELSEIF(ISUB.EQ.50) THEN
C...f + h0 -> f + Z0
ENDIF
ELSEIF(ISUB.LE.60) THEN
IF(ISUB.EQ.51) THEN
C...f + h0 -> f' + W+/-
ELSEIF(ISUB.EQ.52) THEN
C...f + h0 -> f + h0
ELSEIF(ISUB.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.54) THEN
C...g + gamma -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=27
IF(MINT(16).EQ.21) KCC=28
ELSEIF(ISUB.EQ.55) THEN
C...g + Z0 -> f + fbar
ELSEIF(ISUB.EQ.56) THEN
C...g + W+/- -> f + fbar'
ELSEIF(ISUB.EQ.57) THEN
C...g + h0 -> f + fbar
ELSEIF(ISUB.EQ.58) THEN
C...gamma + gamma -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=21
ELSEIF(ISUB.EQ.59) THEN
C...gamma + Z0 -> f + fbar
ELSEIF(ISUB.EQ.60) THEN
C...gamma + W+/- -> f + fbar'
ENDIF
ELSEIF(ISUB.LE.70) THEN
IF(ISUB.EQ.61) THEN
C...gamma + h0 -> f + fbar
ELSEIF(ISUB.EQ.62) THEN
C...Z0 + Z0 -> f + fbar
ELSEIF(ISUB.EQ.63) THEN
C...Z0 + W+/- -> f + fbar'
ELSEIF(ISUB.EQ.64) THEN
C...Z0 + h0 -> f + fbar
ELSEIF(ISUB.EQ.65) THEN
C...W+ + W- -> f + fbar
ELSEIF(ISUB.EQ.66) THEN
C...W+/- + h0 -> f + fbar'
ELSEIF(ISUB.EQ.67) THEN
C...h0 + h0 -> f + fbar
ELSEIF(ISUB.EQ.68) THEN
C...g + g -> g + g; th arbitrary
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.EQ.69) THEN
C...gamma + gamma -> W+ + W-; th arbitrary
MINT(21)=24
MINT(22)=-24
KCC=21
ELSEIF(ISUB.EQ.70) THEN
C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
IF(MINT(15).EQ.22) MINT(21)=23
IF(MINT(16).EQ.22) MINT(22)=23
KCC=21
ENDIF
ELSEIF(ISUB.LE.80) THEN
IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
XH=SH/SHP
MINT(21)=MINT(15)
MINT(22)=MINT(16)
PMQ(1)=PYMASS(MINT(21))
PMQ(2)=PYMASS(MINT(22))
330 JT=INT(1.5D0+PYR(0))
ZMIN=2D0*PMQ(JT)/SHPR
ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
& (SHPR*(SHPR-PMQ(3-JT)))
ZMAX=MIN(1D0-XH,ZMAX)
Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
& (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 330
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
Z(3-JT)=1D0-XH/(1D0-Z(JT))
SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 330
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
PHIR=PARU(2)*PYR(0)
CPHI=COS(PHIR)
ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
& SQRT(1D0-CTHE(2)**2)*CPHI
Z1=2D0-Z(JT)
Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
& PMQ(3-JT)**2/SHP))
ZMIN=2D0*PMQ(3-JT)/SHPR
ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
KCC=22
ELSEIF(ISUB.EQ.73) THEN
C...Z0 + W+/- -> Z0 + W+/-
JS=MINT(2)
XH=SH/SHP
340 JT=3-MINT(2)
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 350 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 360
350 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
360 PMQ(JT)=PYMASS(MINT(20+JT))
MINT(23-JT)=MINT(17-JT)
PMQ(3-JT)=PYMASS(MINT(23-JT))
JT=INT(1.5D0+PYR(0))
ZMIN=2D0*PMQ(JT)/SHPR
ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
& (SHPR*(SHPR-PMQ(3-JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(ZMIN.GE.ZMAX) GOTO 340
Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
& (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 340
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
Z(3-JT)=1D0-XH/(1D0-Z(JT))
SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 340
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
PHIR=PARU(2)*PYR(0)
CPHI=COS(PHIR)
ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
& SQRT(1D0-CTHE(2)**2)*CPHI
Z1=2D0-Z(JT)
Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
& PMQ(3-JT)**2/SHP))
ZMIN=2D0*PMQ(3-JT)/SHPR
ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
KCC=22
ELSEIF(ISUB.EQ.74) THEN
C...Z0 + h0 -> Z0 + h0
ELSEIF(ISUB.EQ.75) THEN
C...W+ + W- -> gamma + gamma
ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
XH=SH/SHP
370 DO 400 JT=1,2
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 380 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 390
380 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
390 PMQ(JT)=PYMASS(MINT(20+JT))
400 CONTINUE
JT=INT(1.5D0+PYR(0))
ZMIN=2D0*PMQ(JT)/SHPR
ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
& (SHPR*(SHPR-PMQ(3-JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(ZMIN.GE.ZMAX) GOTO 370
Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
& (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 370
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
Z(3-JT)=1D0-XH/(1D0-Z(JT))
SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
IF(SQC1.LT.1D-8) GOTO 370
C1=SQRT(SQC1)
C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
PHIR=PARU(2)*PYR(0)
CPHI=COS(PHIR)
ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
& SQRT(1D0-CTHE(2)**2)*CPHI
Z1=2D0-Z(JT)
Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
& PMQ(3-JT)**2/SHP))
ZMIN=2D0*PMQ(3-JT)/SHPR
ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
ZMAX=MIN(1D0-XH,ZMAX)
IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
KCC=22
ELSEIF(ISUB.EQ.78) THEN
C...W+/- + h0 -> W+/- + h0
ELSEIF(ISUB.EQ.79) THEN
C...h0 + h0 -> h0 + h0
ELSEIF(ISUB.EQ.80) THEN
C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
IF(MINT(15).EQ.22) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
IB=3-IA
MINT(20+JS)=ISIGN(IB,I)
KCC=22
ENDIF
ELSEIF(ISUB.LE.90) THEN
IF(ISUB.EQ.81) THEN
C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
MINT(21)=ISIGN(MINT(55),MINT(15))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.82) THEN
C...g + g -> Q + Qbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(MINT(55),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.83) THEN
C...f + q -> f' + Q; th = (p(f) - p(f'))**2
KFOLD=MINT(16)
IF(MINT(2).EQ.2) KFOLD=MINT(15)
KFAOLD=IABS(KFOLD)
IF(KFAOLD.GT.10) THEN
KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
ELSE
RCKM=VINT(180+KFOLD)*PYR(0)
IPM=(5-ISIGN(1,KFOLD))/2
KFANEW=-MOD(KFAOLD+1,2)
410 KFANEW=KFANEW+2
IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
& VCKM(KFAOLD/2,(KFANEW+1)/2)
IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
& VCKM(KFANEW/2,(KFAOLD+1)/2)
ENDIF
IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
ENDIF
IF(MINT(2).EQ.1) THEN
MINT(21)=ISIGN(MINT(55),MINT(15))
MINT(22)=ISIGN(KFANEW,MINT(16))
ELSE
MINT(21)=ISIGN(KFANEW,MINT(15))
MINT(22)=ISIGN(MINT(55),MINT(16))
JS=2
ENDIF
KCC=22
ELSEIF(ISUB.EQ.84) THEN
C...g + gamma -> Q + Qbar; th arbitary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(MINT(55),KCS)
MINT(22)=-MINT(21)
KCC=27
IF(MINT(16).EQ.21) KCC=28
ELSEIF(ISUB.EQ.85) THEN
C...gamma + gamma -> F + Fbar; th arbitary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(MINT(56),KCS)
MINT(22)=-MINT(21)
KCC=21
ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
MINT(21)=KFPR(ISUB,1)
MINT(22)=KFPR(ISUB,2)
KCC=24
KCS=(-1)**INT(1.5D0+PYR(0))
ENDIF
ELSEIF(ISUB.LE.100) THEN
IF(ISUB.EQ.95) THEN
C...Low-pT ( = energyless g + g -> g + g)
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.EQ.96) THEN
C...Multiple interactions (should be reassigned to QCD process)
ENDIF
ELSEIF(ISUB.LE.110) THEN
IF(ISUB.EQ.101) THEN
C...g + g -> gamma*/Z0
KCC=21
KFRES=22
ELSEIF(ISUB.EQ.102) THEN
C...g + g -> h0 (or H0, or A0)
KCC=21
KFRES=KFHIGG
ELSEIF(ISUB.EQ.103) THEN
C...gamma + gamma -> h0 (or H0, or A0)
KCC=21
KFRES=KFHIGG
ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
C...g + g -> chi_0c or chi_2c.
KCC=21
KFRES=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.106) THEN
C...g + g -> J/Psi + gamma
MINT(21)=KFPR(ISUB,1)
MINT(22)=KFPR(ISUB,2)
KCC=21
ELSEIF(ISUB.EQ.107) THEN
C...g + gamma -> J/Psi + g
MINT(21)=KFPR(ISUB,1)
MINT(22)=KFPR(ISUB,2)
KCC=22
IF(MINT(16).EQ.22) KCC=33
ELSEIF(ISUB.EQ.108) THEN
C...gamma + gamma -> J/Psi + gamma
MINT(21)=KFPR(ISUB,1)
MINT(22)=KFPR(ISUB,2)
ELSEIF(ISUB.EQ.110) THEN
C...f + fbar -> gamma + h0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=22
MINT(23-JS)=KFHIGG
ENDIF
ELSEIF(ISUB.LE.120) THEN
IF(ISUB.EQ.111) THEN
C...f + fbar -> g + h0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=21
MINT(23-JS)=KFHIGG
KCC=17+JS
ELSEIF(ISUB.EQ.112) THEN
C...f + g -> f + h0; th = (p(f) - p(f))**2
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=KFHIGG
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.113) THEN
C...g + g -> g + h0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(23-JS)=KFHIGG
KCC=22+JS
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.EQ.114) THEN
C...g + g -> gamma + gamma; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(21)=22
MINT(22)=22
KCC=21
ELSEIF(ISUB.EQ.115) THEN
C...g + g -> g + gamma; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(23-JS)=22
KCC=22+JS
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.EQ.116) THEN
C...g + g -> gamma + Z0
ELSEIF(ISUB.EQ.117) THEN
C...g + g -> Z0 + Z0
ELSEIF(ISUB.EQ.118) THEN
C...g + g -> W+ + W-
ENDIF
ELSEIF(ISUB.LE.140) THEN
IF(ISUB.EQ.121) THEN
C...g + g -> Q + Qbar + h0
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
MINT(22)=-MINT(21)
KCC=11+INT(0.5D0+PYR(0))
KFRES=KFHIGG
ELSEIF(ISUB.EQ.122) THEN
C...q + qbar -> Q + Qbar + h0
MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
MINT(22)=-MINT(21)
KCC=4
KFRES=KFHIGG
ELSEIF(ISUB.EQ.123) THEN
C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
C...inner process)
KCC=22
KFRES=KFHIGG
ELSEIF(ISUB.EQ.124) THEN
C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
C...inner process)
DO 430 JT=1,2
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 420 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 430
420 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
430 CONTINUE
KCC=22
KFRES=KFHIGG
ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
IF(MINT(15).EQ.22) JS=2
MINT(23-JS)=21
KCC=24+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
IF(MINT(15).EQ.22) JS=2
KCC=22
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
C...g + gamma*_(T,L) -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=27
IF(MINT(16).EQ.21) KCC=28
ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=21
ENDIF
ELSEIF(ISUB.LE.160) THEN
IF(ISUB.EQ.141) THEN
C...f + fbar -> gamma*/Z0/Z'0
KFRES=32
ELSEIF(ISUB.EQ.142) THEN
C...f + fbar' -> W'+/-
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(34,KCH1+KCH2)
ELSEIF(ISUB.EQ.143) THEN
C...f + fbar' -> H+/-
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(37,KCH1+KCH2)
ELSEIF(ISUB.EQ.144) THEN
C...f + fbar' -> R
KFRES=ISIGN(41,MINT(15)+MINT(16))
ELSEIF(ISUB.EQ.145) THEN
C...q + l -> LQ (leptoquark)
IF(IABS(MINT(16)).LE.8) JS=2
KFRES=ISIGN(42,MINT(14+JS))
KCC=28+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.146) THEN
C...e + gamma -> e* (excited lepton)
IF(MINT(15).EQ.22) JS=2
KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
KCC=22
ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
C...q + g -> q* (excited quark)
IF(MINT(15).EQ.21) JS=2
KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
KCC=30+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.149) THEN
C...g + g -> eta_tc
KFRES=KTECHN+331
KCC=23
KCS=(-1)**INT(1.5D0+PYR(0))
ENDIF
ELSEIF(ISUB.LE.200) THEN
IF(ISUB.EQ.161) THEN
C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
IB=IA+MOD(IA,2)-MOD(IA+1,2)
MINT(20+JS)=ISIGN(IB,I)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.162) THEN
C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
IF(MINT(15).EQ.21) JS=2
MINT(20+JS)=ISIGN(42,MINT(14+JS))
KFLQL=KFDP(MDCY(42,2),2)
MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.163) THEN
C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(42,KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.164) THEN
C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
MINT(21)=ISIGN(42,MINT(15))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.165) THEN
C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.166) THEN
C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
IF(MOD(MINT(15),2).EQ.0) THEN
MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
ELSE
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
ENDIF
ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
C...q + q' -> q" + q* (excited quark)
KFQSTR=KFPR(ISUB,2)
KFQEXC=MOD(KFQSTR,KEXCIT)
JS=MINT(2)
MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
& MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
KCC=22
JS=3-JS
ELSEIF(ISUB.EQ.169) THEN
C...q + qbar -> e + e* (excited lepton)
KFQSTR=KFPR(ISUB,2)
KFQEXC=MOD(KFQSTR,KEXCIT)
JS=MINT(2)
MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
JS=3-JS
ELSEIF(ISUB.EQ.191) THEN
C...f + fbar -> rho_tc0.
KFRES=KTECHN+113
ELSEIF(ISUB.EQ.192) THEN
C...f + fbar' -> rho_tc+/-
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
ELSEIF(ISUB.EQ.193) THEN
C...f + fbar -> omega_tc0.
KFRES=KTECHN+223
ELSEIF(ISUB.EQ.194) THEN
C...f + fbar -> f' + fbar' via mixture of s-channel
C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.195) THEN
C...f + fbar' -> f'' + fbar''' via s-channel
C...rho_tc+ th=(p(f)-p(f'))**2
C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
IF(MOD(MINT(15),2).EQ.0) THEN
MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
ELSE
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
ENDIF
ENDIF
CMRENNA++
ELSEIF(ISUB.LE.215) THEN
IF(ISUB.EQ.201) THEN
C...f + fbar -> ~e_L + ~e_Lbar
MINT(21)=ISIGN(KSUSY1+11,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.202) THEN
C...f + fbar -> ~e_R + ~e_Rbar
MINT(21)=ISIGN(KSUSY2+11,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.203) THEN
C...f + fbar -> ~e_L + ~e_Rbar
IF(MINT(15).LT.0) JS=2
IF(MINT(2).EQ.1) THEN
MINT(20+JS)=KFPR(ISUB,1)
MINT(23-JS)=-KFPR(ISUB,2)
ELSE
MINT(20+JS)=-KFPR(ISUB,1)
MINT(23-JS)=KFPR(ISUB,2)
ENDIF
ELSEIF(ISUB.EQ.204) THEN
C...f + fbar -> ~mu_L + ~mu_Lbar
MINT(21)=ISIGN(KSUSY1+13,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.205) THEN
C...f + fbar -> ~mu_R + ~mu_Rbar
MINT(21)=ISIGN(KSUSY2+13,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.206) THEN
C...f + fbar -> ~mu_L + ~mu_Rbar
IF(MINT(15).LT.0) JS=2
IF(MINT(2).EQ.1) THEN
MINT(20+JS)=KFPR(ISUB,1)
MINT(23-JS)=-KFPR(ISUB,2)
ELSE
MINT(20+JS)=-KFPR(ISUB,1)
MINT(23-JS)=KFPR(ISUB,2)
ENDIF
ELSEIF(ISUB.EQ.207) THEN
C...f + fbar -> ~tau_1 + ~tau_1bar
MINT(21)=ISIGN(KSUSY1+15,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.208) THEN
C...f + fbar -> ~tau_2 + ~tau_2bar
MINT(21)=ISIGN(KSUSY2+15,KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.209) THEN
C...f + fbar -> ~tau_1 + ~tau_2bar
IF(MINT(15).LT.0) JS=2
IF(MINT(2).EQ.1) THEN
MINT(20+JS)=KFPR(ISUB,1)
MINT(23-JS)=-KFPR(ISUB,2)
ELSE
MINT(20+JS)=-KFPR(ISUB,1)
MINT(23-JS)=KFPR(ISUB,2)
ENDIF
ELSEIF(ISUB.EQ.210) THEN
C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
ELSEIF(ISUB.EQ.211) THEN
C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
ELSEIF(ISUB.EQ.212) THEN
C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
ELSEIF(ISUB.EQ.213) THEN
C...f + fbar -> ~nul + ~nulbar
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.214) THEN
C...f + fbar -> ~nutau + ~nutaubar
MINT(21)=ISIGN(KSUSY1+16,KCS)
MINT(22)=-MINT(21)
ENDIF
ELSEIF(ISUB.LE.225) THEN
IF(ISUB.EQ.216) THEN
C...f + fbar -> ~chi01 + ~chi01
MINT(21)=KSUSY1+22
MINT(22)=KSUSY1+22
ELSEIF(ISUB.EQ.217) THEN
C...f + fbar -> ~chi02 + ~chi02
MINT(21)=KSUSY1+23
MINT(22)=KSUSY1+23
ELSEIF(ISUB.EQ.218 ) THEN
C...f + fbar -> ~chi03 + ~chi03
MINT(21)=KSUSY1+25
MINT(22)=KSUSY1+25
ELSEIF(ISUB.EQ.219 ) THEN
C...f + fbar -> ~chi04 + ~chi04
MINT(21)=KSUSY1+35
MINT(22)=KSUSY1+35
ELSEIF(ISUB.EQ.220 ) THEN
C...f + fbar -> ~chi01 + ~chi02
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+22
MINT(23-JS)=KSUSY1+23
ELSEIF(ISUB.EQ.221 ) THEN
C...f + fbar -> ~chi01 + ~chi03
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+22
MINT(23-JS)=KSUSY1+25
ELSEIF(ISUB.EQ.222) THEN
C...f + fbar -> ~chi01 + ~chi04
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+22
MINT(23-JS)=KSUSY1+35
ELSEIF(ISUB.EQ.223) THEN
C...f + fbar -> ~chi02 + ~chi03
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+23
MINT(23-JS)=KSUSY1+25
ELSEIF(ISUB.EQ.224) THEN
C...f + fbar -> ~chi02 + ~chi04
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+23
MINT(23-JS)=KSUSY1+35
ELSEIF(ISUB.EQ.225) THEN
C...f + fbar -> ~chi03 + ~chi04
IF(MINT(15).LT.0) JS=2
C IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+25
MINT(23-JS)=KSUSY1+35
ENDIF
ELSEIF(ISUB.LE.236) THEN
IF(ISUB.EQ.226) THEN
C...f + fbar -> ~chi+-1 + ~chi-+1
C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
MINT(21)=ISIGN(KSUSY1+24,KCH1)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.227) THEN
C...f + fbar -> ~chi+-2 + ~chi-+2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
MINT(21)=ISIGN(KSUSY1+37,KCH1)
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.228) THEN
C...f + fbar -> ~chi+-1 + ~chi-+2
C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
C...js=1 if pyr<.5, js=2 if pyr>.5
C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=INT(1-KCH1)/2
IF(MINT(2).EQ.1) THEN
MINT(21)= ISIGN(KSUSY1+24,KCH1)
MINT(22)= -ISIGN(KSUSY1+37,KCH1)
c IF(KCH2.EQ.0) JS=2
ELSE
MINT(21)= ISIGN(KSUSY1+37,KCH1)
MINT(22)= -ISIGN(KSUSY1+24,KCH1)
JS=2
c IF(KCH2.EQ.1) JS=2
ENDIF
ELSEIF(ISUB.EQ.229) THEN
C...q + qbar' -> ~chi01 + ~chi+-1
C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
C...CHECK THIS
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+22
MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
ELSEIF(ISUB.EQ.230) THEN
C...q + qbar' -> ~chi02 + ~chi+-1
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+23
MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
ELSEIF(ISUB.EQ.231) THEN
C...q + qbar' -> ~chi03 + ~chi+-1
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+25
MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
ELSEIF(ISUB.EQ.232) THEN
C...q + qbar' -> ~chi04 + ~chi+-1
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+35
MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
ELSEIF(ISUB.EQ.233) THEN
C...q + qbar' -> ~chi01 + ~chi+-2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+22
MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
ELSEIF(ISUB.EQ.234) THEN
C...q + qbar' -> ~chi02 + ~chi+-2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+23
MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
ELSEIF(ISUB.EQ.235) THEN
C...q + qbar' -> ~chi03 + ~chi+-2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+25
MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
ELSEIF(ISUB.EQ.236) THEN
C...q + qbar' -> ~chi04 + ~chi+-2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MOD(MINT(15),2).EQ.0) JS=2
MINT(20+JS)=KSUSY1+35
MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
ENDIF
ELSEIF(ISUB.LE.245) THEN
IF(ISUB.EQ.237) THEN
C...q + qbar -> ~chi01 + ~g
C...th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=KSUSY1+22
KCC=17+JS
ELSEIF(ISUB.EQ.238) THEN
C...q + qbar -> ~chi02 + ~g
C...th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=KSUSY1+23
KCC=17+JS
ELSEIF(ISUB.EQ.239) THEN
C...q + qbar -> ~chi03 + ~g
C...th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=KSUSY1+25
KCC=17+JS
ELSEIF(ISUB.EQ.240) THEN
C...q + qbar -> ~chi04 + ~g
C...th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=KSUSY1+35
KCC=17+JS
ELSEIF(ISUB.EQ.241) THEN
C...q + qbar' -> ~chi+-1 + ~g
C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
JS=1
IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
KCC=17+JS
ELSEIF(ISUB.EQ.242) THEN
C...q + qbar' -> ~chi+-2 + ~g
C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
JS=1
IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
MINT(20+JS)=KSUSY1+21
MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
KCC=17+JS
ELSEIF(ISUB.EQ.243) THEN
C...q + qbar -> ~g + ~g ; th arbitrary
MINT(21)=KSUSY1+21
MINT(22)=KSUSY1+21
KCC=MINT(2)+4
ELSEIF(ISUB.EQ.244) THEN
C...g + g -> ~g + ~g ; th arbitrary
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=KSUSY1+21
MINT(22)=KSUSY1+21
ENDIF
ELSEIF(ISUB.LE.260) THEN
IF(ISUB.EQ.246) THEN
C...qj + g -> ~qj_L + ~chi01
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+22
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.247) THEN
C...qj + g -> ~qj_R + ~chi01
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+22
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.248) THEN
C...qj + g -> ~qj_L + ~chi02
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+23
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.249) THEN
C...qj + g -> ~qj_R + ~chi02
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+23
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.250) THEN
C...qj + g -> ~qj_L + ~chi03
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+25
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.251) THEN
C...qj + g -> ~qj_R + ~chi03
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+25
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.252) THEN
C...qj + g -> ~qj_L + ~chi04
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+35
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.253) THEN
C...qj + g -> ~qj_R + ~chi04
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+35
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.254) THEN
C...qj + g -> ~qk_L + ~chi+-1
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
IB=-IA+INT((IA+1)/2)*4-1
MINT(20+JS)=ISIGN(KSUSY1+IB,I)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.255) THEN
C...qj + g -> ~qk_L + ~chi+-1
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
IB=-IA+INT((IA+1)/2)*4-1
MINT(20+JS)=ISIGN(KSUSY2+IB,I)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.256) THEN
C...qj + g -> ~qk_L + ~chi+-2
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
IB=-IA+INT((IA+1)/2)*4-1
MINT(20+JS)=ISIGN(KSUSY1+IB,I)
MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.257) THEN
C...qj + g -> ~qk_R + ~chi+-2
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
IB=-IA+INT((IA+1)/2)*4-1
MINT(20+JS)=ISIGN(KSUSY2+IB,I)
MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.258) THEN
C...qj + g -> ~qj_L + ~g
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+21
KCC=MINT(2)+6
IF(JS.EQ.2) KCC=KCC+2
KCS=ISIGN(1,I)
ELSEIF(ISUB.EQ.259) THEN
C...qj + g -> ~qj_R + ~g
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+21
KCC=MINT(2)+6
IF(JS.EQ.2) KCC=KCC+2
KCS=ISIGN(1,I)
ENDIF
ELSEIF(ISUB.LE.270) THEN
IF(ISUB.EQ.261) THEN
C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
ISGN=1
IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
C...Correct color combination
IF(MINT(43).EQ.4) KCC=4
ELSEIF(ISUB.EQ.262) THEN
C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
ISGN=1
IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
C...Correct color combination
IF(MINT(43).EQ.4) KCC=4
ELSEIF(ISUB.EQ.263) THEN
C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
& (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
ELSE
JS=2
MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
ENDIF
C...Correct color combination
IF(MINT(43).EQ.4) KCC=4
ELSEIF(ISUB.EQ.264) THEN
C...g + g -> ~t_1 + ~t_1bar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.265) THEN
C...g + g -> ~t_2 + ~t_2bar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ENDIF
ELSEIF(ISUB.LE.301) THEN
IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
C...qi + qj -> ~qi_L + ~qj_L
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
C...qi + qj -> ~qi_R + ~qj_R
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
C...qi + qj -> ~qi_L + ~qj_R
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
ISGN=1
IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
IF(MINT(43).EQ.4) KCC=4
ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
ISGN=1
IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
IF(MINT(43).EQ.4) KCC=4
ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
C...pure LL + RR
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.294) THEN
C...qj + g -> ~qj_L + ~g
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY1+IA,I)
MINT(23-JS)=KSUSY1+21
KCC=MINT(2)+6
IF(JS.EQ.2) KCC=KCC+2
KCS=ISIGN(1,I)
ELSEIF(ISUB.EQ.295) THEN
C...qj + g -> ~qj_R + ~g
IF(MINT(15).EQ.21) JS=2
I=MINT(14+JS)
IA=IABS(I)
MINT(20+JS)=ISIGN(KSUSY2+IA,I)
MINT(23-JS)=KSUSY1+21
KCC=MINT(2)+6
IF(JS.EQ.2) KCC=KCC+2
KCS=ISIGN(1,I)
ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
C...q + qbar' -> H+ + H0
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
MINT(20+JS)=ISIGN(37,KCH1+KCH2)
MINT(23-JS)=KFPR(ISUB,2)
ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
C...f + fbar -> A0 + H0; th arbitrary
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFPR(ISUB,1)
MINT(23-JS)=KFPR(ISUB,2)
ELSEIF(ISUB.EQ.301) THEN
C...f + fbar -> H+ H-
MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
MINT(22)=-MINT(21)
ENDIF
CMRENNA--
ELSEIF(ISUB.LE.330) THEN
IF(ISUB.EQ.311)THEN
C...g + g -> g* + g* (UED)
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
MUED(1)=472
MUED(2)=472
MINT(21)=IUEDEQ(472)
MINT(22)=IUEDEQ(472)
ELSEIF(ISUB.EQ.312)THEN
C...q + g -> q*_D + g*, q*_S + g*
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
IF(MINT(15).EQ.21) JS=2
KCC=MINT(2)+6
IF(MINT(15).EQ.21)KCC=KCC+2
IF(MINT(15).NE.21)THEN
KCS=ISIGN(1,MINT(15))
MUED(2)=472
MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
MINT(22)=IUEDEQ(472)
MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
ENDIF
IF(MINT(16).NE.21)THEN
KCS=ISIGN(1,MINT(16))
MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
MUED(1)=472
MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
MINT(21)=IUEDEQ(472)
ENDIF
ELSEIF(ISUB.EQ.313)THEN
C...q + q' -> q*_D + q*_D',q*_S+q*_S'
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
KCC=MINT(2)
IF(MINT(15).EQ.MINT(16))THEN
MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
MUED(2)=MINT(21)
MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
MINT(22)=MINT(21)
ELSE
MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
ENDIF
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.314)THEN
C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
KCS=(-1)**INT(1.5D0+PYR(0))
XFLAOUT=PYR(0)
IF(XFLAOUT.LE.0.2)THEN
MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
ELSEIF(XFLAOUT.LE.0.4)THEN
MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
ELSEIF(XFLAOUT.LE.0.6)THEN
MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
ELSEIF(XFLAOUT.LE.0.8)THEN
MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
ELSE
MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
ENDIF
MINT(22)=-MINT(21)
MUED(2)=-MUED(1)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.315)THEN
C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
MUED(2)=-MINT(21)
MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.316)THEN
C...q + qbar' -> q*_D + q*_S_bar'
MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
KCC=MINT(2)+2
ELSEIF(ISUB.EQ.317)THEN
C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
KCC=MINT(2)+2
ELSEIF(ISUB.EQ.318)THEN
C...q + q' -> q*_D + q*_S'
KCC=MINT(2)
MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
ELSEIF(ISUB.EQ.319)THEN
C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
C...The two channels have the same cross section
KKFLMI=450
IF(PYR(0).GT.0.5)KKFLMI=456
XFLAOUT=PYR(0)
IIFLAV=0
C...N.B. NFLAVOURS=IUED(3)
C DO I=1,NFLAVOURS
DO 433 I=1,IUED(3)
IF(I.NE.IABS(MINT(15)))THEN
IIFLAV=IIFLAV+1
IOKFLA(IIFLAV)=I
ENDIF
433 CONTINUE
FLASTEP=1./(IUED(3)-1)
DO I=1,IUED(3)-1
FLAVV=FLASTEP*I
IF(XFLAOUT.LE.FLAVV)THEN
MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
GOTO 435
ENDIF
ENDDO
435 CONTINUE
IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
CALL PYSTOP(5000000)
ENDIF
MINT(22)=-MINT(21)
KCC=4
ENDIF
ELSEIF(ISUB.LE.360) THEN
IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
C...l + l -> H_L++/--, H_R++/--
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
IF(MINT(15).EQ.22) JS=2
MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
KCC=22
ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
MINT(22)=-MINT(21)
ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
C...as inner process).
DO 450 JT=1,2
I=MINT(14+JT)
IA=IABS(I)
IF(IA.LE.10) THEN
RVCKM=VINT(180+I)*PYR(0)
DO 440 J=1,MSTP(1)
IB=2*J-1+MOD(IA,2)
IPM=(5-ISIGN(1,I))/2
IDC=J+MDCY(IA,2)+2
IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
MINT(20+JT)=ISIGN(IB,I)
RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
IF(RVCKM.LE.0D0) GOTO 450
440 CONTINUE
ELSE
IB=2*((IA+1)/2)-1+MOD(IA,2)
MINT(20+JT)=ISIGN(IB,I)
ENDIF
450 CONTINUE
KCC=22
KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
ELSEIF(ISUB.EQ.353) THEN
C...f + fbar -> Z_R0
KFRES=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.354) THEN
C...f + fbar' -> W+/-
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
ENDIF
ELSEIF(ISUB.LE.380) THEN
IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
C...f + fbar -> charged+ charged- technicolor
KSW=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
C...f + fbar -> neutral neutral technicolor
MINT(21)=KFPR(ISUB,1)
MINT(22)=KFPR(ISUB,2)
ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
C...f + fbar' -> neutral charged technicolor
IN=1
IC=2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
MINT(20+JS)=KFPR(ISUB,IN)
ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
C...f + fbar' -> charged neutral technicolor
IN=2
IC=1
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
MINT(23-JS)=KFPR(ISUB,IN)
ENDIF
ELSEIF(ISUB.LE.400) THEN
IF(ISUB.EQ.381) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
KCC=MINT(2)
IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
ELSEIF(ISUB.EQ.382) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
MINT(21)=ISIGN(KFLF,MINT(15))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.383) THEN
C...f + fbar -> g + g; th arbitrary, TC extensions
MINT(21)=21
MINT(22)=21
KCC=MINT(2)+4
ELSEIF(ISUB.EQ.384) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
IF(MINT(15).EQ.21) JS=2
KCC=MINT(2)+6
IF(MINT(15).EQ.21) KCC=KCC+2
IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
ELSEIF(ISUB.EQ.385) THEN
C...g + g -> f + fbar; th arbitrary, TC extensions
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFLF,KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.386) THEN
C...g + g -> g + g; th arbitrary, TC extensions
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.EQ.387) THEN
C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
MINT(21)=ISIGN(MINT(55),MINT(15))
MINT(22)=-MINT(21)
KCC=4
ELSEIF(ISUB.EQ.388) THEN
C...g + g -> Q + Qbar; th arbitrary, TC extensions
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(MINT(55),KCS)
MINT(22)=-MINT(21)
KCC=MINT(2)+10
ELSEIF(ISUB.EQ.391) THEN
C...f + fbar -> G*.
KFRES=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.392) THEN
C...g + g -> G*.
KCC=21
KFRES=KFPR(ISUB,1)
ELSEIF(ISUB.EQ.393) THEN
C...q + qbar -> g + G*; th arbitrary.
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFPR(ISUB,1)
MINT(23-JS)=KFPR(ISUB,2)
KCC=17+JS
ELSEIF(ISUB.EQ.394) THEN
C...q + g -> q + G*; th = (p(f) - p(f))**2
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=KFPR(ISUB,2)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.EQ.395) THEN
C...g + g -> G* + g; th arbitrary.
IF(PYR(0).GT.0.5D0) JS=2
MINT(23-JS)=KFPR(ISUB,2)
KCC=22+JS
ENDIF
ELSEIF(ISUB.LE.420) THEN
IF(ISUB.EQ.401) THEN
C...g + g -> t + b + H+/-
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
MINT(22)=ISIGN(5,-KCS)
KCC=11+INT(0.5D0+PYR(0))
KFRES=ISIGN(KFHIGG,-KCS)
ELSEIF(ISUB.EQ.402) THEN
C...q + qbar -> t + b + H+/-
KFL=(-1)**INT(1.5D0+PYR(0))
MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
KCC=4
KFRES=ISIGN(KFHIGG,-KFL*KCS)
ENDIF
C...QUARKONIA+++
C...Additional code by Stefan Wolf
ELSEIF(ISUB.LE.430) THEN
IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
C...g + g -> QQ~[n] + g
C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...or from ISUB.EQ.68 (for ISUB.NE.421)
C...[g + g -> g + g; th arbitrary]
MINT(21)=KFPR(ISUBSV,1)
MINT(22)=KFPR(ISUBSV,2)
IF(ISUB.EQ.421) THEN
KCC=24
KCS=(-1)**INT(1.5D0+PYR(0))
ELSE
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
ENDIF
ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
C...q + g -> q + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
C...KCC copied from ISUB.EQ.28
C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=KFPR(ISUBSV,2)
KCC=MINT(2)+6
IF(MINT(15).EQ.21) KCC=KCC+2
IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
C...q + q~ -> g + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
C...KCC copied from ISUB.EQ.13
C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
IF(PYR(0).GT.0.5) JS=2
MINT(20+JS)=21
MINT(23-JS)=KFPR(ISUBSV,2)
KCC=MINT(2)+4
ENDIF
ELSEIF(ISUB.LE.440) THEN
IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
C...g + g -> QQ~[n] + g
C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...KCC and KCS copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
MINT(21)=KFPR(ISUBSV,1)
MINT(22)=KFPR(ISUBSV,2)
KCC=24
KCS=(-1)**INT(1.5D0+PYR(0))
ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
C...q + g -> q + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
C...KCC and KCS copied from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
IF(MINT(15).EQ.21) JS=2
MINT(23-JS)=KFPR(ISUBSV,2)
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
C...q + q~ -> g + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
C...KCC copied from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
IF(PYR(0).GT.0.5) JS=2
MINT(20+JS)=21
MINT(23-JS)=KFPR(ISUBSV,2)
KCC=17+JS
C...QUARKONIA---
ENDIF
ELSEIF(ISUB.LE.500) THEN
IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
KFRES=9900001
KCRES=PYCOMP(KFRES)
MCOL=KCHG(KCRES,2)
MCHG=KCHG(KCRES,1)
IF(KCRES.EQ.0)
$ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
IDCY=MDCY(KCRES,2)
IF(IDCY.EQ.0)
$ CALL PYERRM(21,"No decays for resonance in Generic 2->2")
KCI1=PYCOMP(MINT(15))
KCI2=PYCOMP(MINT(16))
ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
KFF1=KFPR(ISUB,1)
KFF2=KFPR(ISUB,2)
KCF1=PYCOMP(KFF1)
KCF2=PYCOMP(KFF2)
JCOL1=SIGN(KCHG(KCF1,2),KFF1)
IF(JCOL1.EQ.-2) JCOL1=2
JCOL2=SIGN(KCHG(KCF2,2),KFF2)
IF(JCOL2.EQ.-2) JCOL2=2
KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
KCHW=KCH1+KCH2
KREL=1
IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
$ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
KCC=17+JS
MINT(20+JS)=KFF2
MINT(23-JS)=KFF1
ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
KCC=17+JS
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
KCC=MINT(2)+4
ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
$ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
IF(ICOL1.EQ.JCOL1) THEN
JS=1
MINT(21)=KFF1
MINT(22)=KFF2
ELSE
JS=2
MINT(21)=KFF2
MINT(22)=KFF1
ENDIF
IF(MCOL.EQ.0) THEN
ELSE
KCC=4
ENDIF
ENDIF
ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
$ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
$ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
IF(MINT(15).EQ.21) JS=2
KCC=MINT(2)+6
IF(MINT(15).EQ.21) KCC=KCC+2
IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
IF(JCOL1.EQ.2) THEN
MINT(20+JS)=KFF2
MINT(23-JS)=KFF1
ELSE
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ENDIF
ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
$ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
IF(MINT(15).EQ.21) JS=2
KCC=15+JS
KCS=ISIGN(1,MINT(14+JS))
IF(JCOL1.EQ.0) THEN
MINT(23-JS)=KFF1
MINT(20+JS)=KFF2
ELSE
MINT(23-JS)=KFF2
MINT(20+JS)=KFF1
ENDIF
ENDIF
ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
$ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
IF(PYR(0).GT.0.5D0) JS=2
KCC=21
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
$ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
$ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
IF(PYR(0).GT.0.5D0) JS=2
KCC=22+JS
KCS=(-1)**INT(1.5D0+PYR(0))
IF(JCOL1.EQ.0) THEN
MINT(23-JS)=KFF1
MINT(20+JS)=KFF2
ELSE
MINT(23-JS)=KFF2
MINT(20+JS)=KFF1
ENDIF
ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
$ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
$ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
C....two choices, 0 or 2 depending upon mother properties
IF(MCOL.EQ.2) THEN
KCS=(-1)**INT(1.5D0+PYR(0))
KCC=MINT(2)+10
IF(JCOL1.EQ.1) THEN
MINT(21)=KFF1*KCS
MINT(22)=KFF2*KCS
ELSE
MINT(22)=KFF1*KCS
MINT(21)=KFF2*KCS
ENDIF
c MINT(20+JS)=KFF1*KCS
c MINT(23-JS)=KFF2*KCS
ELSEIF(MCOL.EQ.0) THEN
KCC=21
MINT(20+JS)=KFF1*KCS
MINT(23-JS)=KFF2*KCS
ENDIF
ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
$ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
C....two choices, 0 or 2 depending upon mother properties
IF(MCOL.EQ.0) THEN
KCC=21
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ELSEIF(MCOL.EQ.2) THEN
IF(PYR(0).GT.0.5D0) JS=2
KCC=MINT(2)+12
KCS=(-1)**INT(1.5D0+PYR(0))
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ENDIF
ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
$ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
KCC=MINT(2)
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
KCC=20
IF(PYR(0).GT.0.5D0) JS=2
MINT(20+JS)=KFF1
MINT(23-JS)=KFF2
ELSE
CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
ENDIF
IF(ISUBSV.EQ.482) KFRES=0
ENDIF
ENDIF
IF(ISET(ISUB).EQ.11) THEN
C...Store documentation for user-defined processes
BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
KUPPO(1)=MINT(83)+5
KUPPO(2)=MINT(83)+6
I=MINT(83)+6
DO 470 IUP=3,NUP
KUPPO(IUP)=0
IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
IDOC=IDOC-1
MINT(4)=MINT(4)-1
GOTO 470
ENDIF
I=I+1
KUPPO(IUP)=I
K(I,1)=21
K(I,2)=IDUP(IUP)
IF(IDUP(IUP).EQ.0) K(I,2)=90
K(I,3)=0
IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
K(I,4)=0
K(I,5)=0
DO 460 J=1,5
P(I,J)=PUP(J,IUP)
460 CONTINUE
V(I,5)=VTIMUP(IUP)
470 CONTINUE
CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
& -BEZUP)
C...Store final state partons for user-defined processes
N=IPU2
DO 490 IUP=3,NUP
N=N+1
K(N,1)=1
IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
K(N,2)=IDUP(IUP)
IF(IDUP(IUP).EQ.0) K(N,2)=90
IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
K(N,3)=KUPPO(IUP)
ELSE
K(N,3)=MINT(84)+MOTHUP(1,IUP)
ENDIF
K(N,4)=0
K(N,5)=0
C...Search for daughters of intermediate colourless particles.
IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
DO 475 IUPDAU=IUP+1,NUP
IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
& N+IUPDAU-IUP
IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
475 CONTINUE
ENDIF
DO 480 J=1,5
P(N,J)=PUP(J,IUP)
480 CONTINUE
V(N,5)=VTIMUP(IUP)
490 CONTINUE
CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
C...Arrange colour flow for user-defined processes
NLBL=0
DO 540 IUP1=1,NUP
I1=MINT(84)+IUP1
IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
IF(K(I1,1).EQ.1) K(I1,1)=3
IF(K(I1,1).EQ.11) K(I1,1)=14
C...Find a not yet considered colour/anticolour line.
DO 530 ISDE1=1,2
IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
NMAT=0
DO 500 ILBL=1,NLBL
IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
500 CONTINUE
IF(NMAT.EQ.0) THEN
NLBL=NLBL+1
ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
C...Find all others belonging to same line.
I3=I1
I4=0
DO 520 IUP2=IUP1+1,NUP
I2=MINT(84)+IUP2
DO 510 ISDE2=1,2
IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
IF(ISDE2.EQ.ISDE1) THEN
K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
I3=I2
ELSEIF(I4.NE.0) THEN
K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
I4=I2
ELSEIF(IUP2.LE.2) THEN
K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
I4=I2
ELSE
K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
I4=I2
ENDIF
ENDIF
510 CONTINUE
520 CONTINUE
ENDIF
530 CONTINUE
540 CONTINUE
ELSEIF(IDOC.EQ.7) THEN
C...Resonance not decaying; store kinematics
I=MINT(83)+7
K(IPU3,1)=1
K(IPU3,2)=KFRES
K(IPU3,3)=I
P(IPU3,4)=SHUSER
P(IPU3,5)=SHUSER
K(I,1)=21
K(I,2)=KFRES
P(I,4)=SHUSER
P(I,5)=SHUSER
N=IPU3
MINT(21)=KFRES
MINT(22)=0
C...Special cases: colour flow in coloured resonances
KCRES=PYCOMP(KFRES)
IF(KCHG(KCRES,2).NE.0) THEN
K(IPU3,1)=3
DO 550 J=1,2
JC=J
IF(KCS.EQ.-1) JC=3-J
IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
& MINT(84)+ICOL(KCC,1,JC)
IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
& MINT(84)+ICOL(KCC,2,JC)
IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
& MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
550 CONTINUE
ELSE
K(IPU1,4)=IPU2
K(IPU1,5)=IPU2
K(IPU2,4)=IPU1
K(IPU2,5)=IPU1
ENDIF
ELSEIF(IDOC.EQ.8) THEN
C...2 -> 2 processes: store outgoing partons in their CM-frame
DO 560 JT=1,2
I=MINT(84)+2+JT
KCA=PYCOMP(MINT(20+JT))
K(I,1)=1
IF(KCHG(KCA,2).NE.0) K(I,1)=3
K(I,2)=MINT(20+JT)
K(I,3)=MINT(83)+IDOC+JT-2
KFAA=IABS(K(I,2))
IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
ELSE
P(I,5)=PYMASS(K(I,2))
ENDIF
IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
& P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
560 CONTINUE
IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
KFA1=IABS(MINT(21))
KFA2=IABS(MINT(22))
IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
& THEN
MINT(51)=1
RETURN
ENDIF
P(IPU3,5)=0D0
P(IPU4,5)=0D0
ENDIF
P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
P(IPU4,4)=SHR-P(IPU3,4)
P(IPU4,3)=-P(IPU3,3)
N=IPU4
MINT(7)=MINT(83)+7
MINT(8)=MINT(83)+8
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
ELSEIF(IDOC.EQ.9) THEN
C...2 -> 3 processes: store outgoing partons in their CM frame
DO 570 JT=1,2
I=MINT(84)+2+JT
KCA=PYCOMP(MINT(20+JT))
K(I,1)=1
IF(KCHG(KCA,2).NE.0) K(I,1)=3
K(I,2)=MINT(20+JT)
K(I,3)=MINT(83)+IDOC+JT-3
JTA=JT
C...t and b in opposide order in event list as compared to
C...matrix element?
IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
IF(IABS(K(I,2)).LE.22) THEN
P(I,5)=PYMASS(K(I,2))
ELSE
P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
ENDIF
PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
P(I,1)=PT*COS(VINT(198+5*JTA))
P(I,2)=PT*SIN(VINT(198+5*JTA))
570 CONTINUE
K(IPU5,1)=1
K(IPU5,2)=KFRES
K(IPU5,3)=MINT(83)+IDOC
P(IPU5,5)=SHR
P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
PMT3=SQRT(PMS3)
P(IPU5,3)=PMT3*SINH(VINT(211))
P(IPU5,4)=PMT3*COSH(VINT(211))
PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
IF(SQL12.LE.0D0) THEN
MINT(51)=1
RETURN
ENDIF
P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
& VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
C...t and b in opposide order in event list as compared to
C...matrix element
P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
& VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
END IF
P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
MINT(23)=KFRES
N=IPU5
MINT(7)=MINT(83)+7
MINT(8)=MINT(83)+8
ELSEIF(IDOC.EQ.11) THEN
C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
PHI(1)=PARU(2)*PYR(0)
PHI(2)=PHI(1)-PHIR
DO 580 JT=1,2
I=MINT(84)+2+JT
K(I,1)=1
IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
K(I,2)=MINT(20+JT)
K(I,3)=MINT(83)+IDOC+JT-2
P(I,5)=PYMASS(K(I,2))
IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
MINT(51)=1
RETURN
ENDIF
PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
P(I,1)=PTABS*COS(PHI(JT))
P(I,2)=PTABS*SIN(PHI(JT))
P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
P(I,4)=0.5D0*SHPR*Z(JT)
IZW=MINT(83)+6+JT
K(IZW,1)=21
K(IZW,2)=23
IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
K(IZW,3)=IZW-2
P(IZW,1)=-P(I,1)
P(IZW,2)=-P(I,2)
P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
580 CONTINUE
I=MINT(83)+9
K(IPU5,1)=1
K(IPU5,2)=KFRES
K(IPU5,3)=I
P(IPU5,5)=SHR
P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
K(I,1)=21
K(I,2)=KFRES
DO 590 J=1,5
P(I,J)=P(IPU5,J)
590 CONTINUE
N=IPU5
MINT(23)=KFRES
ELSEIF(IDOC.EQ.12) THEN
C...Z0 and W+/- scattering: store bosons and outgoing partons
PHI(1)=PARU(2)*PYR(0)
PHI(2)=PHI(1)-PHIR
JTRAN=INT(1.5D0+PYR(0))
DO 600 JT=1,2
I=MINT(84)+2+JT
K(I,1)=1
IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
K(I,2)=MINT(20+JT)
K(I,3)=MINT(83)+IDOC+JT-2
P(I,5)=PYMASS(K(I,2))
IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
P(I,1)=PTABS*COS(PHI(JT))
P(I,2)=PTABS*SIN(PHI(JT))
P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
P(I,4)=0.5D0*SHPR*Z(JT)
IZW=MINT(83)+6+JT
K(IZW,1)=21
IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
K(IZW,2)=23
ELSE
K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
ENDIF
K(IZW,3)=IZW-2
P(IZW,1)=-P(I,1)
P(IZW,2)=-P(I,2)
P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
IPU=MINT(84)+4+JT
K(IPU,1)=3
K(IPU,2)=KFPR(ISUB,JT)
IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
K(IPU,3)=MINT(83)+8+JT
IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
P(IPU,5)=PYMASS(K(IPU,2))
ELSE
P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
ENDIF
MINT(22+JT)=K(IPU,2)
600 CONTINUE
C...Find rotation and boost for hard scattering subsystem
I1=MINT(83)+7
I2=MINT(83)+8
BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
GAMCM=(P(I1,4)+P(I2,4))/SHR
BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
PHICM=PYANGL(PX,PY)
C...Store hard scattering subsystem. Rotate and boost it
SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
& P(IPU6,5)**2
PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
CTHWZ=VINT(23)
STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
PHIWZ=VINT(24)-PHICM
P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
P(IPU5,3)=PABS*CTHWZ
P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
P(IPU6,1)=-P(IPU5,1)
P(IPU6,2)=-P(IPU5,2)
P(IPU6,3)=-P(IPU5,3)
P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
DO 620 JT=1,2
I1=MINT(83)+8+JT
I2=MINT(84)+4+JT
K(I1,1)=21
K(I1,2)=K(I2,2)
DO 610 J=1,5
P(I1,J)=P(I2,J)
610 CONTINUE
620 CONTINUE
N=IPU6
MINT(7)=MINT(83)+9
MINT(8)=MINT(83)+10
ENDIF
IF(ISET(ISUB).EQ.11) THEN
ELSEIF(IDOC.GE.8) THEN
C...Store colour connection indices
DO 630 J=1,2
JC=J
IF(KCS.EQ.-1) JC=3-J
IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
& K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
& K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
& MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
& MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
630 CONTINUE
C...Copy outgoing partons to documentation lines
IMAX=2
IF(IDOC.EQ.9) IMAX=3
DO 650 I=1,IMAX
I1=MINT(83)+IDOC-IMAX+I
I2=MINT(84)+2+I
K(I1,1)=21
K(I1,2)=K(I2,2)
IF(IDOC.LE.9) K(I1,3)=0
IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
DO 640 J=1,5
P(I1,J)=P(I2,J)
640 CONTINUE
650 CONTINUE
ELSEIF(IDOC.EQ.9) THEN
C...Store colour connection indices
DO 660 J=1,2
JC=J
IF(KCS.EQ.-1) JC=3-J
IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
& K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
& MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
& K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
& MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
& MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
& MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
660 CONTINUE
C...Copy outgoing partons to documentation lines
DO 680 I=1,3
I1=MINT(83)+IDOC-3+I
I2=MINT(84)+2+I
K(I1,1)=21
K(I1,2)=K(I2,2)
K(I1,3)=0
DO 670 J=1,5
P(I1,J)=P(I2,J)
670 CONTINUE
680 CONTINUE
ENDIF
C...Copy outgoing partons to list of allowed radiators.
NPART=0
IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
DO 690 I=MINT(84)+3,N
NPART=NPART+1
IPART(NPART)=I
PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
690 CONTINUE
ENDIF
C...Low-pT events: remove gluons used for string drawing purposes
IF(ISUB.EQ.95) THEN
IF(MINT(35).LE.1) THEN
K(IPU3,1)=K(IPU3,1)+10
K(IPU4,1)=K(IPU4,1)+10
ENDIF
DO 700 J=41,66
VINTSV(J)=VINT(J)
VINT(J)=0D0
700 CONTINUE
DO 720 I=MINT(83)+5,MINT(83)+8
DO 710 J=1,5
P(I,J)=0D0
710 CONTINUE
720 CONTINUE
ENDIF
RETURN
END
C***********************************************************************
C...PYEVOL
C...Handles intertwined pT-ordered spacelike initial-state parton
C...and multiple interactions.
SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
C...MODE = 0 : (Re-)initialize ISR/MI evolution.
C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...External
EXTERNAL PYALPS
DOUBLE PRECISION PYALPS
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
& PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
C...Local arrays and saved variables.
DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
& ,PSAV,KSAV,VSAV
SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
& /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
C----------------------------------------------------------------------
C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
C...done only once per event, while MODE=0 is repeated each time the
C...evolution needs to be restarted.
IF (MODE.EQ.-1) THEN
ISUBHD=MINT(1)
NSAV=N
NPARTS=NPART
C...Store hard scattering variables
M15SV=MINT(15)
M16SV=MINT(16)
M21SV=MINT(21)
M22SV=MINT(22)
DO 100 J=11,80
VINTSV(J)=VINT(J)
100 CONTINUE
DO 120 J=1,5
DO 110 IS=1,4
I=IS+MINT(84)
PSAV(IS,J)=P(I,J)
KSAV(IS,J)=K(I,J)
VSAV(IS,J)=V(I,J)
110 CONTINUE
120 CONTINUE
C...Set shat for hardest scattering
SHAT(1)=VINT(44)
IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
& *VINT(2)
C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
RMC=PMAS(4,1)
RMB=PMAS(5,1)
ALAM4=PARP(61)
IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
C----------------------------------------------------------------------
C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
C...interaction initiators, with no previous evolution. Check the input
C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
C...smaller than the CM energy / 2.)
ELSEIF (MODE.EQ.0) THEN
C...Reset counters and switches
N=NSAV
NPART=NPARTS
MINT(30)=0
MINT(31)=1
MINT(36)=1
C...Reset hard scattering variables
MINT(1)=ISUBHD
DO 130 J=11,80
VINT(J)=VINTSV(J)
130 CONTINUE
DO 150 J=1,5
DO 140 IS=1,4
I=IS+MINT(84)
P(I,J)=PSAV(IS,J)
K(I,J)=KSAV(IS,J)
V(I,J)=VSAV(IS,J)
P(MINT(83)+4+IS,J)=PSAV(IS,J)
V(MINT(83)+4+IS,J)=VSAV(IS,J)
140 CONTINUE
150 CONTINUE
C...Reset statistics on activity in event.
DO 160 J=351,359
MINT(J)=0
VINT(J)=0D0
160 CONTINUE
C...Reset extra companion reweighting factor
VINT(140)=1D0
C...We do not generate MI for soft process (ISUB=95), but the
C...initialization must be done regardless, for later purposes.
MINT(36)=1
C...Initialize multiple interactions.
CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
IF(MINT(51).NE.0) RETURN
C...Decide whether quarks in hard scattering were valence or sea
PT2HD=VINT(54)
DO 170 JS=1,2
MINT(30)=JS
CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
IF(MINT(51).NE.0) RETURN
170 CONTINUE
C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
VINT(18)=0D0
PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
IF (MSTP(70).EQ.2) THEN
C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
ELSEIF (MSTP(70).EQ.3) THEN
C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
ALPHA0 = MAX(1D-6,PARP(73))
Q20 = ALAM3**2/PARP(64)
IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
ENDIF
C...Also store PT2MIN in VINT(17).
180 VINT(17)=PT2MIN
C...Set FS masses zero now.
VINT(63)=0D0
VINT(64)=0D0
C...Initialize IS showers with VINT(56) as max scale.
PT2ISR=VINT(56)
PT20=PT2MIN
IF (MSTP(70).EQ.0) THEN
PT20=MAX(PT2MIN,PARP(62)**2)
ELSEIF (MSTP(70).EQ.1) THEN
PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
ENDIF
CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
IF(MINT(51).NE.0) RETURN
RETURN
C----------------------------------------------------------------------
C...MODE= 1: Evolve event from PTMAX to PTMIN.
ELSEIF (MODE.EQ.1) THEN
C...Skip if no phase space.
190 IF (PT2MAX.LE.PT2MIN) GOTO 330
C...Starting pT2 max scale (to be udpated successively).
PT2CMX=PT2MAX
C...Evolve two sides of the event to find which branches at highest pT.
200 JSMX=-1
MIMX=0
PT2MX=0D0
C...Loop over current shower initiators.
IF (MSTP(61).GE.1) THEN
DO 230 MI=1,MINT(31)
IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
ISUB=96
IF (MI.EQ.1) ISUB=ISUBHD
MINT(1)=ISUB
MINT(36)=MI
C...Set up shat, initiator x values, and x remaining in BR.
VINT(44)=SHAT(MI)
VINT(141)=XMI(1,MI)
VINT(142)=XMI(2,MI)
VINT(143)=1D0
VINT(144)=1D0
DO 210 JI=1,MINT(31)
IF (JI.EQ.MINT(36)) GOTO 210
VINT(143)=VINT(143)-XMI(1,JI)
VINT(144)=VINT(144)-XMI(2,JI)
210 CONTINUE
C...Loop over sides.
C...Generate trial branchings for this interaction. The hardest
C...branching so far is automatically updated if necessary in /PYISMX/.
DO 220 JS=1,2
MINT(30)=JS
PT20=PT2MIN
IF (MSTP(70).EQ.0) THEN
PT20=MAX(PT2MIN,PARP(62)**2)
ELSEIF (MSTP(70).EQ.1) THEN
PT20=MAX(PT2MIN,
& (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
ENDIF
CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
IF (MINT(51).NE.0) RETURN
220 CONTINUE
230 CONTINUE
ENDIF
C...Generate trial additional interaction.
MINT(36)=MINT(31)+1
240 IF (MOD(MSTP(81),10).GE.1) THEN
MINT(1)=96
C...Set up X remaining in BR.
VINT(143)=1D0
VINT(144)=1D0
DO 250 JI=1,MINT(31)
VINT(143)=VINT(143)-XMI(1,JI)
VINT(144)=VINT(144)-XMI(2,JI)
250 CONTINUE
C...Generate trial interaction
260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
IF (MINT(51).EQ.1) RETURN
ENDIF
C...And the winner is:
IF (PT2MX.LT.PT2MIN) THEN
GOTO 330
ELSEIF (JSMX.EQ.0) THEN
C...Accept additional interaction (may still fail).
CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
IF(MINT(51).NE.0) RETURN
IF (IFAIL.EQ.0) THEN
SHAT(MINT(36))=VINT(44)
C...Decide on flavours (valence/sea/companion).
DO 270 JS=1,2
MINT(30)=JS
CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
IF(MINT(51).NE.0) RETURN
270 CONTINUE
ENDIF
ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
C...Reconstruct kinematics of acceptable ISR branching.
C...Set up shat, initiator x values, and x remaining in BR.
MINT(30)=JSMX
MINT(36)=MIMX
VINT(44)=SHAT(MINT(36))
VINT(141)=XMI(1,MINT(36))
VINT(142)=XMI(2,MINT(36))
VINT(143)=1D0
VINT(144)=1D0
DO 280 JI=1,MINT(31)
IF (JI.EQ.MINT(36)) GOTO 280
VINT(143)=VINT(143)-XMI(1,JI)
VINT(144)=VINT(144)-XMI(2,JI)
280 CONTINUE
PT2NEW=PT2MX
CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
IF (MINT(51).EQ.1) RETURN
ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
C...Bookeep joining. Cannot (yet) be constructed kinematically.
MINT(354)=MINT(354)+1
VINT(354)=VINT(354)+SQRT(PT2MX)
IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
MJOIND(JSMX-2,MJN1MX)=MJN2MX
MJOIND(JSMX-2,MJN2MX)=MJN1MX
ENDIF
C...Update PT2 iteration scale.
PT2CMX=PT2MX
C...Loop back to continue evolution.
IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
ELSE
IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
ENDIF
C----------------------------------------------------------------------
C...MODE= 2: (Re-)store user information on hardest interaction etc.
ELSEIF (MODE.EQ.2) THEN
C...Revert to "ordinary" meanings of some parameters.
290 DO 310 JS=1,2
MINT(12+JS)=K(IMI(JS,1,1),2)
VINT(140+JS)=XMI(JS,1)
IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
VINT(142+JS)=1D0
DO 300 MI=1,MINT(31)
VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
300 CONTINUE
310 CONTINUE
C...Restore saved quantities for hardest interaction.
MINT(1)=ISUBHD
MINT(15)=M15SV
MINT(16)=M16SV
MINT(21)=M21SV
MINT(22)=M22SV
DO 320 J=11,80
VINT(J)=VINTSV(J)
320 CONTINUE
ENDIF
330 RETURN
END
C*********************************************************************
C...PYSSPA
C...Generates spacelike parton showers.
SUBROUTINE PYSSPA(IPU1,IPU2)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYCTAG/NCT,MCT(4000,2)
SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
C...Local arrays and data.
DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
&XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
&WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
&DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
&THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
DATA IS/2*0/
C...Read out basic information; set global Q^2 scale.
IPUS1=IPU1
IPUS2=IPU2
ISUB=MINT(1)
Q2MX=VINT(56)
VINT2R=VINT(2)*VINT(143)*VINT(144)
IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
&MIN(VINT2R,PARP(67)*VINT(56))
FCQ2MX=1D0
C...Define which processes ME corrections have been implemented for.
MECOR=0
IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
& ISUB.EQ.144) MECOR=1
IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
ENDIF
C...Initialize QCD evolution and check phase space.
Q2MNC=PARP(62)**2
Q2MNCS(1)=Q2MNC
Q2MNCS(2)=Q2MNC
IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
Q0S=PARP(15)**2
PS=VINT(3)**2
Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
& EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
Q2INT=SQRT(Q0S*Q2EFF)
Q2MNCS(1)=MAX(Q2MNC,Q2INT)
ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
Q2MNCS(1)=MAX(Q2MNC,VINT(283))
ENDIF
IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
Q0S=PARP(15)**2
PS=VINT(4)**2
Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
& EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
Q2INT=SQRT(Q0S*Q2EFF)
Q2MNCS(2)=MAX(Q2MNC,Q2INT)
ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
Q2MNCS(2)=MAX(Q2MNC,VINT(284))
ENDIF
MCEV=0
ALAMS=PARU(112)
PARU(112)=PARP(61)
FQ2C=1D0
TCMX=0D0
IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
MCEV=1
IF(MSTP(64).EQ.1) FQ2C=PARP(63)
IF(MSTP(64).EQ.2) FQ2C=PARP(64)
TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
& MCEV=0
ENDIF
C...Initialize QED evolution and check phase space.
MEEV=0
XEE=1D-10
SPME=PMAS(11,1)**2
IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
&SPME=PMAS(13,1)**2
IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
&SPME=PMAS(15,1)**2
Q2MNE=MAX(PARP(68)**2,2D0*SPME)
TEMX=0D0
FWTE=10D0
IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
MEEV=1
TEMX=LOG(Q2MX/SPME)
IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
ENDIF
IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
MEEV=2
TEMX=TCMX
FWTE=1D0
ENDIF
IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
C...Loopback point in case of failure to reconstruct kinematics.
NS=N
NPARTS=NPART
LOOP=0
MNT352=MINT(352)
MNT353=MINT(353)
VNT352=VINT(352)
VNT353=VINT(353)
100 LOOP=LOOP+1
IF(LOOP.GT.100) THEN
MINT(51)=1
RETURN
ENDIF
N=NS
NPART=NPARTS
MINT(352)=MNT352
MINT(353)=MNT353
VINT(352)=VNT352
VINT(353)=VNT353
C...Initial values: flavours, momenta, virtualities.
DO 120 JT=1,2
MORE(JT)=1
KFBEAM(JT)=MINT(10+JT)
IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
KFLS(JT)=MINT(14+JT)
KFLS(JT+2)=KFLS(JT)
XS(JT)=VINT(40+JT)
IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
ZS(JT)=1D0
Q2S(JT)=FCQ2MX*Q2MX
DQ2(JT)=0D0
TEVCSV(JT)=TCMX
ALAM(JT)=PARP(61)
THE2(JT)=1D0
TEVESV(JT)=TEMX
MCESV(JT)=0
C...Calculate initial parton distribution weights.
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
VINT(120)=VINT(2+JT)
IF(XS(JT).LT.1D0-XEE) THEN
IF(MINT(31).GE.2) MINT(30)=JT
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
ELSE
CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
ENDIF
ENDIF
DO 110 KFL=-25,25
XFS(JT,KFL)=XFB(KFL)
110 CONTINUE
C...Special kinematics check for c/b quarks (that g -> c cbar or
C...b bbar kinematically possible).
KFLCB=IABS(KFLS(JT))
IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
MINT(51)=1
RETURN
ENDIF
ENDIF
120 CONTINUE
DSH=VINT(44)
IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
C...Find if interference with final state partons.
MFIS=0
IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
IF(MFIS.NE.0) THEN
DO 140 I=1,2
KCFI(I)=0
KCA=PYCOMP(IABS(KFLS(I)))
IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
NFIS(I)=0
IF(KCFI(I).NE.0) THEN
IF(I.EQ.1) IPFS=IPUS1
IF(I.EQ.2) IPFS=IPUS2
DO 130 J=1,2
ICSI=MOD(K(IPFS,3+J),MSTU(5))
IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
& (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
NFIS(I)=NFIS(I)+1
THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
& P(ICSI,2)**2))
IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
ENDIF
130 CONTINUE
ENDIF
140 CONTINUE
IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
ENDIF
C...Pick up leg with highest virtuality.
JTOLD=1
150 N=N+1
JT=1
IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
IF(MORE(JT).EQ.0) JT=3-JT
JTOLD=JT
KFLB=KFLS(JT)
XB=XS(JT)
DO 160 KFL=-25,25
XFB(KFL)=XFS(JT,KFL)
160 CONTINUE
DSHR=2D0*SQRT(DSH)
DSHZ=DSH/ZS(JT)
C...Check if allowed to branch.
MCEV=0
IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
MCEV=1
XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
IF(XB.GE.1D0-2D0*XEC) MCEV=0
ENDIF
MEEV=0
IF(MINT(44+JT).EQ.3) THEN
MEEV=1
IF(XB.GE.1D0-2D0*XEE) MEEV=0
IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
& MEEV=0
C***Currently kill QED shower for resolved photoproduction.
IF(MINT(18+JT).EQ.1) MEEV=0
C***Currently kill shower for W inside electron.
IF(IABS(KFLB).EQ.24) THEN
MCEV=0
MEEV=0
ENDIF
ENDIF
IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
&MEEV=2
IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
Q2B=0D0
GOTO 260
ENDIF
C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
Q2B=Q2S(JT)
TEVCB=TEVCSV(JT)
TEVEB=TEVESV(JT)
IF(MSTP(62).LE.1) THEN
IF(ZS(JT).GT.0.99999D0) THEN
Q2B=Q2S(JT)
ELSE
Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
& (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
& 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
ENDIF
IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
ENDIF
IF(MCEV.EQ.1) THEN
ALSDUM=PYALPS(FQ2C*Q2B)
TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
ALAM(JT)=PARU(117)
B0=(33D0-2D0*MSTU(118))/6D0
ENDIF
IF(MEEV.EQ.2) TEVEB=TEVCB
TEVCBS=TEVCB
TEVEBS=TEVEB
C...Select side for interference with final state partons.
IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
IFI=N-NS
ISFI(IFI)=0
IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
ISFI(IFI)=1
ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
ISFI(IFI)=1
IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
ENDIF
ENDIF
C...Calculate preweighting factor for ME-corrected processes.
IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
C...Calculate Altarelli-Parisi weights.
DO 170 KFL=-25,25
WTAPC(KFL)=0D0
WTAPE(KFL)=0D0
WTSF(KFL)=0D0
170 CONTINUE
C...q -> q (g or gamma emission), g -> q.
IF(IABS(KFLB).LE.10) THEN
WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
EQ2=1D0/9D0
IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
& (XEC*(1D0-XEC)))
IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
WTAPC(KFLB)=WTFF*WTAPC(KFLB)
WTAPC(21)=WTGF*WTAPC(21)
WTAPE(KFLB)=WTFF*WTAPE(KFLB)
ENDIF
C...f -> f, gamma -> f.
ELSEIF(IABS(KFLB).LE.20) THEN
WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
WTAPE(KFLB)=WTFF*WTAPE(KFLB)
WTAPE(22)=WTGF*WTAPE(22)
ENDIF
C...f -> g, g -> g.
ELSEIF(KFLB.EQ.21) THEN
WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
DO 180 KFL=1,MSTP(58)
WTAPC(KFL)=WTAPQ
WTAPC(-KFL)=WTAPQ
180 CONTINUE
WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
DO 190 KFL=1,MSTP(58)
WTAPC(KFL)=WTFG*WTAPC(KFL)
WTAPC(-KFL)=WTFG*WTAPC(-KFL)
190 CONTINUE
WTAPC(21)=WTGG*WTAPC(21)
ENDIF
C...f -> gamma, W+, W-.
ELSEIF(KFLB.EQ.22) THEN
WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
WTAPE(11)=WTAPF
WTAPE(-11)=WTAPF
IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
WTAPE(11)=WTFG*WTAPE(11)
WTAPE(-11)=WTFG*WTAPE(-11)
ENDIF
ELSEIF(KFLB.EQ.24) THEN
WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
& (XEE*(XB+XEE)))/XB
ELSEIF(KFLB.EQ.-24) THEN
WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
& (XEE*(XB+XEE)))/XB
ENDIF
C...Calculate parton distribution weights and sum.
NTRY=0
200 NTRY=NTRY+1
IF(NTRY.GT.500) THEN
MINT(51)=1
RETURN
ENDIF
WTSUMC=0D0
WTSUME=0D0
XFBO=MAX(1D-10,XFB(KFLB))
DO 210 KFL=-25,25
WTSF(KFL)=XFB(KFL)/XFBO
WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
210 CONTINUE
WTSUMC=MAX(0.0001D0,WTSUMC)
WTSUME=MAX(0.0001D0/FWTE,WTSUME)
C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
NTRY2=0
220 NTRY2=NTRY2+1
IF(NTRY2.GT.500) THEN
MINT(51)=1
RETURN
ENDIF
IF(MCEV.EQ.1) THEN
IF(MSTP(64).LE.0) THEN
TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
ELSEIF(MSTP(64).EQ.1) THEN
TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
ELSE
TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
ENDIF
ENDIF
IF(MEEV.EQ.1) THEN
TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
& (PARU(101)*FWTE*WTSUME*TEMX)))
ELSEIF(MEEV.EQ.2) THEN
TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
ENDIF
C...Translate t into Q2 scale; choose between QCD and QED evolution.
230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
C...Ensure that Q2 is above threshold for charm/bottom.
KFLCB=IABS(KFLB)
IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
&MCEV.EQ.1) THEN
IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
Q2CB=1.1D0*PMAS(KFLCB,1)**2
TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
ENDIF
ENDIF
IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
&MEEV.EQ.2) THEN
IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
ENDIF
MCE=0
IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
IF(Q2EB.GT.Q2MNE) MCE=2
ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
MCE=1
IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
ELSE
MCE=2
IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
ENDIF
C...Evolution possibly ended. Update t values.
IF(MCE.EQ.0) THEN
Q2B=0D0
GOTO 260
ELSEIF(MCE.EQ.1) THEN
Q2B=Q2CB
Q2REF=FQ2C*Q2B
IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
ELSE
Q2B=Q2EB
Q2REF=Q2B
IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
ENDIF
C...Select flavour for branching parton.
IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
KFLA=-25
240 KFLA=KFLA+1
IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
IF(KFLA.EQ.25) THEN
Q2B=0D0
GOTO 260
ENDIF
C...Choose z value and corrective weight.
WTZ=0D0
C...q -> q + g or q -> q + gamma.
IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
& (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
WTZ=0.5D0*(1D0+Z**2)
C...q -> g + q.
ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
C...f -> f + gamma.
ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
& (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
ELSE
Z=XB+XB*(XEE/(1D0-XEE))*
& ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
ENDIF
WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
C...f -> gamma + f.
ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
Z=XB+XB*(XEE/(1D0-XEE))*
& ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
C...f -> W+- + f.
ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
Z=XB+XB*(XEE/(1D0-XEE))*
& ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
& (Q2B/(Q2B+PMAS(24,1)**2))
C...g -> q + qbar.
ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
WTZ=1D0-2D0*Z*(1D0-Z)
C...g -> g + g.
ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
WTZ=(1D0-Z*(1D0-Z))**2
C...gamma -> f + fbar.
ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
WTZ=1D0-2D0*Z*(1D0-Z)
ENDIF
IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
C...Option with resummation of soft gluon emission as effective z shift.
IF(MCE.EQ.1) THEN
IF(MSTP(65).GE.1) THEN
RSOFT=6D0
IF(KFLB.NE.21) RSOFT=8D0/3D0
Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
IF(Z.LE.XB) GOTO 220
ENDIF
C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
IF(MSTP(64).GE.2) THEN
IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
ENDIF
ENDIF
C...Remove kinematically impossible branchings.
UHAT=Q2B-DSH*(1D0-Z)/Z
IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
C...Select phi angle of branching at random.
PHIBR=PARU(2)*PYR(0)
C...Matrix-element corrections for some processes.
IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
WTZ=WTZ*WTME/WTFF
ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
WTZ=WTZ*WTME/WTGF
ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
WTZ=WTZ*WTME/WTFG
ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
WTZ=WTZ*WTME/WTGG
ENDIF
ENDIF
C...Impose angular constraint in first branching from interference
C...with final state partons.
IF(MCE.EQ.1) THEN
IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
ENDIF
ENDIF
C...Option with angular ordering requirement.
IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
IF(THE2T.GT.THE2(JT)) GOTO 220
ENDIF
ENDIF
C...Weighting with new parton distributions.
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
VINT(120)=VINT(2+JT)
IF(MINT(31).GE.2) MINT(30)=JT
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
ELSE
CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
ENDIF
XFBN=XFN(KFLB)
IF(XFBN.LT.1D-20) THEN
IF(KFLA.EQ.KFLB) THEN
TEVCB=TEVCBS
TEVEB=TEVEBS
WTAPC(KFLB)=0D0
WTAPE(KFLB)=0D0
GOTO 200
ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
TEVCB=0.5D0*(TEVCBS+TEVCB)
GOTO 230
ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
TEVEB=0.5D0*(TEVEBS+TEVEB)
GOTO 230
ELSE
XFBN=1D-10
XFN(KFLB)=XFBN
ENDIF
ENDIF
DO 250 KFL=-25,25
XFB(KFL)=XFN(KFL)
250 CONTINUE
XA=XB/Z
IF(MINT(31).GE.2) MINT(30)=JT
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
ELSE
CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
ENDIF
XFAN=XFA(KFLA)
IF(XFAN.LT.1D-20) GOTO 200
WTSFA=WTSF(KFLA)
IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
C...Define two hard scatterers in their CM-frame.
260 IF(N.EQ.NS+2) THEN
DQ2(JT)=Q2B
DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
DO 280 JR=1,2
I=NS+JR
IF(JR.EQ.1) IPO=IPUS1
IF(JR.EQ.2) IPO=IPUS2
DO 270 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
270 CONTINUE
K(I,1)=14
K(I,2)=KFLS(JR+2)
K(I,4)=IPO
K(I,5)=IPO
P(I,3)=DPLCM*(-1)**(JR+1)
P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
P(I,5)=-SQRT(DQ2(JR))
K(IPO,1)=14
K(IPO,3)=I
K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
MCT(I,1)=MCT(IPO,1)
MCT(I,2)=MCT(IPO,2)
280 CONTINUE
C...Find maximum allowed mass of timelike parton.
ELSEIF(N.GT.NS+2) THEN
JR=3-JT
DQ2(3)=Q2B
DPC(1)=P(IS(1),4)
DPC(2)=P(IS(2),4)
DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
DPD(1)=DSH+DQ2(JR)+DQ2(JT)
DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
IKIN=0
IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
& 1D-10*DPD(1)) IKIN=1
IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
& (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
& (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
C...Generate timelike parton shower (if required).
IT=N
DO 290 J=1,5
K(IT,J)=0
P(IT,J)=0D0
V(IT,J)=0D0
290 CONTINUE
C...f -> f + g (gamma).
IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
K(IT,2)=21
IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
C...f -> g (gamma, W+-) + f.
ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
K(IT,2)=KFLB
IF(KFLS(JT+2).EQ.24) THEN
K(IT,2)=-12
ELSEIF(KFLS(JT+2).EQ.-24) THEN
K(IT,2)=12
ENDIF
C...g (gamma) -> f + fbar, g + g.
ELSE
K(IT,2)=-KFLS(JT+2)
IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
ENDIF
K(IT,1)=3
IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
& IABS(K(IT,2)).EQ.22) K(IT,1)=1
P(IT,5)=PYMASS(K(IT,2))
IF(DMSMA.LE.P(IT,5)**2) GOTO 100
IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
MSTJ48=MSTJ(48)
PARJ85=PARJ(85)
P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
IF(MSTP(63).EQ.1) THEN
Q2TIM=DMSMA
ELSEIF(MSTP(63).EQ.2) THEN
Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
ELSE
Q2TIM=DMSMA
MSTJ(48)=1
IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
& DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
PARJ(85)=SQRT(MAX(0D0,DPT2))*
& (1D0/P(IT,4)+1D0/P(IS(JT),4))
ENDIF
C...Only do timelike shower here if using PYSHOW
IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
CALL PYSHOW(IT,0,SQRT(Q2TIM))
ENDIF
MSTJ(48)=MSTJ48
PARJ(85)=PARJ85
IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
ENDIF
C...Reconstruct kinematics of branching: timelike parton shower.
DMS=P(IT,5)**2
IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
& 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
& (4D0*DSH*DPC(3)**2)
IF(DPT2.LT.0D0) GOTO 100
DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
& DSHR)/DPC(3)-DPC(3)
P(IT,1)=SQRT(DPT2)
P(IT,3)=DPB(1)*(-1)**(JT+1)
P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
IF(N.GE.IT+1) THEN
DPB(1)=SQRT(DPB(1)**2+DPT2)
DPB(2)=SQRT(DPB(1)**2+DMS)
DPB(3)=P(IT+1,3)
DPB(4)=SQRT(DPB(3)**2+DMS)
DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
& DPB(1))
CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
THE=PYANGL(P(IT,3),P(IT,1))
CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
ENDIF
C...Reconstruct kinematics of branching: spacelike parton.
DO 300 J=1,5
K(N+1,J)=0
P(N+1,J)=0D0
V(N+1,J)=0D0
300 CONTINUE
K(N+1,1)=14
K(N+1,2)=KFLB
P(N+1,1)=P(IT,1)
P(N+1,3)=P(IT,3)+P(IS(JT),3)
P(N+1,4)=P(IT,4)+P(IS(JT),4)
P(N+1,5)=-SQRT(DQ2(3))
MCT(N+1,1)=0
MCT(N+1,2)=0
C...Define colour flow of branching.
K(IS(JT),3)=N+1
K(IT,3)=N+1
IM1=N+1
IM2=N+1
C...f -> f + gamma (Z, W).
IF(IABS(K(IT,2)).GE.22) THEN
K(IT,1)=1
ID1=IS(JT)
ID2=IS(JT)
C...f -> gamma (Z, W) + f.
ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
ID1=IT
ID2=IT
C...gamma -> q + qbar, g + g.
ELSEIF(K(N+1,2).EQ.22) THEN
ID1=IS(JT)
ID2=IT
IM1=ID2
IM2=ID1
C...q -> q + g.
ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
ID1=IT
ID2=IS(JT)
C...q -> g + q.
ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
ID1=IS(JT)
ID2=IT
C...qbar -> qbar + g.
ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
ID1=IS(JT)
ID2=IT
C...qbar -> g + qbar.
ELSEIF(K(N+1,2).LT.0) THEN
ID1=IT
ID2=IS(JT)
C...g -> g + g; g -> q + qbar.
ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
ID1=IS(JT)
ID2=IT
ELSE
ID1=IT
ID2=IS(JT)
ENDIF
IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
IF(ID1.NE.ID2) THEN
K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
ENDIF
N=N+1
IF(K(IT,1).EQ.1) THEN
K(IT,4)=0
K(IT,5)=0
ENDIF
C...Boost to new CM-frame.
DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
IR=N+(JT-1)*(IS(1)-N)
CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
& 0D0,0D0,0D0)
C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
NPART=NPART+1
IPART(NPART)=IT
PTPART(NPART)=SQRT(PARP(71)*DPT2)
ENDIF
C...Global statistics.
MINT(352)=MINT(352)+1
VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
ENDIF
C...Update kinematics variables.
IS(JT)=N
DQ2(JT)=Q2B
IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
DSH=DSHZ
C...Save quantities; loop back.
Q2S(JT)=Q2B
DPHI(JT)=PHIBR
MCESV(JT)=MCE
IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
&(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
KFLS(JT+2)=KFLS(JT)
KFLS(JT)=KFLA
XS(JT)=XA
ZS(JT)=Z
DO 310 KFL=-25,25
XFS(JT,KFL)=XFA(KFL)
310 CONTINUE
TEVCSV(JT)=TEVCB
TEVESV(JT)=TEVEB
ELSE
MORE(JT)=0
IF(JT.EQ.1) IPU1=N
IF(JT.EQ.2) IPU2=N
ENDIF
IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) N=NS
IF(MSTU(21).GE.1) RETURN
ENDIF
IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
C...Boost hard scattering partons to frame of shower initiators.
DO 320 J=1,3
ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
320 CONTINUE
K(N+2,1)=1
DO 330 J=1,5
P(N+2,J)=P(NS+1,J)
330 CONTINUE
CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
IMIN=MINT(83)+5
IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
C...Store user information. Reset Lambda value.
IF(MINT(31).LE.1) THEN
K(IPU1,3)=MINT(83)+3
K(IPU2,3)=MINT(83)+4
ELSE
K(IPU1,3)=MINT(83)+1
K(IPU2,3)=MINT(83)+2
ENDIF
DO 340 JT=1,2
MINT(12+JT)=KFLS(JT)
VINT(140+JT)=XS(JT)
IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
340 CONTINUE
PARU(112)=ALAMS
RETURN
END
C*********************************************************************
C...PYPTIS
C...Generates pT-ordered spacelike initial-state parton showers and
C...trial joinings.
C...MODE=-1: Initialize ISR from scratch, starting from the hardest
C... interaction initiators at PT2NOW.
C...MODE= 0: Generate a trial branching on interaction MINT(36), side
C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
C... is below PT2CUT.
C... (Also generate test joinings if MSTP(96)=1.)
C...MODE= 1: Accept stored shower branching. Update event record etc.
C...PT2NOW : Starting (max) PT2 scale for evolution.
C...PT2CUT : Lower limit for evolution.
C...PT2 : Result of evolution. Generated PT2 for trial emission.
C...IFAIL : Status return code. IFAIL=0 when all is well.
SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
& PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
& /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
C...Local variables
DIMENSION ZSAV(2,240),PT2SAV(2,240),
& XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
& WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
& WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
& RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
C...For check on excessive weights.
CHARACTER CHWT*12
C...Only give errors for very large weights, otherwise just warnings
DATA WTEMAX /1.5D0/
C...Only give errors for large pT, otherwise just warnings
DATA PTEMAX /5D0/
IFAIL=-1
C----------------------------------------------------------------------
C...MODE=-1: Initialize initial state showers from scratch, i.e.
C...starting from the hardest interaction initiators.
IF (MODE.EQ.-1) THEN
C...Set hard scattering SHAT.
SHTNOW(1)=VINT(44)
C...Mass thresholds and Lambda for QCD evolution.
AEM2PI=PARU(101)/PARU(2)
RMB=PMAS(5,1)
RMC=PMAS(4,1)
ALAM4=PARP(61)
IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
C...Optionally use Lambda_MC = Lambda_CMW
IF (MSTP(64).EQ.3) THEN
ALAM5 = ALAM5 * 1.569
ALAM4 = ALAM4 * 1.618
ALAM3 = ALAM3 * 1.661
ENDIF
RMB2=RMB**2
RMC2=RMC**2
C...Massive quark forced creation threshold (in M**2).
TMIN=1.01D0
C...Set upper limit for X (ensures some X left for beam remnant).
XMXC=1D0-2D0*PARP(111)/VINT(1)
IF (MSTP(61).GE.1) THEN
C...Initial values: flavours, momenta, virtualities.
DO 100 JS=1,2
NISGEN(JS,1)=0
C...Special kinematics check for c/b quarks (that g -> c cbar or
C...b bbar kinematically possible).
KFLB=K(IMI(JS,1,1),2)
KFLCB=IABS(KFLB)
IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
C...Check PT2MAX > mQ^2
IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
& 'No Q creation possible.')
MINT(51)=1
RETURN
ELSE
C...Check for physical z values (m == MQ / sqrt(s))
C...For creation diagram, x < z < (1-m)/(1+m(1-m))
FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
& 'Q creation.')
MINT(51)=1
RETURN
ENDIF
ENDIF
ENDIF
100 CONTINUE
ENDIF
MINT(354)=0
C...Zero joining array
DO 110 MJ=1,240
MJOIND(1,MJ)=0
MJOIND(2,MJ)=0
110 CONTINUE
C----------------------------------------------------------------------
C...MODE= 0: Generate a trial branching on interaction MINT(36) side
C...MINT(30). Store if emission PT2 scale is largest so far.
C...Also generate test joinings if MSTP(96)=1.
ELSEIF(MODE.EQ.0) THEN
IFAIL=-1
MECOR=0
ISUB=MINT(1)
JS=MINT(30)
C...No shower for structureless beam
IF (MINT(44+JS).EQ.1) RETURN
MI=MINT(36)
SHAT=VINT(44)
C...Absolute shower max scale = VINT(56)
IF (MSTP(67).NE.0) THEN
PT2 = MIN(PT2NOW,VINT(56))
ELSE
C...For MSTP(67)=0, adjust starting scale by PARP(67)
PT2=MIN(PT2NOW,PARP(67)*VINT(56))
ENDIF
IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
C...Define for which processes ME corrections have been implemented.
IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
& .142.OR.ISUB.EQ.144) MECOR=1
IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
C...Calculate preweighting factor for ME-corrected processes.
IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
ENDIF
C...Basic info on daughter for which to find mother.
KFLB=K(IMI(JS,MI,1),2)
KFLBA=IABS(KFLB)
C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
C...second companion.
KSVCB=MAX(-1,IMI(JS,MI,2))
C...Treat "first" companion of a pair like an ordinary sea quark
C...(except that creation diagram is not allowed)
IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
C...X (rescaled to [0,1])
XB=XMI(JS,MI)/VINT(142+JS)
C...Massive quarks (use physical masses.)
RMQ2=0D0
MQMASS=0
IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
RMQ2=RMC2
IF (KFLBA.EQ.5) RMQ2=RMB2
C...Special threshold treatment for non-photon beams
IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
C...Check that not below mass threshold.
IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
& 'No Q creation possible.')
MINT(51)=1
C...Special return code if failing before any evolution at all: bad event
IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
RETURN
ENDIF
ENDIF
C...Flags for parton distribution calls.
MINT(105)=MINT(102+JS)
MINT(109)=MINT(106+JS)
VINT(120)=VINT(2+JS)
C...Calculate initial parton distribution weights.
IF(XB.GE.XMXC) THEN
RETURN
ELSEIF(MQMASS.EQ.0) THEN
CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
ELSE
C...Initialize massive quark PT2 dependent pdf underestimate.
PT20=PT2
CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
C.!.Tentative treatment of massive valence quarks.
XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
XG0=XFB(21)
TPM0=LOG(PT20/RMQ2)
WPDF0=TPM0*XG0/XQ0
ENDIF
IF (KFLBA.LE.6) THEN
C...For quarks, only include respective sea, val, or cmp part.
IF (KSVCB.LE.0) THEN
XFB(KFLB)=XPSVC(KFLB,KSVCB)
ELSE
C...Find companion's companion
MISEA=0
120 MISEA=MISEA+1
IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
XS=XMI(JS,MISEA)
XREM=VINT(142+JS)
YS=XS/(XREM+XS)
C...Momentum fraction of the companion quark.
C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
YB=XB*(1D0-YS)
XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
ENDIF
ENDIF
C...Determine overestimated z range: switch at c and b masses.
130 IF (PT2.GT.TMIN*RMB2) THEN
IZRG=3
PT2MNE=MAX(TMIN*RMB2,PT2CUT)
B0=23D0/6D0
ALAM2=ALAM5**2
ELSEIF(PT2.GT.TMIN*RMC2) THEN
IZRG=2
PT2MNE=MAX(TMIN*RMC2,PT2CUT)
B0=25D0/6D0
ALAM2=ALAM4**2
ELSE
IZRG=1
PT2MNE=PT2CUT
B0=27D0/6D0
ALAM2=ALAM3**2
ENDIF
C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
ALAM2=ALAM2/PARP(64)
C...Overestimated ZMAX:
IF (MQMASS.EQ.0) THEN
C...Massless
ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
& /PT2MNE)-1D0)
ELSE
C...Massive (limit for bremsstrahlung diagram > creation)
FMQ=SQRT(RMQ2/SHTNOW(MI))
ZMAX=1D0/(1D0+FMQ)
ENDIF
ZMIN=XB/XMXC
C...If kinematically impossible then do not evolve.
IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
C...Reset Altarelli-Parisi and PDF weights.
DO 140 KFL=-5,5
WTAP(KFL)=0D0
WTPDF(KFL)=0D0
140 CONTINUE
WTAP(21)=0D0
WTPDF(21)=0D0
C...Zero joining weights and compute X(partner) and X(mother) values.
NJN=0
IF (MSTP(96).NE.0) THEN
DO 150 MJ=1,MINT(31)
WTAPJ(MJ)=0D0
WTPDFJ(MJ)=0D0
X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
& +XMI(JS,MI))
150 CONTINUE
ENDIF
C...Approximate Altarelli-Parisi weights (integrated AP dz).
C...q -> q, g -> q or q -> q + gamma (already set which).
IF(KFLBA.LE.5) THEN
C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
IF (KSVCB.LT.0) THEN
WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
ELSE
RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
ENDIF
WTAP(21)=0.5D0*(ZMAX-ZMIN)
WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
WTAP(KFLB)=WTFF*WTAP(KFLB)
WTAP(21)=WTGF*WTAP(21)
WTAPE=WTFF*WTAPE
ENDIF
IF(MSTP(61).EQ.1) WTAPE=0D0
IF (KSVCB.GE.1) THEN
C...Kill normal creation but add joining diagrams for cmp quark.
WTAP(21)=0D0
IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
& " quark here. Not handled yet, giving up!")
PT2=0D0
MINT(51)=1
RETURN
ENDIF
C...Check for possible joinings
IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
C...Find companion's companion.
MJ=0
160 MJ=MJ+1
IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
IF (MJOIND(JS,MJ).EQ.0) THEN
Y(MI)=YB+YS
Z=YB/Y(MI)
WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
IF (WTAPJ(MJ).GT.1D-6) THEN
NJN=1
ELSE
WTAPJ(MJ)=0D0
ENDIF
ENDIF
C...Add trial gluon joinings.
DO 170 MJ=1,MINT(31)
KFLC=K(IMI(JS,MJ,1),2)
IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
IF (WTAPJ(MJ).GT.1D-6) THEN
NJN=NJN+1
ELSE
WTAPJ(MJ)=0D0
ENDIF
170 CONTINUE
ENDIF
ELSEIF (IMI(JS,MI,2).GE.0) THEN
C...Kill creation diagram for val quarks and sea quarks with companions.
WTAP(21)=0D0
ELSEIF (MQMASS.EQ.0) THEN
C...Extra safety factor for massless sea quark creation.
WTAP(21)=WTAP(21)*1.25D0
ENDIF
C... q -> g, g -> g.
ELSEIF(KFLB.EQ.21) THEN
C...Here we decide later whether a quark picked up is valence or
C...sea, so we maintain the extra factor sqrt(z) since we deal
C...with the *sum* of sea and valence in this context.
WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
C...new: do not allow backwards evol to pick up heavy flavour.
DO 180 KFL=1,MIN(3,MSTP(58))
WTAP(KFL)=WTAPQ
WTAP(-KFL)=WTAPQ
180 CONTINUE
WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
WTAPQ=WTFG*WTAPQ
WTAP(21)=WTGG*WTAP(21)
ENDIF
C...Check for possible joinings (companions handled separately above)
IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
& THEN
DO 190 MJ=1,MINT(31)
IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
KSVCC=IMI(JS,MJ,2)
IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
IF (KSVCC.GE.1) GOTO 190
KFLC=K(IMI(JS,MJ,1),2)
C...Only try g -> g + g once.
IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
IF (KFLC.EQ.21) THEN
WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
ELSE
WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
ENDIF
IF (WTAPJ(MJ).GT.1D-6) THEN
NJN=NJN+1
ELSE
WTAPJ(MJ)=0D0
ENDIF
190 CONTINUE
ENDIF
ENDIF
C...Initialize massive quark evolution
IF (MQMASS.NE.0) THEN
RML=(RMQ2+VINT(18))/ALAM2
TML=LOG(RML)
TPL=LOG((PT2+VINT(18))/ALAM2)
TPM=LOG((PT2+VINT(18))/RMQ2)
WN=WTAP(21)*WPDF0/B0
ENDIF
C...Loopback point for iteration
NTRY=0
NTHRES=0
200 NTRY=NTRY+1
IF(NTRY.GT.500) THEN
CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
MINT(51)=1
RETURN
ENDIF
C... Calculate PDF weights and sum for evolution rate.
WTSUM=0D0
XFBO=MAX(1D-10,XFB(KFLB))
DO 210 KFL=-5,5
WTPDF(KFL)=XFB(KFL)/XFBO
WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
210 CONTINUE
C...Only add gluon mother diagram for massless KFLB.
IF(MQMASS.EQ.0) THEN
WTPDF(21)=XFB(21)/XFBO
WTSUM=WTSUM+WTAP(21)*WTPDF(21)
ENDIF
WTSUM=MAX(0.0001D0,WTSUM)
WTSUMS=WTSUM
C...Add joining diagrams where applicable.
WTJOIN=0D0
IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
DO 220 MJ=1,MINT(31)
IF (WTAPJ(MJ).LT.1D-3) GOTO 220
WTPDFJ(MJ)=1D0/XFBO
C...x and x*pdf (+ sea/val) for parton C.
KFLC=K(IMI(JS,MJ,1),2)
KFLCA=IABS(KFLC)
KSVCC=MAX(-1,IMI(JS,MJ,2))
IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
MINT(30)=JS
MINT(36)=MJ
CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
MINT(36)=MI
IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
XFJ(KFLC)=XPSVC(KFLC,KSVCC)
ELSEIF (KSVCC.GE.1) THEN
print*, 'error! parton C is companion!'
ENDIF
WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
C...x and x*pdf (+ sea/val) for parton A.
KFLA=21
KSVCA=0
IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
KFLA=KFLB
KSVCA=KSVCB
ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
KFLA=KFLC
KSVCA=KSVCC
ENDIF
MINT(30)=JS
IF (KSVCA.LE.0) THEN
C...Consider C the "evolved" parton if B is gluon. Val/sea
C...counting will then be done correctly in PYPDFU.
IF (KFLBA.EQ.21) MINT(36)=MJ
CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
MINT(36)=MI
IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
ELSE
C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
ENDIF
WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
220 CONTINUE
ENDIF
C...Pick normal pT2 (in overestimated z range).
230 PT2OLD=PT2
WTSUM=WTSUMS
PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
KFLC=21
C...Evolve q -> q gamma separately, pick it if larger pT.
IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN
PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
IF(PT2QED.GT.PT2) THEN
PT2=PT2QED
KFLC=22
KFLA=KFLB
ENDIF
ENDIF
C... Evolve massive quark creation separately.
MCRQQ=0
IF (MQMASS.NE.0) THEN
PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
& -VINT(18)
C...If massive quark also on opposite side, ensure sufficient remaining
C...phase space also for creation of that quark
TMINQQ = TMIN
KFLOPP = K(IMI(3-JS,MI,1),2)
IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
C...Ensure mininimum PT2CR and force creation near threshold.
IF (PT2CR.LT.TMINQQ*RMQ2) THEN
NTHRES=NTHRES+1
IF (NTHRES.GT.50) THEN
CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
& 'massive quark creation. Gave up trying.')
MINT(51)=1
C...Special return code if failing before any evolution at all: bad event
IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
RETURN
ENDIF
PT2=0D0
PT2CR=TMINQQ*RMQ2
C...Signal that massive quark creation is being forced
MCRQQ=2
ENDIF
C... Select largest PT2 (brems or creation):
IF (PT2CR.GT.PT2) THEN
MCRQQ=MAX(MCRQQ,1)
WTSUM=0D0
PT2=PT2CR
KFLA=21
ELSE
MCRQQ=0
KFLA=KFLB
ENDIF
C... Compute logarithms for this PT2
TPL=LOG((PT2+VINT(18))/ALAM2)
TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
WTCRQQ=TPM/LOG(PT2/RMQ2)
ENDIF
C...Evolve joining separately
MJOIN=0
IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
& -VINT(18)
IF (PT2JN.GE.PT2) THEN
MJOIN=1
PT2=PT2JN
ENDIF
ENDIF
C...Loopback if crossed c/b mass thresholds.
IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
PT2=RMB2
GOTO 130
ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
PT2=RMC2
GOTO 130
ENDIF
C...Speed up shower. Skip if higher-PT acceptable branching
C...already found somewhere else.
C...Also finish if below lower cutoff.
IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN
C...Select parton A flavour (massive Q handled above.)
IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
WTRAN=PYR(0)*WTSUM
KFLA=-6
240 KFLA=KFLA+1
WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
IF(KFLA.EQ.6) KFLA=21
ELSEIF (MJOIN.EQ.1) THEN
C...Tentative joining accept/reject.
WTRAN=PYR(0)*WTJOIN
MJ=0
250 MJ=MJ+1
WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
& ' Rejected.')
GOTO 230
ENDIF
C...x*pdf (+ sea/val) at new pT2 for parton B.
IF (KSVCB.LE.0) THEN
MINT(30)=JS
CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
ELSE
C...Companion distributions do not evolve.
XFB(KFLB)=XFBO
ENDIF
WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
KFLC=K(IMI(JS,MJ,1),2)
KFLCA=IABS(KFLC)
KSVCC=MAX(-1,IMI(JS,MJ,2))
IF (KSVCB.GE.1) KSVCC=-1
C...x*pdf (+ sea/val) at new pT2 for parton C.
MINT(30)=JS
MINT(36)=MJ
CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
MINT(36)=MI
IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
WTVETO=WTVETO/XFJ(KFLC)
C...x and x*pdf (+ sea/val) at new pT2 for parton A.
KFLA=21
KSVCA=0
IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
KFLA=KFLB
KSVCA=KSVCB
ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
KFLA=KFLC
KSVCA=KSVCC
ENDIF
IF (KSVCA.LE.0) THEN
MINT(30)=JS
IF (KFLB.EQ.21) MINT(36)=MJ
CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
MINT(36)=MI
IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
ELSE
XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
ENDIF
WTVETO=WTVETO*XFJ(KFLA)
C...Monte Carlo veto.
IF (WTVETO.LT.PYR(0)) GOTO 200
C...If accept, save PT2 of this joining.
IF (PT2.GT.PT2MX) THEN
PT2MX=PT2
JSMX=2+JS
MJN1MX=MJ
MJN2MX=MI
WTAPJ(MJ)=0D0
NJN=0
ENDIF
C...Exit and continue evolution.
GOTO 390
ENDIF
KFLAA=IABS(KFLA)
C...Choose z value (still in overestimated range) and corrective weight.
C...Unphysical z will be rejected below when Q2 has is computed.
WTZ=0D0
C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
C...q -> q + g or q -> q + gamma (already set which).
IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
IF (KSVCB.LT.0) THEN
Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
ELSE
ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
Z=((1-ZFAC)/(1+ZFAC))**2
ENDIF
WTZ=0.5D0*(1D0+Z**2)
C...Massive weight correction.
IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
C...Valence quark weight correction (extra sqrt)
IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
C...q -> g + q.
C...NB: MQ>0 not yet implemented. Forced absent above.
ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
KFLC=KFLA
Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
C...g -> q + qbar.
ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
KFLC=-KFLB
Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
WTZ=Z**2+(1D0-Z)**2
C...Massive correction
IF (MQMASS.NE.0) THEN
WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
C...Extra safety margin for light sea quark creation
ELSEIF (KSVCB.LT.0) THEN
WTZ=WTZ/1.25D0
ENDIF
C...g -> g + g.
ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
KFLC=21
Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
& (ZMAX*(1D0-ZMIN)))**PYR(0))
WTZ=(1D0-Z*(1D0-Z))**2
ENDIF
C...Derive Q2 from pT2.
Q2B=PT2/(1D0-Z)
IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
C...Loopback if outside allowed z range for given pT2.
RM2C=PYMASS(KFLC)**2
PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
IF (PT2ADJ.LT.1D-6) GOTO 230
C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
C...No modification for very first emission if using ME correction
MSTP67 = MSTP(67)
IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
MSTP67 = 0
ENDIF
C...For 1st branching, limit phase space by s-hat with color-partner
IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
MSIDE=1
IDIP=IMI(JS,MI,1)
C...Use anticolor tag for antiquark, or for gluon half the time
IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
& KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
C...Tag
MCTAG=MCT(IDIP,MSIDE)
C...Default is to set up phase space using the opposite incoming parton
JDIP=IMI(3-JS,MI,1)
NDIP=0
C...Alternatively, look for final-state color partner (pick first if several)
DO 260 IFS=1,NPART
IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
JDIP=IPART(IFS)
NDIP=NDIP+1
ENDIF
260 CONTINUE
C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2
& -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2))
IF (MSTP67.EQ.1) THEN
C...1 Option to completely kill radiation above s_dip * PARP(67)
IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230
ELSE IF (MSTP67.EQ.2) THEN
C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
C... (-> improved power showers?)
IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
ENDIF
C...For subsequent branchings, loopback if nonordered in angle/rapidity
ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
& GOTO 230
ENDIF
C...Select phi angle of branching at random.
PHI=PARU(2)*PYR(0)
C...Matrix-element corrections for some processes.
IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
WTZ=WTZ*WTME/WTFF
ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
WTZ=WTZ*WTME/WTGF
ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
WTZ=WTZ*WTME/WTFG
ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
WTZ=WTZ*WTME/WTGG
ENDIF
ENDIF
C...Parton distributions at new pT2 but old x.
MINT(30)=JS
CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
C...Treat val and cmp separately
IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
IF (KSVCB.GE.1)
& XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
XFBN=XFN(KFLB)
IF(XFBN.LT.1D-20) THEN
IF(KFLA.EQ.KFLB) THEN
WTAP(KFLB)=0D0
GOTO 200
ELSE
XFBN=1D-10
XFN(KFLB)=XFBN
ENDIF
ENDIF
DO 270 KFL=-5,5
XFB(KFL)=XFN(KFL)
270 CONTINUE
XFB(21)=XFN(21)
C...Parton distributions at new pT2 and new x.
XA=XB/Z
MINT(30)=JS
CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
C...q -> q + g: only consider respective sea, val, or cmp content.
IF (KSVCB.LE.0) THEN
XFA(KFLA)=XPSVC(KFLA,KSVCB)
ELSE
YA=XA*(1D0-YS)
XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
ENDIF
ENDIF
XFAN=XFA(KFLA)
IF(XFAN.LT.1D-20) THEN
GOTO 200
ENDIF
C...If weighting fails continue evolution.
WTTOT=0D0
IF (MCRQQ.EQ.0) THEN
WTPDFA=1D0/WTPDF(KFLA)
WTTOT=WTZ*XFAN/XFBN*WTPDFA
ELSEIF(MCRQQ.EQ.1) THEN
WTPDFA=TPM/WPDF0
WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
XBEST=TPM/TPM0*XQ0
ELSEIF(MCRQQ.EQ.2) THEN
C...Force massive quark creation.
WTTOT=1D0
ENDIF
C...Loop back if trial emission fails.
IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
WTACC=((1D0+PT2)/(0.25D0+PT2))**2
IF(WTTOT.LT.0D0) THEN
WRITE(CHWT,'(1P,E12.4)') WTTOT
CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
ELSEIF(WTTOT.GT.WTACC) THEN
WRITE(CHWT,'(1P,E12.4)') WTTOT
IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
C...Too high weight: write out as error, but do not update error counter
IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
CALL PYERRM(19,
& '(PYPTIS:) Weight '//CHWT//' above unity')
IF (PT2.GT.PTEMAX) PTEMAX=PT2
IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
ELSE
CALL PYERRM(9,
& '(PYPTIS:) Weight '//CHWT//' above unity')
ENDIF
C...Useful for debugging but commented out for distribution:
C print*, 'JS, MI',JS, MI
C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
C print*, 'A -> B C',KFLA, KFLB, KFLC
C XFAO=XFBO/WTPDFA
C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
ENDIF
C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks
C...simultaneously reached their creation thresholds)
IF (ABS(PT2-PT2MX).LT.0.001) THEN
IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
ENDIF
C...Save acceptable branching.
IF(PT2.GT.PT2MX) THEN
MIMX=MINT(36)
JSMX=JS
PT2MX=PT2
KFLAMX=KFLA
KFLCMX=KFLC
RM2CMX=RM2C
Q2BMX=Q2B
ZMX=Z
PT2AMX=PT2ADJ
PHIMX=PHI
ENDIF
C----------------------------------------------------------------------
C...MODE= 1: Accept stored shower branching. Update event record etc.
ELSEIF (MODE.EQ.1) THEN
MI=MIMX
JS=JSMX
SHAT=SHTNOW(MI)
SIDE=3D0-2D0*JS
C...Shift down rest of event record to make room for insertion.
IT=IMISEP(MI)+1
IM=IT+1
IS=IMI(JS,MI,1)
DO 290 I=N,IT,-1
IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
KT1=K(I,4)/MSTU(5)**2
KT2=K(I,5)/MSTU(5)**2
ID1=MOD(K(I,4),MSTU(5))
ID2=MOD(K(I,5),MSTU(5))
IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
IF (ID1.GE.IT) ID1=ID1+2
IF (ID2.GE.IT) ID2=ID2+2
IF (IM1.GE.IT) IM1=IM1+2
IF (IM2.GE.IT) IM2=IM2+2
K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
DO 280 IX=1,5
K(I+2,IX)=K(I,IX)
P(I+2,IX)=P(I,IX)
V(I+2,IX)=V(I,IX)
280 CONTINUE
MCT(I+2,1)=MCT(I,1)
MCT(I+2,2)=MCT(I,2)
290 CONTINUE
N=N+2
C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
DO 300 JI=1,MINT(31)
IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
C...Also update companion pointers to the present mother.
IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
300 CONTINUE
DO 310 IFS=1,NPART
IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
310 CONTINUE
C...Zero entries dedicated for new timelike and mother partons.
DO 330 I=IT,IT+1
DO 320 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
320 CONTINUE
MCT(I,1)=0
MCT(I,2)=0
330 CONTINUE
C...Define timelike and new mother partons. History.
K(IT,1)=3
K(IT,2)=KFLCMX
K(IM,1)=14
K(IM,2)=KFLAMX
K(IS,3)=IM
K(IT,3)=IM
C...Set mother origin = side.
K(IM,3)=MINT(83)+JS+2
IF(MI.GE.2) K(IM,3)=MINT(83)+JS
C...Define colour flow of branching.
IM1=IM
IM2=IM
C...q -> q + gamma.
IF(K(IT,2).EQ.22) THEN
K(IT,1)=1
ID1=IS
ID2=IS
C...q -> q + g.
ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
ID1=IT
ID2=IS
C...q -> g + q.
ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
ID1=IS
ID2=IT
C...qbar -> qbar + g.
ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
ID1=IS
ID2=IT
C...qbar -> g + qbar.
ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
ID1=IT
ID2=IS
C...g -> g + g; g -> q + qbar..
ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
ID1=IS
ID2=IT
ELSE
ID1=IT
ID2=IS
ENDIF
IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
IF(ID1.NE.ID2) THEN
K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
ENDIF
IF(K(IT,1).EQ.1) THEN
K(IT,4)=0
K(IT,5)=0
ENDIF
C...Update IMI and colour tag arrays.
IMI(JS,MI,1)=IM
DO 340 MC=1,2
MCT(IT,MC)=0
MCT(IM,MC)=0
340 CONTINUE
DO 350 JCS=4,5
KCS=JCS
C...If mother flag not yet set for spacelike parton, trace it.
IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
IF(MINT(51).NE.0) RETURN
350 CONTINUE
DO 360 JCS=4,5
KCS=JCS
C...If mother flag not yet set for timelike parton, trace it.
IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
IF(MINT(51).NE.0) RETURN
360 CONTINUE
C...Boost recoiling parton to compensate for Q2 scale.
BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
& (1D0+(1D0+Q2BMX/SHAT)**2)
IR=IMI(3-JS,MI,1)
CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
C...Define system to be rotated and boosted
C...(not including the 2 just added partons)
C...(but including the docu lines for first interaction)
IMIN=IMISEP(MI-1)+1
IF (MI.EQ.1) IMIN=MINT(83)+5
IMAX=IMISEP(MI)-2
C...Rotate back system in phi to compensate for subsequent rotation.
CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
C...Define kinematics of new partons in old frame.
IMAX=IMISEP(MI)
P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
& +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
P(IT,1)=P(IM,1)
P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
P(IT,5)=SQRT(RM2CMX)
C...Update internal line, now spacelike
P(IS,1)=P(IM,1)-P(IT,1)
P(IS,2)=P(IM,2)-P(IT,2)
P(IS,3)=P(IM,3)-P(IT,3)
P(IS,4)=P(IM,4)-P(IT,4)
P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
IF (P(IS,5).LT.0D0) THEN
P(IS,5)=-SQRT(ABS(P(IS,5)))
ELSE
P(IS,5)=SQRT(P(IS,5))
ENDIF
C...Boost entire system and rotate to new frame.
C...(including docu lines)
BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
IF(BETAX**2+BETAZ**2.GE.1D0) THEN
CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
MINT(51)=1
IFAIL=-1
RETURN
ENDIF
CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
I1=IMI(1,MI,1)
THETA=PYANGL(P(I1,3),P(I1,1))
CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
C...Global statistics.
MINT(352)=MINT(352)+1
VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
C...Add parton with relevant pT scale for timelike shower.
IF (K(IT,2).NE.22) THEN
NPART=NPART+1
IPART(NPART)=IT
PTPART(NPART)=SQRT(PT2AMX)
ENDIF
C...Update saved variables.
SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
PT2SAV(JSMX,MIMX)=PT2MX
ZSAV(JS,MIMX)=ZMX
KSA=IABS(K(IS,2))
KMA=IABS(K(IM,2))
IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
C...Gluon reconstructs to quark.
C...Decide whether newly created quark is valence or sea:
MINT(30)=JS
CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
IF(MINT(51).NE.0) RETURN
ENDIF
IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
C...Quark reconstructs to gluon.
C...Now some guy may have lost his companion. Check.
ICMP=IMI(JS,MI,2)
IF (ICMP.GT.0) THEN
CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
& //' away. Cannot handle that yet. Giving up.')
MINT(51)=1
RETURN
ELSEIF(ICMP.LT.0) THEN
C...A sea quark with companion still in BR was reconstructed to a gluon.
C...Companion should now be removed from the beam remnant.
C...(Momentum integral is automatically updated in next call to PYPDFU.)
ICMP=-ICMP
IFL=-K(IS,2)
DO 380 JCMP=ICMP,NVC(JS,IFL)-1
XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
DO 370 JI=1,MINT(31)
KMI=-IMI(JS,JI,2)
JFL=-K(IMI(JS,JI,1),2)
IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
& ,2)+1
370 CONTINUE
380 CONTINUE
NVC(JS,IFL)=NVC(JS,IFL)-1
ENDIF
C...Set gluon IMI(JS,MI,2) = 0.
IMI(JS,MI,2)=0
ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
C...Quark reconstructing to quark. If sea with companion still in BR
C...then update associated x value.
C...(Momentum integral is automatically updated in next call to PYPDFU.)
IF (IMI(JS,MI,2).LT.0) THEN
ICMP=-IMI(JS,MI,2)
IFL=-K(IS,2)
XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
ENDIF
ENDIF
ENDIF
C...If reached this point, normal exit.
390 IFAIL=0
RETURN
END
C*********************************************************************
C...PYMEMX
C...Generates maximum ME weight in some initial-state showers.
C...Inparameter MECOR: kind of hard scattering process
C...Outparameter WTFF: maximum weight for fermion -> fermion
C... WTGF: maximum weight for gluon/photon -> fermion
C... WTFG: maximum weight for fermion -> gluon/photon
C... WTGG: maximum weight for gluon -> gluon
SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
C...Default maximum weight.
WTFF=1D0
WTGF=1D0
WTFG=1D0
WTGG=1D0
C...Select maximum weight by process.
IF(MECOR.EQ.1) THEN
WTFF=1D0
WTGF=3D0
ELSEIF(MECOR.EQ.2) THEN
WTFG=1D0
WTGG=1D0
ENDIF
RETURN
END
C*********************************************************************
C...PYMEWT
C...Calculates actual ME weight in some initial-state showers.
C...Inparameter MECOR: kind of hard scattering process
C... IFLCB: flavour combination of branching,
C... 1 for fermion -> fermion,
C... 2 for gluon/photon -> fermion
C... 3 for fermion -> gluon/photon,
C... 4 for gluon -> gluon
C... Q2: Q2 value of shower branching
C... Z: Z value of branching
C...In+outparameter PHIBR: azimuthal angle of branching
C...Outparameter WTME: actual ME weight
SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
C...Default output.
WTME=1D0
C...Define kinematics of shower branching in Mandelstam variables.
SQM=VINT(44)
SH=SQM/Z
TH=-Q2
UH=Q2-SQM*(1D0-Z)/Z
C...Matrix-element corrections for f + fbar -> s-channel vector boson.
IF(MECOR.EQ.1) THEN
IF(IFLCB.EQ.1) THEN
WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
ELSEIF(IFLCB.EQ.2) THEN
WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
ENDIF
C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
ELSEIF(MECOR.EQ.2) THEN
IF(IFLCB.EQ.3) THEN
WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
ELSEIF(IFLCB.EQ.4) THEN
WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
ENDIF
C...Matrix-element corrections for q + qbar -> Higgs (h0)
ELSEIF(MECOR.EQ.3) THEN
IF(IFLCB.EQ.2) THEN
WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
1 (SH**2+2D0*SQM*(SQM-SH))
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYPTMI
C...Handles the generation of additional interactions in the new
C...multiple interactions framework.
C...MODE=-1 : Initalize MI from scratch.
C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
C... Sudakov for PT2, abort if below PT2CUT.
C...MODE= 1 : Accept interaction at PT2NOW and store variables.
C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
C...PT2NOW : Starting (max) PT2 scale for evolution.
C...PT2CUT : Lower limit for evolution.
C...PT2 : Result of evolution. Generated PT2 for trial interaction.
C...IFAIL : Status return code.
C... = 0: All is well.
C... < 0: Phase space exhausted, generation to be terminated.
C... > 0: Additional interaction vetoed, but continue evolution.
SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
& PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
COMMON/PYCTAG/NCT,MCT(4000,2)
C...Local arrays and saved variables.
DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
& /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
& /PYISMX/,/PYCTAG/
SAVE NCHN,XT2FAC,SIGS
IFAIL=0
C...Set MI subprocess = QCD 2 -> 2.
ISUB=96
C----------------------------------------------------------------------
C...MODE=-1: Initialize from scratch
IF (MODE.EQ.-1) THEN
C...Initialize PT2 array.
PT2MI(1)=VINT(54)
C...Initialize list of incoming beams and partons from two sides.
DO 110 JS=1,2
DO 100 MI=1,240
IMI(JS,MI,1)=0
IMI(JS,MI,2)=0
100 CONTINUE
NMI(JS)=1
IMI(JS,1,1)=MINT(84)+JS
IMI(JS,1,2)=0
XMI(JS,1)=VINT(40+JS)
C...Rescale x values to fractions of photon energy.
IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
C...Hard reset: hard interaction initiators motherless by definition.
K(MINT(84)+JS,3)=2+JS
K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
110 CONTINUE
IMISEP(0)=MINT(84)
IMISEP(1)=N
IF (MOD(MSTP(81),10).GE.1) THEN
IF(MSTP(82).LE.1) THEN
SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
& ,5))
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
& VINT(317)/(VINT(318)*VINT(320))
XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
ELSE
XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
& MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
ENDIF
ENDIF
C...Zero entries relating to scatterings beyond the first.
DO 120 MI=2,240
IMI(1,MI,1)=0
IMI(2,MI,1)=0
IMI(1,MI,2)=0
IMI(2,MI,2)=0
IMISEP(MI)=IMISEP(1)
PT2MI(MI)=0D0
XMI(1,MI)=0D0
XMI(2,MI)=0D0
120 CONTINUE
C...Initialize factors for PDF reshaping.
DO 140 JS=1,2
KFBEAM(JS)=MINT(10+JS)
IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
KFABM=IABS(KFBEAM(JS))
KFSBM=ISIGN(1,KFBEAM(JS))
C...Zero flavour content of incoming beam particle.
KFIVAL(JS,1)=0
KFIVAL(JS,2)=0
KFIVAL(JS,3)=0
C... Flavour content of baryon.
IF(KFABM.GT.1000) THEN
KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
C... Flavour content of pi+-, K+-.
ELSEIF(KFABM.EQ.211) THEN
KFIVAL(JS,1)=KFSBM*2
KFIVAL(JS,2)=-KFSBM
ELSEIF(KFABM.EQ.321) THEN
KFIVAL(JS,1)=-KFSBM*3
KFIVAL(JS,2)=KFSBM*2
C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
ENDIF
C...Zero initial valence and companion content.
DO 130 IFL=-6,6
NVC(JS,IFL)=0
130 CONTINUE
140 CONTINUE
C...Set up colour line tags starting from hard interaction initiators.
NCT=0
C...Reset colour tag array and colour processing flags.
DO 150 I=IMISEP(0)+1,N
MCT(I,1)=0
MCT(I,2)=0
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
150 CONTINUE
C... Consider each side in turn.
DO 170 JS=1,2
I1=IMI(JS,1,1)
I2=IMI(3-JS,1,1)
DO 160 JCS=4,5
IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
& GOTO 160
IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
KCS=JCS
CALL PYCTTR(I1,KCS,I2)
IF(MINT(51).NE.0) RETURN
160 CONTINUE
170 CONTINUE
C...Range checking for companion quark pdf large-x param.
IF (MSTP(87).LT.0) THEN
CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
& ' MSTP(87)=0')
MSTP(87)=0
ELSEIF (MSTP(87).GT.4) THEN
CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
& ' MSTP(87)=4')
MSTP(87)=4
ENDIF
C----------------------------------------------------------------------
C...MODE=0: Generate trial interaction. Return codes:
C...IFAIL < 0: Phase space exhausted, generation to be terminated.
C...IFAIL = 0: Additional interaction generated at PT2.
C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
ELSEIF (MODE.EQ.0) THEN
C...Abolute MI max scale = VINT(62)
XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
180 IF(MSTP(82).LE.1) THEN
XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
IF(XT2.LT.VINT(149)) IFAIL=-2
ELSE
IF(XT2.LE.0.01001D0*VINT(149)) THEN
IFAIL=-3
ELSE
XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
& LOG(PYR(0)))-VINT(149)
ENDIF
ENDIF
C...Also exit if below lower limit or if higher trial branching
C...already found.
PT2=0.25D0*VINT(2)*XT2
IF (PT2.LE.PT2CUT) IFAIL=-4
IF (PT2.LE.PT2MX) IFAIL=-5
IF (IFAIL.NE.0) THEN
PT2=0D0
RETURN
ENDIF
IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
VINT(25)=4D0*PT2/VINT(2)
XT2=VINT(25)
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
C...New: require shat > 1.
IF(TAU*VINT(2).LT.1D0) GOTO 180
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
C...Check that x not used up. Accept or reject kinematical variables.
X1M=SQRT(TAU)*EXP(VINT(22))
X2M=SQRT(TAU)*EXP(-VINT(22))
IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
NCHN=0
CALL PYSIGH(NCHN,SIGS)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
C...Save if highest PT so far.
IF (PT2.GT.PT2MX) THEN
JSMX=0
MIMX=MINT(31)+1
PT2MX=PT2
ENDIF
C----------------------------------------------------------------------
C...MODE=1: Generate and save accepted scattering.
ELSEIF (MODE.EQ.1) THEN
PT2=PT2NOW
C...Reset K, P, V, and MCT vectors.
DO 200 I=N+1,N+4
DO 190 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
190 CONTINUE
MCT(I,1)=0
MCT(I,2)=0
200 CONTINUE
NTRY=0
C...Choose flavour of reacting partons (and subprocess).
210 NTRY=NTRY+1
IF (NTRY.GT.50) THEN
CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
& //'interaction. Giving up!')
MINT(51)=1
RETURN
ENDIF
RSIGS=SIGS*PYR(0)
DO 220 ICHN=1,NCHN
KFL1=ISIG(ICHN,1)
KFL2=ISIG(ICHN,2)
ICONMI=ISIG(ICHN,3)
RSIGS=RSIGS-SIGH(ICHN)
IF(RSIGS.LE.0D0) GOTO 230
220 CONTINUE
C...Reassign to appropriate process codes.
230 ISUBMI=ICONMI/10
ICONMI=MOD(ICONMI,10)
C...Choose new quark flavour for annihilation graphs
IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
SH=VINT(21)*VINT(2)
CALL PYWIDT(21,SH,WDTP,WDTE)
240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
DO 250 I=1,MDCY(21,3)
KFLF=KFDP(I+MDCY(21,2)-1,1)
RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
IF(RKFL.LE.0D0) GOTO 260
250 CONTINUE
260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
IF(KFLF.GE.4) GOTO 240
ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
KFLF=4
ICONMI=ICONMI-2
ELSEIF(ISUBMI.EQ.53) THEN
KFLF=5
ICONMI=ICONMI-4
ENDIF
ENDIF
C...Final state flavours and colour flow: default values
JS=1
KFL3=KFL1
KFL4=KFL2
KCC=20
KCS=ISIGN(1,KFL1)
IF(ISUBMI.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
KCC=ICONMI
IF(KFL1*KFL2.LT.0) KCC=KCC+2
ELSEIF(ISUBMI.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
KFL3=ISIGN(KFLF,KFL1)
KFL4=-KFL3
KCC=4
ELSEIF(ISUBMI.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
KFL3=21
KFL4=21
KCC=ICONMI+4
ELSEIF(ISUBMI.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
IF(KFL1.EQ.21) JS=2
KCC=ICONMI+6
IF(KFL1.EQ.21) KCC=KCC+2
IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
ELSEIF(ISUBMI.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
KFL3=ISIGN(KFLF,KCS)
KFL4=-KFL3
KCC=ICONMI+10
ELSEIF(ISUBMI.EQ.68) THEN
C...g + g -> g + g; th arbitrary
KCC=ICONMI+12
KCS=(-1)**INT(1.5D0+PYR(0))
ENDIF
C...Check that massive sea quarks have non-zero phase space for g -> Q Q
IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
& .OR.IABS(KFL4).EQ.5) THEN
RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
IF (PT2.LE.1.05*RMMAX2) THEN
IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
& //' too close to threshold (2nd try).')
GOTO 210
ENDIF
ENDIF
C...Store flavours of scattering.
MINT(13)=KFL1
MINT(14)=KFL2
MINT(15)=KFL1
MINT(16)=KFL2
MINT(21)=KFL3
MINT(22)=KFL4
C...Set flavours and mothers of scattering partons.
K(N+1,1)=14
K(N+2,1)=14
K(N+3,1)=3
K(N+4,1)=3
K(N+1,2)=KFL1
K(N+2,2)=KFL2
K(N+3,2)=KFL3
K(N+4,2)=KFL4
K(N+1,3)=MINT(83)+1
K(N+2,3)=MINT(83)+2
K(N+3,3)=N+1
K(N+4,3)=N+2
C...Store colour connection indices.
DO 270 J=1,2
JC=J
IF(KCS.EQ.-1) JC=3-J
IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
270 CONTINUE
C...Store incoming and outgoing partons in their CM-frame.
SHR=SQRT(VINT(21))*VINT(1)
P(N+1,3)=0.5D0*SHR
P(N+1,4)=0.5D0*SHR
P(N+2,3)=-0.5D0*SHR
P(N+2,4)=0.5D0*SHR
P(N+3,5)=PYMASS(K(N+3,2))
P(N+4,5)=PYMASS(K(N+4,2))
IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
IFAIL=1
RETURN
ENDIF
P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
P(N+4,4)=SHR-P(N+3,4)
P(N+4,3)=-P(N+3,3)
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
PHI=PARU(2)*PYR(0)
CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
C...Global statistics.
MINT(351)=MINT(351)+1
VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
C...Keep track of loose colour ends and information on scattering.
MINT(31)=MINT(31)+1
MINT(36)=MINT(31)
PT2MI(MINT(36))=PT2
IMISEP(MINT(31))=N+4
DO 280 JS=1,2
IMI(JS,MINT(31),1)=N+JS
IMI(JS,MINT(31),2)=0
XMI(JS,MINT(31))=VINT(40+JS)
NMI(JS)=NMI(JS)+1
C...Update cumulative counters
VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
280 CONTINUE
C...Add to list of final state partons
IPART(NPART+1)=N+3
IPART(NPART+2)=N+4
PTPART(NPART+1)=SQRT(PT2)
PTPART(NPART+2)=SQRT(PT2)
NPART=NPART+2
C...Initialize ISR
NISGEN(1,MINT(31))=0
NISGEN(2,MINT(31))=0
C...Update ER
N=N+4
IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
MINT(51)=1
RETURN
ENDIF
C...Finally, assign colour tags to new partons
DO 300 JS=1,2
I1=IMI(JS,MINT(31),1)
I2=IMI(3-JS,MINT(31),1)
DO 290 JCS=4,5
IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
& GOTO 290
IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
KCS=JCS
CALL PYCTTR(I1,KCS,I2)
IF(MINT(51).NE.0) RETURN
290 CONTINUE
300 CONTINUE
C----------------------------------------------------------------------
C...MODE=2: Decide whether quarks in last scattering were valence,
C...companion, or sea.
ELSEIF (MODE.EQ.2) THEN
JS=MINT(30)
MI=MINT(36)
PT2=PT2NOW
KFSBM=ISIGN(1,MINT(10+JS))
IFL=K(IMI(JS,MI,1),2)
IMI(JS,MI,2)=0
IF (IABS(IFL).GE.6) THEN
IF (IABS(IFL).EQ.6) THEN
CALL PYERRM(29,'(PYPTMI:) top in initial state!')
ENDIF
RETURN
ENDIF
C...Get PDFs at X(rescaled) and PT2 of the current initiator.
C...(Do not include the parton itself in the X rescaling.)
X=XMI(JS,MI)
XRSC=X/(VINT(142+JS)+X)
C...Note: XPSVC = x*pdf.
MINT(30)=JS
CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
SEA=XPSVC(IFL,-1)
VAL=XPSVC(IFL,0)
C...Ensure that pdfs are positive definite
IF (SEA.LT.0D0) THEN
CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
SEA=MAX(0D0,SEA)
ELSEIF (VAL.LT.0D0) THEN
CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
VAL=MAX(0D0,VAL)
ENDIF
CMP=0D0
DO 310 IVC=1,NVC(JS,IFL)
CMP=CMP+XPSVC(IFL,IVC)
310 CONTINUE
NTRY=0
C...Decide (Extra factor x cancels in the dvision).
320 RVCS=PYR(0)*(SEA+VAL+CMP)
IVNOW=1
NTRY=NTRY+1
330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
IVNOW=0
IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
& (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
ELSE
C...Count down valence remaining. Do not count current scattering.
DO 340 I1=1,NMI(JS)
IF (I1.EQ.MINT(36)) GOTO 340
IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
& IVNOW=IVNOW-1
340 CONTINUE
ENDIF
IF(IVNOW.EQ.0) GOTO 330
C...Mark valence.
IMI(JS,MI,2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
KFIVAL(JS,1)=IFL
KFIVAL(JS,2)=-IFL
ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
KFIVAL(JS,1)=IFL
IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
ENDIF
ENDIF
ELSEIF (RVCS.LE.VAL+SEA) THEN
C...If sea, add opposite sign companion parton. Store X and I.
NVC(JS,-IFL)=NVC(JS,-IFL)+1
XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
C...Set pointer to companion
IMI(JS,MI,2)=-NVC(JS,-IFL)
ELSE
C...If companion, check whether we've got any in the books
IF (NVC(JS,IFL).EQ.0) THEN
CMP=0D0
C...Only report error first time for this event
IF (NTRY.EQ.1)
& CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
C...Try a few times
IF (NTRY.LE.10) THEN
GOTO 320
C... But if it stil fails, abort this event
ELSE
MINT(51)=1
RETURN
ENDIF
ENDIF
C...If several possibilities, decide which one
CMPSUM=VAL+SEA
ISEL=0
350 ISEL=ISEL+1
CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
C...Find original sea (anti-)quark. Do not consider current scattering.
IASSOC=0
DO 360 I1=1,NMI(JS)
IF (I1.EQ.MINT(36)) GOTO 360
IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
IF (-IMI(JS,I1,2).EQ.ISEL) THEN
IMI(JS,MI,2)=IMI(JS,I1,1)
IMI(JS,I1,2)=IMI(JS,MI,1)
ENDIF
360 CONTINUE
C...Mark companion "out-kicked".
XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
C...Giving the x*f pdf of a companion quark, with its partner at XS,
C...using an approximate gluon density like (1-X)^NPOW/X. The value
C...corresponds to an unrescaled range between 0 and 1-X.
FUNCTION PYFCMP(XC,XS,NPOW)
IMPLICIT NONE
DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
INTEGER NPOW
PYFCMP=0D0
C...Parent gluon momentum fraction
Y=XC+XS
IF (Y.GE.1D0) RETURN
C...Common factor (includes factor XC, since PYFCMP=x*f)
FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
C...Store normalized companion x*f distribution.
IF (NPOW.LE.0) THEN
PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
ELSEIF (NPOW.EQ.1) THEN
PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
ELSEIF (NPOW.EQ.2) THEN
PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
& +3D0*XS*(1D0+XS)*LOG(XS)))
ELSEIF (NPOW.EQ.3) THEN
PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
& +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
ELSEIF (NPOW.GE.4) THEN
PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
& XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
ENDIF
RETURN
END
C*********************************************************************
C...PYPCMP: Auxiliary to PYPDFU.
C...Giving the momentum integral of a companion quark, with its
C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
C...The value corresponds to an unrescaled range between 0 and 1-XS.
FUNCTION PYPCMP(XS,NPOW)
IMPLICIT NONE
DOUBLE PRECISION XS, PYPCMP
INTEGER NPOW
IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
PYPCMP=0D0
ELSEIF (NPOW.LE.0) THEN
PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
ELSEIF (NPOW.EQ.1) THEN
PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
& /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
ELSEIF (NPOW.EQ.2) THEN
PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
& +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
& -3D0*XS*LOG(XS)*(1+XS)))
ELSEIF (NPOW.EQ.3) THEN
PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
& -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
& +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
ELSE
PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
& *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
& -6D0*XS*LOG(XS)*(1D0+XS)))
ENDIF
RETURN
END
C*********************************************************************
C...PYUPRE
C...Rearranges contents of the HEPEUP commonblock so that
C...mothers precede daughters and daughters of a decay are
C...listed consecutively.
SUBROUTINE PYUPRE
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...User process event common block.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Local arrays.
DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
&MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
&VTIUPT(MAXNUP),SPIUPT(MAXNUP)
C...Check whether a rearrangement is required.
NEED=0
DO 100 IUP=1,NUP
IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
100 CONTINUE
DO 110 IUP=2,NUP
IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
110 CONTINUE
IF(NEED.NE.0) THEN
C...Find the new order that particles should have.
NEWPOS(0)=0
NNEW=0
INEW=-1
120 INEW=INEW+1
DO 130 IUP=1,NUP
IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
NNEW=NNEW+1
NEWPOS(NNEW)=IUP
ENDIF
130 CONTINUE
IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
IF(NNEW.NE.NUP) THEN
CALL PYERRM(2,
& '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
RETURN
ENDIF
C...Copy old info into temporary storage.
DO 150 I=1,NUP
IDUPT(I)=IDUP(I)
ISTUPT(I)=ISTUP(I)
MOTUPT(1,I)=MOTHUP(1,I)
MOTUPT(2,I)=MOTHUP(2,I)
ICOUPT(1,I)=ICOLUP(1,I)
ICOUPT(2,I)=ICOLUP(2,I)
DO 140 J=1,5
PUPT(J,I)=PUP(J,I)
140 CONTINUE
VTIUPT(I)=VTIMUP(I)
SPIUPT(I)=SPINUP(I)
150 CONTINUE
C...Copy info back into HEPEUP in right order.
DO 180 I=1,NUP
IOLD=NEWPOS(I)
IDUP(I)=IDUPT(IOLD)
ISTUP(I)=ISTUPT(IOLD)
MOTHUP(1,I)=0
MOTHUP(2,I)=0
DO 160 IMOT=1,I-1
IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
160 CONTINUE
IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
MOTHSW=MOTHUP(1,I)
MOTHUP(1,I)=MOTHUP(2,I)
MOTHUP(2,I)=MOTHSW
ENDIF
ICOLUP(1,I)=ICOUPT(1,IOLD)
ICOLUP(2,I)=ICOUPT(2,IOLD)
DO 170 J=1,5
PUP(J,I)=PUPT(J,IOLD)
170 CONTINUE
VTIMUP(I)=VTIUPT(IOLD)
SPINUP(I)=SPIUPT(IOLD)
180 CONTINUE
ENDIF
c...If incoming particles are massive recalculate to put them massless.
IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
PUP(4,1)=0.5D0*PPLUS
PUP(3,1)=PUP(4,1)
PUP(5,1)=0D0
PUP(4,2)=0.5D0*PMINUS
PUP(3,2)=-PUP(4,2)
PUP(5,2)=0D0
ENDIF
RETURN
END
C*********************************************************************
C...PYADSH
C...Administers the generation of successive final-state showers
C...in external processes.
SUBROUTINE PYADSH(NFIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
C...Local array.
DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
C...Set primary vertex.
DO 100 J=1,5
V(MINT(83)+5,J)=0D0
V(MINT(83)+6,J)=0D0
V(MINT(84)+1,J)=0D0
V(MINT(84)+2,J)=0D0
100 CONTINUE
C...Isolate systems of particles with the same mother.
NSYS=0
IMS=-1
DO 140 I=MINT(84)+3,NFIN
IM=K(I,3)
IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
IF(IM.NE.IMS) THEN
NSYS=NSYS+1
IBEG(NSYS)=I
IMS=IM
ENDIF
C...Set production vertices.
IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
& THEN
DO 110 J=1,4
V(I,J)=0D0
110 CONTINUE
ELSE
DO 120 J=1,4
V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
120 CONTINUE
ENDIF
IF(MSTP(125).GE.1) THEN
IDOC=I-MSTP(126)+4
DO 130 J=1,5
V(IDOC,J)=V(I,J)
130 CONTINUE
ENDIF
140 CONTINUE
C...End loop over systems. Return if no showers to be performed.
IBEG(NSYS+1)=NFIN+1
IF(MSTP(71).LE.0) RETURN
C...Loop through systems of particles; check that sensible size.
DO 270 ISYS=1,NSYS
NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
IF(MINT(35).LE.2) THEN
IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
GOTO 270
ELSEIF(NSIZ.LE.1) THEN
CALL PYERRM(2,'(PYADSH:) only one particle in system')
GOTO 270
ELSEIF(NSIZ.GT.80) THEN
CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
GOTO 270
ENDIF
ENDIF
C...Save status codes and daughters of showering particles; reset them.
DO 150 J=1,4
PSUM(J)=0D0
150 CONTINUE
DO 170 II=1,NSIZ
I=IBEG(ISYS)-1+II
KSAV(II,1)=K(I,1)
IF(K(I,1).GT.10) THEN
K(I,1)=1
IF(KSAV(II,1).EQ.14) K(I,1)=3
ENDIF
IF(KSAV(II,1).LE.10) THEN
ELSEIF(K(I,1).EQ.1) THEN
KSAV(II,4)=K(I,4)
KSAV(II,5)=K(I,5)
K(I,4)=0
K(I,5)=0
ELSE
KSAV(II,4)=MOD(K(I,4),MSTU(5))
KSAV(II,5)=MOD(K(I,5),MSTU(5))
K(I,4)=K(I,4)-KSAV(II,4)
K(I,5)=K(I,5)-KSAV(II,5)
ENDIF
DO 160 J=1,4
PSUM(J)=PSUM(J)+P(I,J)
160 CONTINUE
170 CONTINUE
C...Perform shower.
QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
& PSUM(3)**2))
IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
NSAV=N
IF(MINT(35).LE.2) THEN
IF(NSIZ.EQ.2) THEN
CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
ELSE
CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
ENDIF
C...For external processes, first call, also ISR partons radiate.
C...Can use existing PYPART list, removing partons that radiate later.
ELSEIF(ISYS.EQ.1) THEN
NPARTN=0
DO 175 II=1,NPART
IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
NPARTN=NPARTN+1
IPART(NPARTN)=IPART(II)
PTPART(NPARTN)=PTPART(II)
ENDIF
175 CONTINUE
NPART=NPARTN
CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
ELSE
C...For subsequent calls use the systems excluded above.
NPART=NSIZ
NPARTD=0
DO 180 II=1,NSIZ
I=IBEG(ISYS)-1+II
IPART(II)=I
PTPART(II)=0.5D0*QMAX
180 CONTINUE
CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
ENDIF
C...Look up showered copies of original showering particles.
DO 260 II=1,NSIZ
I=IBEG(ISYS)-1+II
IMV=I
C...Particles without daughters need not be studied.
IF(KSAV(II,1).LE.10) GOTO 260
IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
ELSEIF(K(I,1).EQ.11) THEN
190 IMV=MOD(K(IMV,4),MSTU(5))
IF(K(IMV,1).EQ.11) GOTO 190
ELSE
KDA1=MOD(K(I,4),MSTU(5))
IF(KDA1.GT.0) THEN
IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
ENDIF
KDA2=MOD(K(I,5),MSTU(5))
IF(KDA2.GT.0) THEN
IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
ENDIF
DO 200 I3=I+1,N
IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
& THEN
IMV=I3
KDA1=MOD(K(I3,4),MSTU(5))
IF(KDA1.GT.0) THEN
IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
ENDIF
KDA2=MOD(K(I3,5),MSTU(5))
IF(KDA2.GT.0) THEN
IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
ENDIF
ENDIF
200 CONTINUE
ENDIF
C...Restore daughter info of original partons to showered copies.
IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
IF(KSAV(II,1).LE.10) THEN
ELSEIF(K(I,1).EQ.1) THEN
K(IMV,4)=KSAV(II,4)
K(IMV,5)=KSAV(II,5)
ELSE
K(IMV,4)=K(IMV,4)+KSAV(II,4)
K(IMV,5)=K(IMV,5)+KSAV(II,5)
ENDIF
C...Reset mother info of existing daughters to showered copies.
DO 210 I3=IBEG(ISYS+1),NFIN
IF(K(I3,3).EQ.I) K(I3,3)=IMV
IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
ENDIF
210 CONTINUE
C...Boost all original daughters to new frame of showered copy.
C...Also update their colour tags.
IF(IMV.NE.I) THEN
DO 220 J=1,3
BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
220 CONTINUE
FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
DO 230 J=1,3
BETA(J)=FAC*BETA(J)
230 CONTINUE
DO 250 I3=IBEG(ISYS+1),NFIN
IMO=I3
240 IMO=K(IMO,3)
IF(MSTP(128).LE.0) THEN
IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
& THEN
CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
ENDIF
ELSE
IF(IMO.EQ.IMV) THEN
CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
GOTO 240
ENDIF
ENDIF
250 CONTINUE
ENDIF
260 CONTINUE
C...End of loop over showering systems
270 CONTINUE
RETURN
END
C*********************************************************************
C...PYVETO
C...Interface to UPVETO, which allows user to veto event generation
C...on the parton level, after parton showers but before multiple
C...interactions, beam remnants and hadronization is added.
SUBROUTINE PYVETO(IVETO)
C...All real arithmetic in double precision.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
C...Three Pythia functions return integers, so need declaring.
INTEGER PYK,PYCHGE,PYCOMP
C...PYTHIA commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYPARS/,/PYINT1/
C...HEPEVT commonblock.
PARAMETER (NMXHEP=4000)
COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
&JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
DOUBLE PRECISION PHEP,VHEP
SAVE /HEPEVT/
C...Local array.
DIMENSION IRESO(100)
C...Define longitudinal boost from initiator rest frame to cm frame.
GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
C...Presentation is different if using pT-ordered shower
IF(MINT(35).EQ.3) THEN
GAMMA=1D0
GABEZ=0D0
ENDIF
C... Reset counters.
NEVHEP=0
NHEP=0
NRESO=0
C...Oth pass: identify beam and incoming partons
DO 140 I=MINT(83)+1,MINT(83)+6
ISTORE=0
IF(K(I,2).EQ.94) THEN
ELSE
NRESO=NRESO+1
IRESO(NRESO)=I
IMOTH=K(I,3)
ENDIF
140 CONTINUE
C...First pass: identify final locations of resonances
C...and of their daughters before showering.
DO 150 I=MINT(84)+3,N
ISTORE=0
IMOTH=0
C...Skip shower CM frame documentation lines.
IF(K(I,2).EQ.94) THEN
C... Store a new intermediate product, when mother in documentation.
ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
& K(I,3).LE.MINT(84)) THEN
ISTORE=1
NHEP=NHEP+1
II=NHEP
NRESO=NRESO+1
IRESO(NRESO)=I
IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
C... Store a new intermediate product, when mother in main section.
ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
& K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
ISTORE=1
NHEP=NHEP+1
II=NHEP
NRESO=NRESO+1
IRESO(NRESO)=I
IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
ENDIF
IF(ISTORE.EQ.1) THEN
C...Copy parton info, boosting momenta along z axis to cm frame.
ISTHEP(II)=2
IDHEP(II)=K(I,2)
PHEP(1,II)=P(I,1)
PHEP(2,II)=P(I,2)
PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
PHEP(5,II)=P(I,5)
C...Store one mother. Rest of history and vertex info zeroed.
JMOHEP(1,II)=IMOTH
JMOHEP(2,II)=0
JDAHEP(1,II)=0
JDAHEP(2,II)=0
VHEP(1,II)=0D0
VHEP(2,II)=0D0
VHEP(3,II)=0D0
VHEP(4,II)=0D0
ENDIF
150 CONTINUE
C...Second pass: identify current set of "final" partons.
DO 200 I=MINT(84)+3,N
ISTORE=0
IMOTH=0
C...Store a final parton.
IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
ISTORE=1
NHEP=NHEP+1
II=NHEP
C..Trace it back through shower, to check if from documented particle.
IHIST=I
ISAVE=IHIST
160 CONTINUE
IF(IHIST.GT.MINT(84)) THEN
IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
DO 170 IRI=1,NRESO
IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
170 CONTINUE
ISAVE=IHIST
IHIST=K(IHIST,3)
IF(IMOTH.EQ.0) GOTO 160
IMOTH=MAX(0,IMOTH-6)
ELSEIF(IHIST.LE.4) THEN
IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
ISTORE=0
NHEP=NHEP-1
ELSE
IMOTH=0
ENDIF
ENDIF
ENDIF
IF(ISTORE.EQ.1) THEN
C...Copy parton info, boosting momenta along z axis to cm frame.
ISTHEP(II)=1
IDHEP(II)=K(I,2)
PHEP(1,II)=P(I,1)
PHEP(2,II)=P(I,2)
PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
PHEP(5,II)=P(I,5)
C...Store one mother. Rest of history and vertex info zeroed.
JMOHEP(1,II)=IMOTH
JMOHEP(2,II)=0
JDAHEP(1,II)=0
JDAHEP(2,II)=0
VHEP(1,II)=0D0
VHEP(2,II)=0D0
VHEP(3,II)=0D0
VHEP(4,II)=0D0
ENDIF
200 CONTINUE
C...Call user-written routine to decide whether to keep events.
CALL UPVETO(IVETO)
RETURN
END
C*********************************************************************
C...PYRESD
C...Allows resonances to decay (including parton showers for hadronic
C...channels).
SUBROUTINE PYRESD(IRES)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Parameter statement for maximum size of showers.
PARAMETER (MAXNUR=1000)
C...Commonblocks.
COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYCTAG/NCT,MCT(4000,2)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
&/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
C...Local arrays and complex and character variables.
DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
&KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6),
&HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
&PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4),
&ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
&KFL4(3)
COMPLEX FGK,HA(6,6),HC(6,6)
REAL TIR,UIR
CHARACTER CODE*9,MASS*9
C...Local arrays.
DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
C...Functions: momentum in two-particle decays and four-product.
PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
C...The F, Xi and Xj functions of Gunion and Kunszt
C...(Phys. Rev. D33, 665, plus errata from the authors).
FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
&HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
&(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
&2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
&2D0*(D34/D56+D56/D34))
C...Some general constants.
XW=PARU(102)
XWV=XW
IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
XW1=1D0-XW
SQMZ=PMAS(23,1)**2
GMMZ=PMAS(23,1)*PMAS(23,2)
SQMW=PMAS(24,1)**2
GMMW=PMAS(24,1)*PMAS(24,2)
SH=VINT(44)
C...Boost and rotate to rest frame of incoming partons,
C...to get proper amount of smearing of decay angles.
IBST=0
IF(IRES.EQ.0) THEN
IBST=1
IIN1=MINT(84)+1
IIN2=MINT(84)+2
C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
C...(101,102) are off shell and can have inconsistent momenta, resulting
C...in boosts larger than unity. However, the corresponding docu partons
C...(5,6) are kept on shell, and have consistent momenta that can be used
C...to derive this boost instead. Ultimately, should change the way the new
C...shower stores intermediate partons, but just using partons (5,6) for now
C...does define the boost and furnishes a quick and much needed solution.
IF (MINT(35).EQ.3) THEN
IIN1=MINT(83)+5
IIN2=MINT(83)+6
ENDIF
ETOTIN=P(IIN1,4)+P(IIN2,4)
BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
ENDIF
C...Reset original resonance configuration.
DO 100 JT=1,8
IREF(1,JT)=0
100 CONTINUE
C...Define initial one, two or three objects for subprocess.
IHDEC=0
IF(IRES.EQ.0) THEN
ISUB=MINT(1)
IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
IREF(1,1)=MINT(84)+2+ISET(ISUB)
IREF(1,4)=MINT(83)+6+ISET(ISUB)
JTMAX=1
ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
IREF(1,1)=MINT(84)+1+ISET(ISUB)
IREF(1,2)=MINT(84)+2+ISET(ISUB)
IREF(1,4)=MINT(83)+5+ISET(ISUB)
IREF(1,5)=MINT(83)+6+ISET(ISUB)
JTMAX=2
ELSEIF(ISET(ISUB).EQ.5) THEN
IREF(1,1)=MINT(84)+3
IREF(1,2)=MINT(84)+4
IREF(1,3)=MINT(84)+5
IREF(1,4)=MINT(83)+7
IREF(1,5)=MINT(83)+8
IREF(1,6)=MINT(83)+9
JTMAX=3
ENDIF
C...Define original resonance for odd cases.
ELSE
ISUB=0
IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
& IHDEC=1
IF(IHDEC.EQ.1) ISUB=3
IREF(1,1)=IRES
IREF(1,4)=K(IRES,3)
IRESTM=IRES
IF(IREF(1,4).GT.MINT(84)) THEN
110 ITMPMO=IREF(1,4)
IF(K(ITMPMO,2).EQ.94) THEN
IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
IRESTM=ITMPMO
C...Explicitly check that reference particle exists, otherwise stop recursion
IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
IREF(1,4)=K(ITMPMO,3)
GOTO 110
ENDIF
ENDIF
ENDIF
IF(IREF(1,4).GT.MINT(84)) THEN
EMATCH=1D10
IREF14=IREF(1,4)
DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
& EMATCH) THEN
IREF(1,4)=II
EMATCH=ABS(P(II,4)-P(IREF14,4))
ENDIF
120 CONTINUE
ENDIF
JTMAX=1
ENDIF
C...Check if initial resonance has been moved (in resonance + jet).
DO 140 JT=1,3
IF(IREF(1,JT).GT.0) THEN
IF(K(IREF(1,JT),1).GT.10) THEN
KFA=IABS(K(IREF(1,JT),2))
IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
ENDIF
IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
ENDIF
DO 130 I=IREF(1,JT)+1,N
IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
& I.EQ.KDA2)) THEN
IREF(1,JT)=I
KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
ENDIF
IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
ENDIF
ENDIF
130 CONTINUE
ELSE
KDA=MOD(K(IREF(1,JT),4),MSTU(5))
IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
ENDIF
ENDIF
ENDIF
140 CONTINUE
C...Set decay vertex for initial resonances
DO 160 JT=1,JTMAX
DO 150 I=1,4
V(IREF(1,JT),I)=0D0
150 CONTINUE
160 CONTINUE
C...Loop over decay history.
NP=1
IP=0
170 IP=IP+1
NINH=0
JTMAX=2
IF(IREF(IP,2).EQ.0) JTMAX=1
IF(IREF(IP,3).NE.0) JTMAX=3
IT4=0
NSAV=N
C...Check for Higgs which appears as decay product of user-process.
IF(ISUB.EQ.0) THEN
IHDEC=0
IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
& .EQ.36) IHDEC=1
IF(IHDEC.EQ.1) ISUB=3
ENDIF
C...Start treatment of one, two or three resonances in parallel.
180 N=NSAV
DO 340 JT=1,JTMAX
ID=IREF(IP,JT)
KDCY(JT)=0
KFL1(JT)=0
KFL2(JT)=0
KFL3(JT)=0
KFL4(JT)=0
KEQL(JT)=0
NSD(JT)=ID
ITJUNC(JT)=0
C...Check whether particle can/is allowed to decay.
IF(ID.EQ.0) GOTO 330
KFA=IABS(K(ID,2))
KCA=PYCOMP(KFA)
IF(MWID(KCA).EQ.0) GOTO 330
IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
& KFA.EQ.18) IT4=IT4+1
K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
C...Choose lifetime and determine decay vertex.
IF(K(ID,1).EQ.5) THEN
V(ID,5)=0D0
ELSEIF(K(ID,1).NE.4) THEN
V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
ENDIF
DO 190 J=1,4
VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
190 CONTINUE
C...Determine whether decay allowed or not.
MOUT=0
IF(MSTJ(22).EQ.2) THEN
IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
ELSEIF(MSTJ(22).EQ.3) THEN
IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
ELSEIF(MSTJ(22).EQ.4) THEN
IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
ENDIF
IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
K(ID,1)=4
GOTO 330
ENDIF
C...Info for selection of decay channel: sign, pairings.
IF(KCHG(KCA,3).EQ.0) THEN
IPM=2
ELSE
IPM=(5-ISIGN(1,K(ID,2)))/2
ENDIF
KFB=0
IF(JTMAX.EQ.2) THEN
KFB=IABS(K(IREF(IP,3-JT),2))
ELSEIF(JTMAX.EQ.3) THEN
JT2=JT+1-3*(JT/3)
KFB=IABS(K(IREF(IP,JT2),2))
IF(KFB.NE.KFA) THEN
JT2=JT+2-3*((JT+1)/3)
KFB=IABS(K(IREF(IP,JT2),2))
ENDIF
ENDIF
C...Select decay channel.
IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
& ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
IF(WDTE0S.LE.0D0) GOTO 330
RKFL=WDTE0S*PYR(0)
IDL=0
200 IDL=IDL+1
IDC=IDL+MDCY(KCA,2)-1
RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
NPROD=0
C...Read out flavours and colour charges of decay channel chosen.
KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
IF(KCQM(JT).EQ.-2) KCQM(JT)=2
KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
KFC1A=PYCOMP(IABS(KFL1(JT)))
IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
NPROD=NPROD+1
KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
KFC2A=PYCOMP(IABS(KFL2(JT)))
IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
NPROD=NPROD+1
KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
KCQ3(JT)=0
KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
KCQ4(JT)=0
IF(KFL3(JT).NE.0) THEN
KFC3A=PYCOMP(IABS(KFL3(JT)))
IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
NPROD=NPROD+1
IF(KFL4(JT).NE.0) THEN
KFC4A=PYCOMP(IABS(KFL4(JT)))
IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
NPROD=NPROD+1
ENDIF
ENDIF
C...Set/save further info on channel.
KDCY(JT)=1
IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
NSD(JT)=N
HGZ(JT,1)=VINT(111)
HGZ(JT,2)=VINT(112)
HGZ(JT,3)=VINT(114)
JTZ=JT
PXSUM=0D0
C...Select masses; to begin with assume resonances narrow.
DO 220 I=1,4
P(N+I,5)=0D0
PMMN(I)=0D0
IF(I.EQ.1) THEN
KFLW=IABS(KFL1(JT))
KCW=KFC1A
ELSEIF(I.EQ.2) THEN
KFLW=IABS(KFL2(JT))
KCW=KFC2A
ELSEIF(I.EQ.3) THEN
IF(KFL3(JT).EQ.0) GOTO 220
KFLW=IABS(KFL3(JT))
KCW=KFC3A
ELSEIF(I.EQ.4) THEN
IF(KFL4(JT).EQ.0) GOTO 220
KFLW=IABS(KFL4(JT))
KCW=KFC4A
ENDIF
P(N+I,5)=PMAS(KCW,1)
PXSUM=PXSUM+P(N+I,5)
CMRENNA++
C...This prevents SUSY/t particles from becoming too light.
IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
PMMN(I)=PMAS(KCW,1)
DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
& PMAS(PYCOMP(KFDP(IDC,2)),1)
IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
& PMAS(PYCOMP(KFDP(IDC,3)),1)
IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
& PMAS(PYCOMP(KFDP(IDC,4)),1)
PMMN(I)=MIN(PMMN(I),PMSUM)
ENDIF
210 CONTINUE
C MRENNA--
ELSEIF(KFLW.EQ.6) THEN
PMMN(I)=PMAS(24,1)+PMAS(5,1)
ENDIF
C...UED: select a graviton mass from continuous distribution
C...(stored in PMAS(39,1) so no value returned)
IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
& CALL PYGRAM(1)
220 CONTINUE
C...Check which two out of three are widest.
IWID1=1
IWID2=2
PWID1=PMAS(KFC1A,2)
PWID2=PMAS(KFC2A,2)
KFLW1=IABS(KFL1(JT))
KFLW2=IABS(KFL2(JT))
IF(KFL3(JT).NE.0) THEN
PWID3=PMAS(KFC3A,2)
IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
IWID1=3
PWID1=PWID3
KFLW1=IABS(KFL3(JT))
ELSEIF(PWID3.GT.PWID2) THEN
IWID2=3
PWID2=PWID3
KFLW2=IABS(KFL3(JT))
ENDIF
ENDIF
IF(KFL4(JT).NE.0) THEN
PWID4=PMAS(KFC4A,2)
IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
IWID1=4
PWID1=PWID4
KFLW1=IABS(KFL4(JT))
ELSEIF(PWID4.GT.PWID2) THEN
IWID2=4
PWID2=PWID4
KFLW2=IABS(KFL4(JT))
ENDIF
ENDIF
C...If all narrow then only check that masses consistent.
IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
& PWID2.LT.PARP(41))) THEN
CMRENNA++
C....Handle near degeneracy cases.
IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
ENDIF
ENDIF
CMRENNA--
IF(PXSUM.GT.P(ID,5)) THEN
CALL PYERRM(13,'(PYRESD:) daughter masses too large')
MINT(51)=1
GOTO 720
ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large')
MINT(51)=1
GOTO 720
ENDIF
C...For three wide resonances select narrower of three
C...according to BW decoupled from rest.
ELSE
PMTOT=P(ID,5)
IF(KFL3(JT).NE.0) THEN
IWID3=6-IWID1-IWID2
KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
& KFLW1-KFLW2
LOOP=0
230 LOOP=LOOP+1
P(N+IWID3,5)=PYMASS(KFLW3)
IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
PMTOT=PMTOT-P(N+IWID3,5)
ENDIF
C...Select other two correlated within remaining phase space.
IF(IP.EQ.1) THEN
CKIN45=CKIN(45)
CKIN47=CKIN(47)
CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
& P(N+IWID2,5))
CKIN(45)=CKIN45
CKIN(47)=CKIN47
ELSE
CKIN(49)=PMMN(IWID1)
CKIN(50)=PMMN(IWID2)
CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
& P(N+IWID2,5))
CKIN(49)=0D0
CKIN(50)=0D0
ENDIF
IF(MINT(51).EQ.1) GOTO 720
ENDIF
C...Begin fill decay products, with colour flow for coloured objects.
MSTU10=MSTU(10)
MSTU(10)=1
MSTU(19)=1
C...Three-body decays
IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN
DO 250 I=N+1,N+NPROD
DO 240 J=1,5
K(I,J)=0
V(I,J)=0D0
240 CONTINUE
MCT(I,1)=0
MCT(I,2)=0
250 CONTINUE
K(N+1,1)=1
K(N+1,2)=KFL1(JT)
K(N+2,1)=1
K(N+2,2)=KFL2(JT)
K(N+3,1)=1
K(N+3,2)=KFL3(JT)
IF(KFL4(JT).NE.0) THEN
K(N+4,1)=1
K(N+4,2)=KFL4(JT)
ENDIF
IDIN=ID
C...Generate kinematics (default is flat)
IF(KFL4(JT).EQ.0) THEN
CALL PYTBDY(IDIN)
ELSE
PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
ND=4
PV(1,1)=0D0
PV(1,2)=0D0
PV(1,3)=0D0
PV(1,4)=P(IDIN,5)
PV(1,5)=P(IDIN,5)
C...Calculate maximum weight ND-particle decay.
PV(ND,5)=P(N+ND,5)
WTMAX=1D0/WTCOR(ND-2)
PMAX=PV(1,5)-PS+P(N+ND,5)
PMIN=0D0
DO 381 IL=ND-1,1,-1
PMAX=PMAX+P(N+IL,5)
PMIN=PMIN+P(N+IL+1,5)
WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
381 CONTINUE
C...M-generator gives weight. If rejected, try again.
411 RORD(1)=1D0
DO 441 IL1=2,ND-1
RSAV=PYR(0)
DO 421 IL2=IL1-1,1,-1
IF(RSAV.LE.RORD(IL2)) GOTO 431
RORD(IL2+1)=RORD(IL2)
421 CONTINUE
431 RORD(IL2+1)=RSAV
441 CONTINUE
RORD(ND)=0D0
WT=1D0
DO 451 IL=ND-1,1,-1
PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
& (PV(1,5)-PS)
WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
451 CONTINUE
IF(WT.LT.PYR(0)*WTMAX) GOTO 411
C...Perform two-particle decays in respective CM frame.
DO 481 IL=1,ND-1
PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
UE(3)=2D0*PYR(0)-1D0
PHIX=PARU(2)*PYR(0)
UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
DO 471 J=1,3
P(N+IL,J)=PA*UE(J)
PV(IL+1,J)=-PA*UE(J)
471 CONTINUE
P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
481 CONTINUE
C...Lorentz transform decay products to lab frame.
DO 491 J=1,4
P(N+ND,J)=PV(ND,J)
491 CONTINUE
DO 531 IL=ND-1,1,-1
DO 501 J=1,3
BE(J)=PV(IL,J)/PV(IL,4)
501 CONTINUE
GA=PV(IL,4)/PV(IL,5)
DO 521 I=N+IL,N+ND
BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
DO 511 J=1,3
P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
511 CONTINUE
P(I,4)=GA*(P(I,4)+BEP)
521 CONTINUE
531 CONTINUE
ENDIF
C...Set generic colour flows whenever unambiguous,
C...(independently of the order of the decay products)
C...Sum up total colour content
NANT=0
NTRI=0
NOCT=0
KCQ(0)=KCQM(JT)
KCQ(1)=KCQ1(JT)
KCQ(2)=KCQ2(JT)
KCQ(3)=KCQ3(JT)
KCQ(4)=KCQ4(JT)
DO 255 J=0,NPROD
IF (KCQ(J).EQ.-1) THEN
NANT=NANT+1
IANT(NANT)=N+J
ELSEIF (KCQ(J).EQ.1) THEN
NTRI=NTRI+1
ITRI(NTRI)=N+J
ELSEIF (KCQ(J).EQ.2) THEN
NOCT=NOCT+1
IOCT(NOCT)=N+J
ENDIF
255 CONTINUE
C...Set color flow for generic 1 -> N processes (N arbitrary)
IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
C...All singlets: do nothing
ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
C...Two octets, zero triplets, n singlets:
IF (KCQ(0).EQ.2) THEN
C...8 -> 8 + n(1)
K(ID,4)=K(ID,4)+IOCT(2)
K(ID,5)=K(ID,5)+IOCT(2)
K(IOCT(2),1)=3
K(IOCT(2),4)=MSTU(5)*ID
K(IOCT(2),5)=MSTU(5)*ID
MCT(IOCT(2),1)=MCT(ID,1)
MCT(IOCT(2),2)=MCT(ID,2)
ELSE
C...1 -> 8 + 8 + n(1)
K(IOCT(1),1)=3
K(IOCT(1),4)=MSTU(5)*IOCT(2)
K(IOCT(1),5)=MSTU(5)*IOCT(2)
K(IOCT(2),1)=3
K(IOCT(2),4)=MSTU(5)*IOCT(1)
K(IOCT(2),5)=MSTU(5)*IOCT(1)
NCT=NCT+1
MCT(IOCT(1),1)=NCT
MCT(IOCT(2),2)=NCT
NCT=NCT+1
MCT(IOCT(2),1)=NCT
MCT(IOCT(1),2)=NCT
ENDIF
ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
C...Two triplets, zero octets, n singlets.
IF (KCQ(0).EQ.1) THEN
C...3 -> 3 + n(1)
K(ID,4)=K(ID,4)+ITRI(2)
K(ITRI(2),1)=3
K(ITRI(2),4)=MSTU(5)*ID
MCT(ITRI(2),1)=MCT(ID,1)
ELSEIF (KCQ(0).EQ.-1) THEN
C...3bar -> 3bar + n(1)
K(ID,5)=K(ID,5)+IANT(2)
K(IANT(2),1)=3
K(IANT(2),5)=MSTU(5)*ID
MCT(IANT(2),2)=MCT(ID,2)
ELSE
C...1 -> 3 + 3bar + n(1)
K(ITRI(1),1)=3
K(ITRI(1),4)=MSTU(5)*IANT(1)
K(IANT(1),1)=3
K(IANT(1),5)=MSTU(5)*ITRI(1)
NCT=NCT+1
MCT(ITRI(1),1)=NCT
MCT(IANT(1),2)=NCT
ENDIF
ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
C...Two triplets, one octet, n singlets.
IF (KCQ(0).EQ.2) THEN
C...8 -> 3 + 3bar + n(1)
K(ID,4)=K(ID,4)+ITRI(1)
K(ID,5)=K(ID,5)+IANT(1)
K(ITRI(1),1)=3
K(ITRI(1),4)=MSTU(5)*ID
K(IANT(1),1)=3
K(IANT(1),5)=MSTU(5)*ID
MCT(ITRI(1),1)=MCT(ID,1)
MCT(IANT(1),2)=MCT(ID,2)
ELSEIF (KCQ(0).EQ.1) THEN
C...3 -> 8 + 3 + n(1)
K(ID,4)=K(ID,4)+IOCT(1)
K(IOCT(1),1)=3
K(IOCT(1),4)=MSTU(5)*ID
K(IOCT(1),5)=MSTU(5)*ITRI(2)
K(ITRI(2),1)=3
K(ITRI(2),4)=MSTU(5)*IOCT(1)
MCT(IOCT(1),1)=MCT(ID,1)
NCT=NCT+1
MCT(IOCT(1),2)=NCT
MCT(ITRI(2),1)=NCT
ELSEIF (KCQ(0).EQ.-1) THEN
C...3bar -> 8 + 3bar + n(1)
K(ID,5)=K(ID,5)+IOCT(1)
K(IOCT(1),1)=3
K(IOCT(1),5)=MSTU(5)*ID
K(IOCT(1),4)=MSTU(5)*IANT(2)
K(IANT(2),1)=3
K(IANT(2),5)=MSTU(5)*IOCT(1)
MCT(IOCT(1),2)=MCT(ID,2)
NCT=NCT+1
MCT(IOCT(1),1)=NCT
MCT(IANT(2),2)=NCT
ELSE
C...1 -> 3 + 3bar + 8 + n(1)
K(ITRI(1),1)=3
K(ITRI(1),4)=MSTU(5)*IOCT(1)
K(IOCT(1),1)=3
K(IOCT(1),5)=MSTU(5)*ITRI(1)
K(IOCT(1),4)=MSTU(5)*IANT(1)
K(IANT(1),1)=3
K(IANT(1),5)=MSTU(5)*IOCT(1)
NCT=NCT+1
MCT(ITRI(1),1)=NCT
MCT(IOCT(1),2)=NCT
NCT=NCT+1
MCT(IOCT(1),1)=NCT
MCT(IANT(1),2)=NCT
ENDIF
ELSEIF(NTRI+NANT.EQ.4) THEN
C...
IF (KCQ(0).EQ.1) THEN
C...3 -> 3 + n(1) -> 3 + 3bar
K(ID,4)=K(ID,4)+ITRI(2)
K(ITRI(2),1)=3
K(ITRI(2),4)=MSTU(5)*ID
MCT(ITRI(2),1)=MCT(ID,1)
K(ITRI(3),1)=3
K(ITRI(3),4)=MSTU(5)*IANT(1)
K(IANT(1),1)=3
K(IANT(1),5)=MSTU(5)*ITRI(3)
NCT=NCT+1
MCT(ITRI(3),1)=NCT
MCT(IANT(1),2)=NCT
ELSEIF (KCQ(0).EQ.-1) THEN
C...3bar -> 3bar + n(1) -> 3 + 3bar
K(ID,5)=K(ID,5)+IANT(2)
K(IANT(2),1)=3
K(IANT(2),5)=MSTU(5)*ID
MCT(IANT(2),2)=MCT(ID,2)
K(ITRI(1),1)=3
K(ITRI(1),4)=MSTU(5)*IANT(3)
K(IANT(3),1)=3
K(IANT(3),5)=MSTU(5)*ITRI(1)
NCT=NCT+1
MCT(ITRI(1),1)=NCT
MCT(IANT(3),2)=NCT
ENDIF
ELSEIF(KFL4(JT).NE.0) THEN
CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
CPS-- End of generic cases
C...(could three octets also be handled?)
C...(could (some of) the RPV cases be made generic as well?)
C...Special cases (= old treatment)
C...Set colour flow for t -> W + b + Z.
ELSEIF(KFA.EQ.6) THEN
K(N+2,1)=3
ISID=4
IF(KCQM(JT).EQ.-1) ISID=5
IDAU=N+2
K(ID,ISID)=K(ID,ISID)+IDAU
K(IDAU,ISID)=MSTU(5)*ID
C...Set colour flow in three-body decays - programmed as special cases.
ELSEIF(KFC2A.LE.6) THEN
K(N+2,1)=3
K(N+3,1)=3
ISID=4
IF(KFL2(JT).LT.0) ISID=5
K(N+2,ISID)=MSTU(5)*(N+3)
K(N+3,9-ISID)=MSTU(5)*(N+2)
C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
& .AND.KFL3(JT).NE.0) THEN
KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
C...3-body decays of squarks to colour singlets plus one quark
IF (KQSUMA.EQ.1) THEN
C...Find quark
IQ=0
IF (KCQ1(JT).NE.0) IQ=1
IF (KCQ2(JT).NE.0) IQ=2
IF (KCQ3(JT).NE.0) IQ=3
ISID=4
IF (K(N+IQ,2).LT.0) ISID=5
K(N+IQ,1)=3
K(ID,ISID)=K(ID,ISID)+(N+IQ)
K(N+IQ,ISID)=MSTU(5)*ID
ENDIF
C...PS--
ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
K(N+1,1)=3
K(N+2,1)=3
K(N+3,1)=3
ISID=4
IF(KFL2(JT).LT.0) ISID=5
K(N+1,ISID)=MSTU(5)*(N+2)
K(N+1,9-ISID)=MSTU(5)*(N+3)
K(N+2,ISID)=MSTU(5)*(N+1)
K(N+3,9-ISID)=MSTU(5)*(N+1)
ELSEIF(KFA.EQ.KSUSY1+21) THEN
K(N+2,1)=3
K(N+3,1)=3
ISID=4
IF(KFL2(JT).LT.0) ISID=5
K(ID,ISID)=K(ID,ISID)+(N+2)
K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
K(N+2,ISID)=MSTU(5)*ID
K(N+3,9-ISID)=MSTU(5)*ID
CMRENNA--
ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
& IABS(KCQ2(JT)).EQ.1) THEN
K(N+2,1)=3
K(N+3,1)=3
ISID=4
IF(KFL2(JT).LT.0) ISID=5
K(N+2,ISID)=MSTU(5)*(N+3)
K(N+3,9-ISID)=MSTU(5)*(N+2)
ENDIF
NSAV=N
C...Set colour flow in three-body decays with baryon number violation.
C...Neutralino and chargino decays first.
KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
K(N+4,4)=ITJUNC(JT)*MSTU(5)
C...Insert junction to keep track of colours.
IF(KCQ1(JT).NE.0) K(N+1,1)=3
IF(KCQ2(JT).NE.0) K(N+2,1)=3
IF(KCQ3(JT).NE.0) K(N+3,1)=3
C...Set special junction codes:
K(N+4,1)=42
K(N+4,2)=88
C...Order decay products by invariant mass. (will be used in PYSTRF).
PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)-
& P(N+1,3)*P(N+2,3)
PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)-
& P(N+1,3)*P(N+3,3)
PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)-
& P(N+2,3)*P(N+3,3)
IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
K(N+4,4)=N+3+K(N+4,4)
K(N+4,5)=N+1+MSTU(5)*(N+2)
ELSEIF(PM13.LT.PM23) THEN
K(N+4,4)=N+2+K(N+4,4)
K(N+4,5)=N+1+MSTU(5)*(N+3)
ELSE
K(N+4,4)=N+1+K(N+4,4)
K(N+4,5)=N+2+MSTU(5)*(N+3)
ENDIF
DO 260 J=1,5
P(N+4,J)=0D0
V(N+4,J)=0D0
260 CONTINUE
C...Connect daughters to junction.
DO 270 II=N+1,N+3
K(II,4)=0
K(II,5)=0
K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
270 CONTINUE
C...Particle counter should be stepped up one extra for junction.
N=N+1
C...Gluino decays.
ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
K(N+4,4)=ITJUNC(JT)*MSTU(5)
C...Insert junction to keep track of colours.
IF(KCQ1(JT).NE.0) K(N+1,1)=3
IF(KCQ2(JT).NE.0) K(N+2,1)=3
IF(KCQ3(JT).NE.0) K(N+3,1)=3
K(N+4,1)=42
K(N+4,2)=88
DO 280 J=1,5
P(N+4,J)=0D0
V(N+4,J)=0D0
280 CONTINUE
CTMSUM=0D0
DO 290 II=N+1,N+3
K(II,4)=0
K(II,5)=0
C...Start by connecting all daughters to junction.
K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
C...Only consider colour topologies with off shell resonances.
RMQ1=PMAS(PYCOMP(K(II,2)),1)
RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
IF (RMGLU-RMQ1.LT.RMRES) THEN
C...Calculate propagators for each colour topology.
RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
& *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
ELSE
CTM2(II-N)=0D0
ENDIF
CTMSUM=CTMSUM+CTM2(II-N)
290 CONTINUE
CTMSUM=PYR(0)*CTMSUM
C...Select colour topology J, with most off shell least likely.
J=0
300 J=J+1
CTMSUM=CTMSUM-CTM2(J)
IF (CTMSUM.GT.0D0) GOTO 300
C...The lucky winner gets its colour (anti-colour) directly from gluino.
K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
C...The other gluino colour is connected to junction
K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
& MSTU(5)
K(N+4,4)=K(N+4,4)+ID
C...Lastly, connect junction to remaining daughters.
K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
C...Particle counter should be stepped up one extra for junction.
N=N+1
ENDIF
C...Update particle counter.
N=N+NPROD
C...2) Everything else two-body decay.
ELSE
CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
MCT(N-1,1)=0
MCT(N-1,2)=0
MCT(N,1)=0
MCT(N,2)=0
C...First set colour flow as if mother colour singlet.
IF(KCQ1(JT).NE.0) THEN
K(N-1,1)=3
IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
ENDIF
IF(KCQ2(JT).NE.0) THEN
K(N,1)=3
IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
ENDIF
C...Then redirect colour flow if mother (anti)triplet.
IF(KCQM(JT).EQ.0) THEN
ELSEIF(KCQM(JT).NE.2) THEN
ISID=4
IF(KCQM(JT).EQ.-1) ISID=5
IDAU=N-1
IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
K(ID,ISID)=K(ID,ISID)+IDAU
K(IDAU,ISID)=MSTU(5)*ID
C...Then redirect colour flow if mother octet.
ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
IDAU=N-1
IF(KCQ1(JT).EQ.0) IDAU=N
K(ID,4)=K(ID,4)+IDAU
K(ID,5)=K(ID,5)+IDAU
K(IDAU,4)=MSTU(5)*ID
K(IDAU,5)=MSTU(5)*ID
ELSE
ISID=4
IF(KCQ1(JT).EQ.-1) ISID=5
IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
K(ID,ISID)=K(ID,ISID)+(N-1)
K(ID,9-ISID)=K(ID,9-ISID)+N
K(N-1,ISID)=MSTU(5)*ID
K(N,9-ISID)=MSTU(5)*ID
ENDIF
C...Insert junction
IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
N=N+1
C...~q* mother: type 3 junction. ~q mother: type 4.
ITJUNC(JT)=(7+KCQM(JT))/2
C...Specify junction KF and set colour flow from junction
K(N,1)=42
K(N,2)=88
K(N,3)=ID
C...Junction type encoded together with mother:
K(N,4)=ID+ITJUNC(JT)*MSTU(5)
K(N,5)=N-1+MSTU(5)*(N-2)
C...Zero P and V for junction (V filled later)
DO 310 J=1,5
P(N,J)=0D0
V(N,J)=0D0
310 CONTINUE
C...Set colour flow from mother to junction
K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
C...Set colour flow from daughters to junction
DO 320 II=N-2,N-1
K(II,4) = 0
K(II,5) = 0
C...(Anti-)colour mother is junction.
K(II,1+ITJUNC(JT)) = MSTU(5)*N
320 CONTINUE
ENDIF
ENDIF
C...End loop over resonances for daughter flavour and mass selection.
MSTU(10)=MSTU10
330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
& NINH=NINH+1
IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
& KFL1(JT).EQ.0) THEN
WRITE(CODE,'(I9)') K(ID,2)
WRITE(MASS,'(F9.3)') P(ID,5)
CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
& CODE//' with mass'//MASS)
MINT(51)=1
GOTO 720
ENDIF
340 CONTINUE
C...Check for allowed combinations. Skip if no decays.
IF(JTMAX.EQ.1) THEN
IF(KDCY(1).EQ.0) GOTO 710
ELSEIF(JTMAX.EQ.2) THEN
IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
ELSEIF(JTMAX.EQ.3) THEN
IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
ENDIF
C...Special case: matrix element option for Z0 decay to quarks.
IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
&IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
C...Check consistency of MSTJ options set.
IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
CALL PYERRM(6,
& '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
MSTJ(110)=1
ENDIF
IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
CALL PYERRM(6,
& '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
MSTJ(111)=0
ENDIF
C...Select alpha_strong behaviour.
MST111=MSTU(111)
PAR112=PARU(112)
MSTU(111)=MSTJ(108)
IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
& MSTU(111)=1
PARU(112)=PARJ(121)
IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
C...Find axial fraction in total cross section for scalar gluon model.
PARJ(171)=0D0
IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
& (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
POLL=1D0-PARJ(131)*PARJ(132)
SFF=1D0/(16D0*XW*XW1)
SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
& (PARJ(123)*PARJ(124))**2)
SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
VE=4D0*XW-1D0
HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
& (PARJ(132)-PARJ(131)))
KFLC=IABS(KFL1(1))
PMQ=PYMASS(KFLC)
QF=KCHG(KFLC,1)/3D0
VQ=1D0
IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
& 1D0-(2D0*PMQ/P(ID,5))**2))
VF=SIGN(1D0,QF)-4D0*QF*XW
RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
& VF**2*HF1W)+VQ**3*HF1W
IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
ENDIF
C...Choice of jet configuration.
CALL PYXJET(P(ID,5),NJET,CUT)
KFLC=IABS(KFL1(1))
KFLN=21
IF(NJET.EQ.4) THEN
CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
ELSEIF(NJET.EQ.3) THEN
CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
ELSE
MSTJ(120)=1
ENDIF
C...Fill jet configuration; return if incorrect kinematics.
NC=N-2
IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
ELSEIF(NJET.EQ.2) THEN
CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
ELSEIF(NJET.EQ.3) THEN
CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
ELSEIF(KFLN.EQ.21) THEN
CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
& X12,X14)
ELSE
CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
& X12,X14)
ENDIF
IF(MSTU(24).NE.0) THEN
MINT(51)=1
MSTU(111)=MST111
PARU(112)=PAR112
GOTO 720
ENDIF
C...Angular orientation according to matrix element.
IF(MSTJ(106).EQ.1) THEN
CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
CTHE(1)=COS(THEZ)
CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
ENDIF
C...Boost partons to Z0 rest frame.
CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
& P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
C...Mark decayed resonance and add documentation lines,
K(ID,1)=K(ID,1)+10
IDOC=MINT(83)+MINT(4)
DO 360 I=NC+1,N
I1=MINT(83)+MINT(4)+1
K(I,3)=I1
IF(MSTP(128).GE.1) K(I,3)=ID
IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
MINT(4)=MINT(4)+1
K(I1,1)=21
K(I1,2)=K(I,2)
K(I1,3)=IREF(IP,4)
DO 350 J=1,5
P(I1,J)=P(I,J)
350 CONTINUE
ENDIF
360 CONTINUE
C...Generate parton shower.
IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
CALL PYSHOW(N-1,N,P(ID,5))
ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
NPART=2
IPART(1)=N-1
IPART(2)=N
PTPART(1)=0.5D0*P(ID,5)
PTPART(2)=PTPART(1)
NCT=NCT+1
IF(K(N-1,2).GT.0) THEN
MCT(N-1,1)=NCT
MCT(N,2)=NCT
ELSE
MCT(N-1,2)=NCT
MCT(N,1)=NCT
ENDIF
CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
ENDIF
C... End special case for Z0: skip ahead.
MSTU(111)=MST111
PARU(112)=PAR112
GOTO 700
ENDIF
C...Order incoming partons and outgoing resonances.
IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
&NINH.EQ.0) THEN
ILIN(1)=MINT(84)+1
IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
& ILIN(1)=2*MINT(84)+3-ILIN(1)
ILIN(2)=2*MINT(84)+3-ILIN(1)
IMIN=1
IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
& .EQ.36) IMIN=3
IMAX=2
IORD=1
IF(K(IREF(IP,1),2).EQ.23) IORD=2
IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
IAKIPD=IABS(K(IREF(IP,IORD),2))
IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
IF(KDCY(IORD).EQ.0) IORD=3-IORD
C...Order decay products of resonances.
DO 370 JT=IORD,3-IORD,3-2*IORD
IF(KDCY(JT).EQ.0) THEN
ILIN(IMAX+1)=NSD(JT)
IMAX=IMAX+1
ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
ILIN(IMAX+1)=N+2*JT-1
ILIN(IMAX+2)=N+2*JT
IMAX=IMAX+2
K(N+2*JT-1,2)=K(NSD(JT)+1,2)
K(N+2*JT,2)=K(NSD(JT)+2,2)
ELSE
ILIN(IMAX+1)=N+2*JT
ILIN(IMAX+2)=N+2*JT-1
IMAX=IMAX+2
K(N+2*JT-1,2)=K(NSD(JT)+1,2)
K(N+2*JT,2)=K(NSD(JT)+2,2)
ENDIF
370 CONTINUE
C...Find charge, isospin, left- and righthanded couplings.
DO 390 I=IMIN,IMAX
DO 380 J=1,4
COUP(I,J)=0D0
380 CONTINUE
KFA=IABS(K(ILIN(I),2))
IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
COUP(I,1)=KCHG(KFA,1)/3D0
COUP(I,2)=(-1)**MOD(KFA,2)
COUP(I,4)=-2D0*COUP(I,1)*XWV
COUP(I,3)=COUP(I,2)+COUP(I,4)
390 CONTINUE
C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
IF(ISUB.EQ.22) THEN
DO 420 I=3,5,2
I1=IORD
IF(I.EQ.5) I1=3-IORD
DO 410 J1=1,2
DO 400 J2=1,2
CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
& 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
& COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
& COUP(I,J2+2)**2
400 CONTINUE
410 CONTINUE
420 CONTINUE
COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
& (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
& (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
ENDIF
ENDIF
C...Select angular orientation type - Z'/W' only.
MZPWP=0
IF(ISUB.EQ.141) THEN
IF(PYR(0).LT.PARU(130)) MZPWP=1
IF(IP.EQ.2) THEN
IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
IAKIR=IABS(K(IREF(2,2),2))
IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
IF(IAKIR.LE.20) MZPWP=2
ENDIF
IF(IP.GE.3) MZPWP=2
ELSEIF(ISUB.EQ.142) THEN
IF(PYR(0).LT.PARU(136)) MZPWP=1
IF(IP.EQ.2) THEN
IAKIR=IABS(K(IREF(2,2),2))
IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
IF(IAKIR.LE.20) MZPWP=2
ENDIF
IF(IP.GE.3) MZPWP=2
ENDIF
C...Select random angles (begin of weighting procedure).
430 DO 440 JT=1,JTMAX
IF(KDCY(JT).EQ.0) GOTO 440
IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
PHI(JT)=VINT(24)
ELSE
CTHE(JT)=2D0*PYR(0)-1D0
PHI(JT)=PARU(2)*PYR(0)
ENDIF
440 CONTINUE
IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
C...Construct massless four-vectors.
DO 460 I=N+1,N+4
K(I,1)=1
DO 450 J=1,5
P(I,J)=0D0
V(I,J)=0D0
450 CONTINUE
460 CONTINUE
DO 470 JT=1,JTMAX
IF(KDCY(JT).EQ.0) GOTO 470
ID=IREF(IP,JT)
P(N+2*JT-1,3)=0.5D0*P(ID,5)
P(N+2*JT-1,4)=0.5D0*P(ID,5)
P(N+2*JT,3)=-0.5D0*P(ID,5)
P(N+2*JT,4)=0.5D0*P(ID,5)
CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
& P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
470 CONTINUE
C...Store incoming and outgoing momenta, with random rotation to
C...avoid accidental zeroes in HA expressions.
IF(ISUB.NE.0) THEN
DO 490 I=IMIN,IMAX
K(N+4+I,1)=1
P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
& P(ILIN(I),3)**2+P(ILIN(I),5)**2)
P(N+4+I,5)=P(ILIN(I),5)
DO 480 J=1,3
P(N+4+I,J)=P(ILIN(I),J)
480 CONTINUE
490 CONTINUE
500 THERR=ACOS(2D0*PYR(0)-1D0)
PHIRR=PARU(2)*PYR(0)
CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
DO 520 I=IMIN,IMAX
IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
& P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
DO 510 J=1,4
PK(I,J)=P(N+4+I,J)
510 CONTINUE
520 CONTINUE
ENDIF
C...Calculate internal products.
IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
& ISUB.EQ.142) THEN
DO 540 I1=IMIN,IMAX-1
DO 530 I2=I1+1,IMAX
HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
& PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
& CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
& SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
& (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
& CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
HC(I1,I2)=CONJG(HA(I1,I2))
IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
HA(I2,I1)=-HA(I1,I2)
HC(I2,I1)=-HC(I1,I2)
530 CONTINUE
540 CONTINUE
ENDIF
C...Calculate four-products.
IF(ISUB.NE.0) THEN
DO 560 I=1,2
DO 550 J=1,4
PK(I,J)=-PK(I,J)
550 CONTINUE
560 CONTINUE
DO 580 I1=IMIN,IMAX-1
DO 570 I2=I1+1,IMAX
PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
& PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
PKK(I2,I1)=PKK(I1,I2)
570 CONTINUE
580 CONTINUE
ENDIF
ENDIF
KFAGM=IABS(IREF(IP,7))
IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
C...Isotropic decay selected by user.
WT=1D0
WTMAX=1D0
ELSEIF(JTMAX.EQ.3) THEN
C...Isotropic decay when three mother particles.
WT=1D0
WTMAX=1D0
ELSEIF(IT4.GE.1) THEN
C... Isotropic decay t -> b + W etc for 4th generation q and l.
WT=1D0
WTMAX=1D0
ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
& IREF(IP,7).EQ.36) THEN
C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
C...CP-odd case added by Kari Ertresvag Myklevoll.
C...Now also with mixed Higgs CP-states
ETA=PARP(25)
IF(IP.EQ.1) WTMAX=SH**2
IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
KFA=IABS(K(IREF(IP,1),2))
KFT=IABS(K(IREF(IP,2),2))
IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
& MSTP(25).GE.3) THEN
C...For mixed CP states need epsilon product.
P10=PK(3,4)
P20=PK(4,4)
P30=PK(5,4)
P40=PK(6,4)
P11=PK(3,1)
P21=PK(4,1)
P31=PK(5,1)
P41=PK(6,1)
P12=PK(3,2)
P22=PK(4,2)
P32=PK(5,2)
P42=PK(6,2)
P13=PK(3,3)
P23=PK(4,3)
P33=PK(5,3)
P43=PK(6,3)
EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
& P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
& P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
& P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
& P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
& P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
& P22*P30*P41+P13*P22*P31*P40
C...For mixed CP states need gauge boson masses.
XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
& (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
& (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
XMV=PMAS(KFA,1)
ENDIF
C...Z decay
IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
KFLF1A=IABS(KFL1(1))
EF1=KCHG(KFLF1A,1)/3D0
AF1=SIGN(1D0,EF1+0.1D0)
VF1=AF1-4D0*EF1*XWV
KFLF2A=IABS(KFL1(2))
EF2=KCHG(KFLF2A,1)/3D0
AF2=SIGN(1D0,EF2+0.1D0)
VF2=AF2-4D0*EF2*XWV
VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
& THEN
C...CP-even decay
WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
& 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
ELSEIF(MSTP(25).LE.2) THEN
C...CP-odd decay
WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
& -2*PKK(3,4)*PKK(5,6)
& -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
& (PKK(3,4)*PKK(5,6))
& +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
& (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
ELSE
C...Mixed CP states.
WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
& +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
& -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
& -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
& +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
& -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
& +PKK(3,4)*PKK(5,6)
& *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
& +VA12AS*PKK(3,4)*PKK(5,6)
& *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
& *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
& /(1D0 +2D0*ETA*XMA*XMB/XMV**2
& +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
ENDIF
C...W decay
ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
& THEN
C...CP-even decay
WT=16D0*PKK(3,5)*PKK(4,6)
ELSEIF(MSTP(25).LE.2) THEN
C...CP-odd decay
WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
& -2*PKK(3,4)*PKK(5,6)
& -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
& (PKK(3,4)*PKK(5,6))
& +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
& (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
ELSE
C...Mixed CP states.
WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
& -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
& +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
& -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
& +PKK(3,4)*PKK(5,6)
& *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
& +PKK(3,4)*PKK(5,6)
& *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
& *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
& /(1D0 +2D0*ETA*XMA*XMB/XMV**2
& +(2D0*ETA*XMA*XMB/XMV**2)**2)
ENDIF
C...No angular correlations in other Higgs decays.
ELSE
WT=WTMAX
ENDIF
ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
& KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
& THEN
C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
I1=IREF(IP,8)
IF(MOD(KFAGM,2).EQ.0) THEN
I2=N+1
I3=N+2
ELSE
I2=N+2
I3=N+1
ENDIF
I4=IREF(IP,2)
WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
& P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
& P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
ELSEIF(ISUB.EQ.1) THEN
C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
EI=KCHG(IABS(MINT(15)),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
EF=KCHG(IABS(KFL1(1)),1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
& (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
& (VI**2+AI**2)*VINT(114)*VF**2)
WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
& 4D0*VI*AI*VINT(114)*VF*AF)
WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
& 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
WTMAX=2D0*(WT1+ABS(WT3))
ELSEIF(ISUB.EQ.2) THEN
C...Angular weight for W+/- -> 2 quarks/leptons.
RM3=PMAS(IABS(KFL1(1)),1)**2/SH
RM4=PMAS(IABS(KFL2(1)),1)**2/SH
BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
WTMAX=4D0
ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
C...-> gluon/gamma + 2 quarks/leptons.
CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
& COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
& COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
& COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
& COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
& (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
& ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
C...-> gluon/gamma + 2 quarks/leptons.
WT=PKK(1,3)**2+PKK(2,4)**2
WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
ELSEIF(ISUB.EQ.22) THEN
C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
S34=P(IREF(IP,IORD),5)**2
S56=P(IREF(IP,3-IORD),5)**2
TI=PKK(1,3)+PKK(1,4)+S34
UI=PKK(1,5)+PKK(1,6)+S56
TIR=REAL(TI)
UIR=REAL(UI)
FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
WT=
& CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
& CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
& CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
& CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
& (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
& ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
& 1D0/UI**2))
ELSEIF(ISUB.EQ.23) THEN
C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
D34=P(IREF(IP,IORD),5)**2
D56=P(IREF(IP,3-IORD),5)**2
DT=PKK(1,3)+PKK(1,4)+D34
DU=PKK(1,5)+PKK(1,6)+D56
FACBW=1D0/((SH-SQMW)**2+GMMW**2)
CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
& REAL(CBWZ)*FGK(1,2,5,6,3,4))
FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
& REAL(CBWZ)*FGK(1,2,6,5,3,4))
WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
& DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
C...(or H0, or A0).
WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
& PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
& COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
& (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
ELSEIF(ISUB.EQ.25) THEN
C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
D34=P(IREF(IP,IORD),5)**2
D56=P(IREF(IP,3-IORD),5)**2
DT=PKK(1,3)+PKK(1,4)+D34
DU=PKK(1,5)+PKK(1,6)+D56
FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
& REAL(CBWW)*FGK(1,2,5,6,3,4))
FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
IF(MSTP(50).LE.0) THEN
WT=FGK135**2+(CCWW*FGK253)**2
WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
& CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
& DJGK(DT,DU)))
ELSE
WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
& CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
& POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
ENDIF
ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
C...(or H0, or A0).
WT=PKK(1,3)*PKK(2,4)
WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
C...-> f + 2 quarks/leptons.
CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
& COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
& COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
& COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
& COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
& COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
& PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
& PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
& ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
& ISUB.EQ.77) THEN
C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
WT=16D0*PKK(3,5)*PKK(4,6)
WTMAX=SH**2
ELSEIF(ISUB.EQ.110) THEN
C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
WT=1D0
WTMAX=1D0
ELSEIF(ISUB.EQ.141) THEN
C...Special case: if only branching ratios known then isotropic decay.
IF(MWID(32).EQ.2) THEN
WT=1D0
WTMAX=1D0
ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
C...Couplings of incoming flavour.
KFAI=IABS(MINT(15))
EI=KCHG(KFAI,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
KFAIC=1
IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
VPI=PARU(119+2*KFAIC)
API=PARU(120+2*KFAIC)
ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
VPI=PARJ(178+2*KFAIC)
API=PARJ(179+2*KFAIC)
ELSE
VPI=PARJ(186+2*KFAIC)
API=PARJ(187+2*KFAIC)
ENDIF
C...Couplings of final flavour.
KFAF=IABS(KFL1(1))
EF=KCHG(KFAF,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
KFAFC=1
IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
VPF=PARU(119+2*KFAFC)
APF=PARU(120+2*KFAFC)
ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
VPF=PARJ(178+2*KFAFC)
APF=PARJ(179+2*KFAFC)
ELSE
VPF=PARJ(186+2*KFAFC)
APF=PARJ(187+2*KFAFC)
ENDIF
C...Asymmetry and weight.
ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
& 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
& (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
& (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
& EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
& (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
& (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
WTMAX=2D0+ABS(ASYM)
ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W-.
RM1=P(NSD(1)+1,5)**2/SH
RM2=P(NSD(1)+2,5)**2/SH
CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
& (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
& (RM2-RM1)**2)
WT=CFLAT+CCOS2*CTHE(1)**2
WTMAX=CFLAT+MAX(0D0,CCOS2)
ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
& IABS(KFL1(1)).EQ.37)) THEN
C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
WT=1D0-CTHE(1)**2
WTMAX=1D0
ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
C...Angular weight for f + fbar -> Z' -> Z0 + h0.
RM1=P(NSD(1)+1,5)**2/SH
RM2=P(NSD(1)+2,5)**2/SH
FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
WTMAX=1D0+FLAM2/(8D0*RM1)
ELSEIF(MZPWP.EQ.0) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
C...(W:s like if intermediate Z).
D34=P(IREF(IP,IORD),5)**2
D56=P(IREF(IP,3-IORD),5)**2
DT=PKK(1,3)+PKK(1,4)+D34
DU=PKK(1,5)+PKK(1,6)+D56
FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
& (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
ELSEIF(MZPWP.EQ.1) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
C...(W:s approximately longitudinal, like if intermediate H).
WT=16D0*PKK(3,5)*PKK(4,6)
WTMAX=SH**2
ELSE
C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.142) THEN
C...Special case: if only branching ratios known then isotropic decay.
IF(MWID(34).EQ.2) THEN
WT=1D0
WTMAX=1D0
ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
KFAI=IABS(MINT(15))
KFAIC=1
IF(KFAI.GT.10) KFAIC=2
VI=PARU(129+2*KFAIC)
AI=PARU(130+2*KFAIC)
KFAF=IABS(KFL1(1))
KFAFC=1
IF(KFAF.GT.10) KFAFC=2
VF=PARU(129+2*KFAFC)
AF=PARU(130+2*KFAFC)
ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
WTMAX=2D0+ABS(ASYM)
ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
RM1=P(NSD(1)+1,5)**2/SH
RM2=P(NSD(1)+2,5)**2/SH
CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
& (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
& (RM2-RM1)**2)
WT=CFLAT+CCOS2*CTHE(1)**2
WTMAX=CFLAT+MAX(0D0,CCOS2)
ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
RM1=P(NSD(1)+1,5)**2/SH
RM2=P(NSD(1)+2,5)**2/SH
FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
WTMAX=1D0+FLAM2/(8D0*RM1)
ELSEIF(MZPWP.EQ.0) THEN
C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
C...(W/Z like if intermediate W).
D34=P(IREF(IP,IORD),5)**2
D56=P(IREF(IP,3-IORD),5)**2
DT=PKK(1,3)+PKK(1,4)+D34
DU=PKK(1,5)+PKK(1,6)+D56
FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
& (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
ELSEIF(MZPWP.EQ.1) THEN
C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
C...(W/Z approximately longitudinal, like if intermediate H).
WT=16D0*PKK(3,5)*PKK(4,6)
WTMAX=SH**2
ELSE
C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
C...t + bbar -> t + W + bbar.
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
& THEN
C...Isotropic decay of leptoquarks (assumed spin 0).
WT=1D0
WTMAX=1D0
ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
SIDE=1D0
IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
WT=1D0+SIDE*CTHE(1)
WTMAX=2D0
ELSEIF(IP.EQ.1) THEN
RM1=P(NSD(1)+1,5)**2/SH
WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
ELSE
C...W/Z decay assumed isotropic, since not known.
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.149) THEN
C...Isotropic decay of techni-eta.
WT=1D0
WTMAX=1D0
ELSEIF(ISUB.EQ.191) THEN
IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
WT=1D0-CTHE(1)**2
WTMAX=1D0
ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
CTHESG=CTHE(1)*ISIGN(1,MINT(15))
XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
KFAI=IABS(MINT(15))
EI=KCHG(KFAI,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
KFAF=IABS(KFL1(1))
EF=KCHG(KFAF,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
VALF=0.5D0*(VF+AF)
VARF=0.5D0*(VF-AF)
ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
WTMAX=4D0*MAX(ASAME,AFLIP)
ELSE
C...Isotropic decay of W/pi_tc produced in rho_tc decay.
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.192) THEN
IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
WT=1D0-CTHE(1)**2
WTMAX=1D0
ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
CTHESG=CTHE(1)*ISIGN(1,MINT(15))
WT=(1D0+CTHESG)**2
WTMAX=4D0
ELSE
C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.193) THEN
IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
C...Angular weight for f + fbar -> omega_tc0 ->
C...gamma pi_tc0 or Z0 pi_tc0.
WT=1D0+CTHE(1)**2
WTMAX=2D0
ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
CTHESG=CTHE(1)*ISIGN(1,MINT(15))
BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
KFAI=IABS(MINT(15))
EI=KCHG(KFAI,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
KFAF=IABS(KFL1(1))
EF=KCHG(KFAF,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
VALF=0.5D0*(VF+AF)
VARF=0.5D0*(VF-AF)
BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
WTMAX=4D0*MAX(BSAME,BFLIP)
ELSE
C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.353) THEN
C...Angular weight for Z_R0 -> 2 quarks/leptons.
EI=KCHG(IABS(MINT(15)),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
WT2=RMF*(VI**2+AI**2)*VF**2
WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
& 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
WTMAX=2D0*(WT1+ABS(WT3))
ELSEIF(ISUB.EQ.354) THEN
C...Angular weight for W_R+/- -> 2 quarks/leptons.
RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
WTMAX=4D0
ELSEIF(ISUB.EQ.391) THEN
C...Angular weight for f + fbar -> G* -> f + fbar
IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
WTMAX=2D0
C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
C...implemented by M.-C. Lemaire
ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
& IABS(KFL1(1)).EQ.22)) THEN
WT=1D0-CTHE(1)**4
WTMAX=1D0
C...Other G* decays not yet implemented angular distributions.
ELSE
WT=1D0
WTMAX=1D0
ENDIF
ELSEIF(ISUB.EQ.392) THEN
C...Angular weight for g + g -> G* -> f + fbar
IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
WT=1D0-CTHE(1)**4
WTMAX=1D0
C...Angular weight for g + g -> G* -> gamma +gamma or g + g
C...implemented by M.-C. Lemaire
ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
& IABS(KFL1(1)).EQ.22)) THEN
WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
WTMAX=8D0
C...Other G* decays not yet implemented angular distributions.
ELSE
WT=1D0
WTMAX=1D0
ENDIF
C...Obtain correct angular distribution by rejection techniques.
ELSE
WT=1D0
WTMAX=1D0
ENDIF
IF(WT.LT.PYR(0)*WTMAX) GOTO 430
C...Construct massive four-vectors using angles chosen.
590 DO 690 JT=1,JTMAX
IF(KDCY(JT).EQ.0) GOTO 690
ID=IREF(IP,JT)
DO 600 J=1,5
DPMO(J)=P(ID,J)
600 CONTINUE
DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
CMRENNA++
NPROD=2
IF(KFL3(JT).NE.0) NPROD=3
IF(KFL4(JT).NE.0) NPROD=4
CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
& DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
N0=NSD(JT)+NPROD
DO 610 J=1,4
VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
610 CONTINUE
C...Fill in position of decay vertex.
DO 630 I=NSD(JT)+1,N0
DO 620 J=1,4
V(I,J)=VDCY(J)
620 CONTINUE
V(I,5)=0D0
630 CONTINUE
CMRENNA--
C...Mark decayed resonances; trace history.
K(ID,1)=K(ID,1)+10
KFA=IABS(K(ID,2))
KCA=PYCOMP(KFA)
IF(KCQM(JT).NE.0) THEN
C...Do not kill colour flow through coloured resonance!
ELSE
K(ID,4)=NSD(JT)+1
K(ID,5)=NSD(JT)+NPROD
IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
C...If 3-body or 2-body with junction:
c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
C...If 3-body with junction:
c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
ENDIF
C...Add documentation lines.
ISUBRG=MAX(1,MIN(500,MINT(1)))
IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
IDOC=MINT(83)+MINT(4)
CMRENNA+++
IHI=NSD(JT)+NPROD
c IF(KFL3(JT).NE.0) IHI=IHI+1
DO 650 I=NSD(JT)+1,IHI
CMRENNA---
I1=MINT(83)+MINT(4)+1
K(I,3)=I1
IF(MSTP(128).GE.1) K(I,3)=ID
IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
MINT(4)=MINT(4)+1
K(I1,1)=21
K(I1,2)=K(I,2)
K(I1,3)=IREF(IP,JT+3)
DO 640 J=1,5
P(I1,J)=P(I,J)
640 CONTINUE
ENDIF
650 CONTINUE
ELSE
K(NSD(JT)+1,3)=ID
K(NSD(JT)+2,3)=ID
C...If 3-body or 2-body with junction:
IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
C...If 3-body with junction:
IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
C...If 4-body or 3-body with junction:
IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
C...If 4-body with junction:
IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID
ENDIF
C...Do showering of two or three objects.
NSHBEF=N
IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
IF(KFL3(JT).EQ.0) THEN
CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
ELSE
CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5))
ENDIF
c...For pT-ordered shower need set up first, especially colour tags.
C...(Need to set up colour tags even if MSTP(71) = 0)
ELSEIF(MINT(35).GE.2) THEN
NPART=NPROD
c IF(KFL3(JT).NE.0) NPART=3
IPART(1)=NSD(JT)+1
IPART(2)=NSD(JT)+2
IPART(3)=NSD(JT)+3
IPART(4)=NSD(JT)+4
PTPART(1)=0.5D0*P(ID,5)
PTPART(2)=PTPART(1)
PTPART(3)=PTPART(1)
PTPART(4)=PTPART(1)
IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
MOTHER=K(NSD(JT)+1,4)/MSTU(5)
IF(MOTHER.LE.NSD(JT)) THEN
MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
ELSE
NCT=NCT+1
MCT(NSD(JT)+1,1)=NCT
MCT(MOTHER,2)=NCT
ENDIF
ENDIF
IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
MOTHER=K(NSD(JT)+1,5)/MSTU(5)
IF(MOTHER.LE.NSD(JT)) THEN
MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
ELSE
NCT=NCT+1
MCT(NSD(JT)+1,2)=NCT
MCT(MOTHER,1)=NCT
ENDIF
ENDIF
IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
& KCQ2(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+2,4)/MSTU(5)
IF(MOTHER.LE.NSD(JT)) THEN
MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
ELSE
NCT=NCT+1
MCT(NSD(JT)+2,1)=NCT
MCT(MOTHER,2)=NCT
ENDIF
ENDIF
IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
& KCQ2(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+2,5)/MSTU(5)
IF(MOTHER.LE.NSD(JT)) THEN
MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
ELSE
NCT=NCT+1
MCT(NSD(JT)+2,2)=NCT
MCT(MOTHER,1)=NCT
ENDIF
ENDIF
IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
& (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+3,4)/MSTU(5)
MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
ENDIF
IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
& (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+3,5)/MSTU(5)
MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
ENDIF
IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
& (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+4,4)/MSTU(5)
MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
ENDIF
IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
& (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
MOTHER=K(NSD(JT)+4,5)/MSTU(5)
MCT(NSD(JT)+4,2)=MCT(MOTHER,2)
ENDIF
IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
ENDIF
NSHAFT=N
IF(JT.EQ.1) NAFT1=N
C...Check if decay products moved by shower.
NSD1=NSD(JT)+1
NSD2=NSD(JT)+2
NSD3=NSD(JT)+3
NSD4=NSD(JT)+4
C...4-body decays will only work if one of the products is "inert"
IF(NSHAFT.GT.NSHBEF) THEN
IF(K(NSD1,1).GT.10) THEN
DO 660 I=NSHBEF+1,NSHAFT
IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
660 CONTINUE
ENDIF
IF(K(NSD2,1).GT.10) THEN
DO 670 I=NSHBEF+1,NSHAFT
IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
& I.NE.NSD1) NSD2=I
670 CONTINUE
ENDIF
IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
DO 680 I=NSHBEF+1,NSHAFT
IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
& I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
680 CONTINUE
ENDIF
IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
DO 685 I=NSHBEF+1,NSHAFT
IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
& I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
685 CONTINUE
ENDIF
ENDIF
C...Store decay products for further treatment.
IF(KFL4(JT).EQ.0) THEN
NP=NP+1
IREF(NP,1)=NSD1
IREF(NP,2)=NSD2
IREF(NP,3)=0
IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
IREF(NP,4)=IDOC+1
IREF(NP,5)=IDOC+2
IREF(NP,6)=0
IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
IREF(NP,7)=K(IREF(IP,JT),2)
IREF(NP,8)=IREF(IP,JT)
ELSE
NSDA=NSD1
NSDB=NSD2
NSDC=NSD3
NP=NP+1
IREF(NP,4)=IDOC+1
IREF(NP,5)=IDOC+2
IREF(NP,6)=IDOC+3
IF(K(NSD1,1).EQ.1) THEN
NSDA=NSD4
IREF(NP,4)=IDOC+4
ELSEIF(K(NSD2,1).EQ.1) THEN
NSDB=NSD4
IREF(NP,5)=IDOC+4
ELSEIF(K(NSD3,1).EQ.1) THEN
NSDC=NSD4
IREF(NP,6)=IDOC+4
ENDIF
IREF(NP,1)=NSDA
IREF(NP,2)=NSDB
IREF(NP,3)=NSDC
IREF(NP,7)=K(IREF(IP,JT),2)
IREF(NP,8)=IREF(IP,JT)
ENDIF
690 CONTINUE
C...Fill information for 2 -> 1 -> 2.
700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
MINT(7)=MINT(83)+6+2*ISET(ISUB)
MINT(8)=MINT(83)+7+2*ISET(ISUB)
MINT(25)=KFL1(1)
MINT(26)=KFL2(1)
VINT(23)=CTHE(1)
RM3=P(N-1,5)**2/SH
RM4=P(N,5)**2/SH
BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
VINT(47)=SQRT(VINT(48))
ENDIF
C...Possibility of colour rearrangement in W+W- events.
IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
IAKF1=IABS(KFL1(1))
IAKF2=IABS(KFL1(2))
IAKF3=IABS(KFL2(1))
IAKF4=IABS(KFL2(2))
IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
& MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
& PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
IF(MINT(51).NE.0) RETURN
ENDIF
C...Loop back if needed.
710 IF(IP.LT.NP) GOTO 170
C...Boost back to standard frame.
720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
&BEZIN)
RETURN
END
C*********************************************************************
C...PYMULT
C...Initializes treatment of multiple interactions, selects kinematics
C...of hardest interaction if low-pT physics included in run, and
C...generates all non-hardest interactions.
SUBROUTINE PYMULT(MMUL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
C...Local arrays and saved variables.
DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
&CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
&RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
C...Initialization of multiple interaction treatment.
IF(MMUL.EQ.1) THEN
IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
ISUB=96
MINT(1)=96
VINT(63)=0D0
VINT(64)=0D0
VINT(143)=1D0
VINT(144)=1D0
C...Loop over phase space points: xT2 choice in 20 bins.
100 SIGSUM=0D0
DO 120 IXT2=1,20
NMUL(IXT2)=MSTP(83)
SIGM(IXT2)=0D0
DO 110 ITRY=1,MSTP(83)
RSCA=0.05D0*((21-IXT2)-PYR(0))
XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
XT2=MAX(0.01D0*VINT(149),XT2)
VINT(25)=XT2
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
C...Calculate differential cross-section.
VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
CALL PYSIGH(NCHN,SIGS)
SIGM(IXT2)=SIGM(IXT2)+SIGS
110 CONTINUE
SIGSUM=SIGSUM+SIGM(IXT2)
120 CONTINUE
SIGSUM=SIGSUM/(20D0*MSTP(83))
C...Reject result if sigma(parton-parton) is smaller than hadronic one.
IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
& PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
PARP(82)=0.9D0*PARP(82)
VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
& VINT(2)
GOTO 100
ENDIF
IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
& PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
C...Start iteration to find k factor.
YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
P83A=(1D0-PARP(83))**2
P83B=2D0*PARP(83)*(1D0-PARP(83))
P83C=PARP(83)**2
CQ2I=1D0/PARP(84)**2
CQ2R=2D0/(1D0+PARP(84)**2)
SO=0.5D0
XI=0D0
YI=0D0
XF=0D0
YF=0D0
XK=0.5D0
IIT=0
130 IF(IIT.EQ.0) THEN
XK=2D0*XK
ELSEIF(IIT.EQ.1) THEN
XK=0.5D0*XK
ELSE
XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
ENDIF
C...Evaluate overlap integrals. Find where to divide the b range.
IF(MSTP(82).EQ.2) THEN
SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
SOP=SP/PARU(1)
ELSE
IF(MSTP(82).EQ.3) THEN
DELTAB=0.02D0
ELSEIF(MSTP(82).EQ.4) THEN
DELTAB=MIN(0.01D0,0.05D0*PARP(84))
ELSE
POWIP=MAX(0.4D0,PARP(83))
RPWIP=2D0/POWIP-1D0
DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
SO=0D0
ENDIF
SP=0D0
SOP=0D0
BSP=0D0
SOHIGH=0D0
IBDIV=0
B=-0.5D0*DELTAB
140 B=B+DELTAB
IF(MSTP(82).EQ.3) THEN
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSE
OV=EXP(-B**POWIP)/PARU(2)
SO=SO+PARU(2)*B*DELTAB*OV
ENDIF
IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
SP=SP+PARU(2)*B*DELTAB*PACC
SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
BSP=BSP+B*PARU(2)*B*DELTAB*PACC
IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
IBDIV=1
BDIV=B+0.5D0*DELTAB
ENDIF
IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
ENDIF
YK=PARU(1)*XK*SO/SP
C...Continue iteration until convergence.
IF(YK.LT.YKE) THEN
XI=XK
YI=YK
IF(IIT.EQ.1) IIT=2
ELSE
XF=XK
YF=YK
IF(IIT.EQ.0) IIT=1
ENDIF
IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
C...Store some results for subsequent use.
BAVG=BSP/SP
VINT(145)=SIGSUM
VINT(146)=SOP/SO
VINT(147)=SOP/SP
VNT145=VINT(145)
VNT146=VINT(146)
VNT147=VINT(147)
C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
PIK=(VNT146/VNT147)*YKE
C...Find relative weight for low and high impact parameter.
PLOWB=PARU(1)*BDIV**2
IF(MSTP(82).EQ.3) THEN
PHIGHB=PIK*0.5*EXP(-BDIV**2)
ELSEIF(MSTP(82).EQ.4) THEN
S4A=P83A*EXP(-BDIV**2)
S4B=P83B*EXP(-BDIV**2*CQ2R)
S4C=P83C*EXP(-BDIV**2*CQ2I)
PHIGHB=PIK*0.5*(S4A+S4B+S4C)
ELSEIF(PARP(83).GE.1.999D0) THEN
PHIGHB=PIK*SOHIGH
B2RPDV=BDIV**POWIP
ELSE
PHIGHB=PIK*SOHIGH
B2RPDV=BDIV**POWIP
B2RPMX=MAX(2D0*RPWIP,B2RPDV)
ENDIF
PALLB=PLOWB+PHIGHB
C...Initialize iteration in xT2 for hardest interaction.
ELSEIF(MMUL.EQ.2) THEN
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
IF(MSTP(82).LE.0) THEN
ELSEIF(MSTP(82).EQ.1) THEN
XT2=1D0
SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
& VINT(317)/(VINT(318)*VINT(320))
XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
ELSEIF(MSTP(82).EQ.2) THEN
XT2=1D0
XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
& VINT(149)*(1D0+VINT(149))
ELSE
XC2=4D0*CKIN(3)**2/VINT(2)
IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
ENDIF
C...Select impact parameter for hardest interaction.
IF(MSTP(82).LE.2) RETURN
142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
C...Treatment in low b region.
MINT(39)=1
B=BDIV*SQRT(PYR(0))
IF(MSTP(82).EQ.3) THEN
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSE
OV=EXP(-B**POWIP)/PARU(2)
ENDIF
VINT(148)=OV/VNT147
PACC=1D0-EXP(-MIN(50D0,PIK*OV))
XT2=1D0
XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
& VINT(149)*(1D0+VINT(149))
ELSE
C...Treatment in high b region.
MINT(39)=2
IF(MSTP(82).EQ.3) THEN
B=SQRT(BDIV**2-LOG(PYR(0)))
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
S4RNDM=PYR(0)*(S4A+S4B+S4C)
IF(S4RNDM.LT.S4A) THEN
B=SQRT(BDIV**2-LOG(PYR(0)))
ELSEIF(S4RNDM.LT.S4A+S4B) THEN
B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
ELSE
B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
ENDIF
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSEIF(PARP(83).GE.1.999D0) THEN
144 B2RPW=B2RPDV-LOG(PYR(0))
ACCIP=(B2RPW/B2RPDV)**RPWIP
IF(ACCIP.LT.PYR(0)) GOTO 144
OV=EXP(-B2RPW)/PARU(2)
B=B2RPW**(1D0/POWIP)
ELSE
146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
IF(ACCIP.LT.PYR(0)) GOTO 146
OV=EXP(-B2RPW)/PARU(2)
B=B2RPW**(1D0/POWIP)
ENDIF
VINT(148)=OV/VNT147
PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
ENDIF
IF(PACC.LT.PYR(0)) GOTO 142
VINT(139)=B/BAVG
ELSEIF(MMUL.EQ.3) THEN
C...Low-pT or multiple interactions (first semihard interaction):
C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
IF(MSTP(82).LE.0) THEN
XT2=0D0
ELSEIF(MSTP(82).EQ.1) THEN
XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
C...Use with "Sudakov" for low b values when impact parameter dependence.
ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
& VINT(149)))).GT.PYR(0)) XT2=1D0
IF(XT2.GE.1D0) THEN
XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
& PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
& VINT(149)
ELSE
XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
& (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
& VINT(149)
ENDIF
XT2=MAX(0.01D0*VINT(149),XT2)
C...Use without "Sudakov" for high b values when impact parameter dep.
ELSE
XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
& PYR(0)*(1D0-XC2))-VINT(149)
XT2=MAX(0.01D0*VINT(149),XT2)
ENDIF
VINT(25)=XT2
C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
ISUB=95
MINT(1)=ISUB
VINT(21)=0.01D0*VINT(149)
VINT(22)=0D0
VINT(23)=0D0
VINT(25)=0.01D0*VINT(149)
ELSE
C...Multiple interactions (first semihard interaction).
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
ENDIF
VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
C...Store results of cross-section calculation.
ELSEIF(MMUL.EQ.4) THEN
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
XTS=VINT(25)
IF(ISET(ISUB).EQ.1) XTS=VINT(21)
IF(ISET(ISUB).EQ.2)
& XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
& (XTS+VINT(149))))
IRBIN=INT(1D0+20D0*RBIN)
IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
NMUL(IRBIN)=NMUL(IRBIN)+1
SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
ENDIF
C...Choose impact parameter if not already done.
ELSEIF(MMUL.EQ.5) THEN
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
150 IF(MINT(39).GT.0) THEN
ELSEIF(MSTP(82).EQ.3) THEN
EXPB2=PYR(0)
B2=-LOG(PYR(0))
VINT(148)=EXPB2/(PARU(2)*VNT147)
VINT(139)=SQRT(B2)/BAVG
ELSEIF(MSTP(82).EQ.4) THEN
RTYPE=PYR(0)
IF(RTYPE.LT.P83A) THEN
B2=-LOG(PYR(0))
ELSEIF(RTYPE.LT.P83A+P83B) THEN
B2=-LOG(PYR(0))/CQ2R
ELSE
B2=-LOG(PYR(0))/CQ2I
ENDIF
VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
& P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
VINT(139)=SQRT(B2)/BAVG
ELSEIF(PARP(83).GE.1.999D0) THEN
POWIP=MAX(2D0,PARP(83))
RPWIP=2D0/POWIP-1D0
PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
160 IF(PYR(0).LT.PROB1) THEN
B2RPW=PYR(0)**(0.5D0*POWIP)
ACCIP=EXP(-B2RPW)
ELSE
B2RPW=1D0-LOG(PYR(0))
ACCIP=B2RPW**RPWIP
ENDIF
IF(ACCIP.LT.PYR(0)) GOTO 160
VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
VINT(139)=B2RPW**(1D0/POWIP)/BAVG
ELSE
POWIP=MAX(0.4D0,PARP(83))
RPWIP=2D0/POWIP-1D0
PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
170 IF(PYR(0).LT.PROB1) THEN
B2RPW=2D0*RPWIP*PYR(0)
ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
ELSE
B2RPW=2D0*(RPWIP-LOG(PYR(0)))
ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
ENDIF
IF(ACCIP.LT .PYR(0)) GOTO 170
VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
VINT(139)=B2RPW**(1D0/POWIP)/BAVG
ENDIF
C...Multiple interactions (variable impact parameter) : reject with
C...probability exp(-overlap*cross-section above pT/normalization).
C...Does not apply to low-b region, where "Sudakov" already included.
VINT(150)=1D0
IF(MINT(39).NE.1) THEN
RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
DO 180 IBIN=IRBIN+1,20
RNCOR=RNCOR+NMUL(IBIN)
SIGCOR=SIGCOR+SIGM(IBIN)
180 CONTINUE
SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
& SIGABV/MAX(1D-10,SIGT(0,0,5))))
ENDIF
IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
& ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
& .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
IF(VINT(150).LT.PYR(0)) GOTO 150
VINT(150)=1D0
ENDIF
C...Generate additional multiple semihard interactions.
ELSEIF(MMUL.EQ.6) THEN
ISUBSV=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
DO 190 J=11,80
VINTSV(J)=VINT(J)
190 CONTINUE
ISUB=96
MINT(1)=96
VINT(151)=0D0
VINT(152)=0D0
C...Reconstruct strings in hard scattering.
NMAX=MINT(84)+4
IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
NSTR=0
DO 210 I=MINT(84)+1,NMAX
KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
IF(KCS.EQ.0) GOTO 210
DO 200 J=1,4
IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
IF(J.LE.2) THEN
IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
ELSE
IST=MOD(K(I,J+1),MSTU(5))
ENDIF
IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
NSTR=NSTR+1
IF(J.EQ.1.OR.J.EQ.4) THEN
KSTR(NSTR,1)=I
KSTR(NSTR,2)=IST
ELSE
KSTR(NSTR,1)=IST
KSTR(NSTR,2)=I
ENDIF
200 CONTINUE
210 CONTINUE
C...Set up starting values for iteration in xT2.
XT2=4D0*VINT(62)/VINT(2)
IF(MSTP(82).LE.1) THEN
SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
& VINT(317)/(VINT(318)*VINT(320))
XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
ELSE
XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
& MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
ENDIF
VINT(63)=0D0
VINT(64)=0D0
VINT(143)=1D0-VINT(141)
VINT(144)=1D0-VINT(142)
C...Iterate downwards in xT2.
220 IF(MSTP(82).LE.1) THEN
XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
IF(XT2.LT.VINT(149)) GOTO 270
ELSE
IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
& LOG(PYR(0)))-VINT(149)
IF(XT2.LE.0D0) GOTO 270
XT2=MAX(0.01D0*VINT(149),XT2)
ENDIF
VINT(25)=XT2
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
C...Check that x not used up. Accept or reject kinematical variables.
X1M=SQRT(TAU)*EXP(VINT(22))
X2M=SQRT(TAU)*EXP(-VINT(22))
IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
CALL PYSIGH(NCHN,SIGS)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
C...Reset K, P and V vectors. Select some variables.
DO 240 I=N+1,N+2
DO 230 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
230 CONTINUE
240 CONTINUE
RFLAV=PYR(0)
PT=0.5D0*VINT(1)*SQRT(XT2)
PHI=PARU(2)*PYR(0)
CTH=VINT(23)
C...Add first parton to event record.
K(N+1,1)=3
K(N+1,2)=21
IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
& 1+INT((2D0+PARJ(2))*PYR(0))
P(N+1,1)=PT*COS(PHI)
P(N+1,2)=PT*SIN(PHI)
P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
P(N+1,5)=0D0
C...Add second parton to event record.
K(N+2,1)=3
K(N+2,2)=21
IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
P(N+2,1)=-P(N+1,1)
P(N+2,2)=-P(N+1,2)
P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
P(N+2,5)=0D0
IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
C....Choose relevant string pieces to place gluons on.
DO 260 I=N+1,N+2
DMIN=1D8
DO 250 ISTR=1,NSTR
I1=KSTR(ISTR,1)
I2=KSTR(ISTR,2)
DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
& P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
& P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
& P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
DMIN=DIST
IST1=I1
IST2=I2
ISTM=ISTR
ENDIF
250 CONTINUE
C....Colour flow adjustments, new string pieces.
IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
& MOD(K(IST1,4),MSTU(5))
IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
& MSTU(5)*(K(IST1,5)/MSTU(5))+I
K(I,5)=MSTU(5)*IST1
K(I,4)=MSTU(5)*IST2
IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
& MOD(K(IST2,5),MSTU(5))
IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
& MSTU(5)*(K(IST2,4)/MSTU(5))+I
KSTR(ISTM,2)=I
KSTR(NSTR+1,1)=I
KSTR(NSTR+1,2)=IST2
NSTR=NSTR+1
260 CONTINUE
C...String drawing and colour flow for gluon loop.
ELSEIF(K(N+1,2).EQ.21) THEN
K(N+1,4)=MSTU(5)*(N+2)
K(N+1,5)=MSTU(5)*(N+2)
K(N+2,4)=MSTU(5)*(N+1)
K(N+2,5)=MSTU(5)*(N+1)
KSTR(NSTR+1,1)=N+1
KSTR(NSTR+1,2)=N+2
KSTR(NSTR+2,1)=N+2
KSTR(NSTR+2,2)=N+1
NSTR=NSTR+2
C...String drawing and colour flow for qqbar pair.
ELSE
K(N+1,4)=MSTU(5)*(N+2)
K(N+2,5)=MSTU(5)*(N+1)
KSTR(NSTR+1,1)=N+1
KSTR(NSTR+1,2)=N+2
NSTR=NSTR+1
ENDIF
C...Global statistics.
MINT(351)=MINT(351)+1
VINT(351)=VINT(351)+PT
IF (MINT(351).EQ.1) VINT(356)=PT
C...Update remaining energy; iterate.
N=N+2
IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
MINT(51)=1
RETURN
ENDIF
MINT(31)=MINT(31)+1
VINT(151)=VINT(151)+VINT(41)
VINT(152)=VINT(152)+VINT(42)
VINT(143)=VINT(143)-VINT(41)
VINT(144)=VINT(144)-VINT(42)
C...Allow FSR for UE (always handle with old showers)
IF(MSTP(152).EQ.1) THEN
M41SAV=MSTJ(41)
IF (MSTJ(41).EQ.10) MSTJ(41)=2
MSTJ(41)=MOD(MSTJ(41),10)
CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
MSTJ(41)=M41SAV
ENDIF
IF(MINT(31).LT.240) GOTO 220
270 CONTINUE
MINT(1)=ISUBSV
DO 280 J=11,80
VINT(J)=VINTSV(J)
280 CONTINUE
ENDIF
C...Format statements for printout.
5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
&'actions for MSTP(82) =',I2,' ******')
5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
&D9.2,' mb: rejected')
5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
&D9.2,' mb: accepted')
RETURN
END
C*********************************************************************
C...PYREMN
C...Adds on target remnants (one or two from each side) and
C...includes primordial kT for hadron beams.
SUBROUTINE PYREMN(IPU1,IPU2)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
&PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
C...Find event type and remaining energy.
ISUB=MINT(1)
NS=N
IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
VINT(143)=1D0-VINT(141)
VINT(144)=1D0-VINT(142)
ENDIF
C...Define initial partons.
NTRY=0
100 NTRY=NTRY+1
DO 130 JT=1,2
I=MINT(83)+JT+2
IF(JT.EQ.1) IPU=IPU1
IF(JT.EQ.2) IPU=IPU2
K(I,1)=21
K(I,2)=K(IPU,2)
K(I,3)=I-2
PMS(JT)=0D0
VINT(156+JT)=0D0
VINT(158+JT)=0D0
IF(MINT(47).EQ.1) THEN
DO 110 J=1,5
P(I,J)=P(I-2,J)
110 CONTINUE
ELSEIF(ISUB.EQ.95) THEN
K(I,2)=21
ELSE
P(I,5)=P(IPU,5)
C...No primordial kT, or chosen according to truncated Gaussian or
C...exponential, or (for photon) predetermined or power law.
120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
IF(MSTP(91).LE.0) THEN
PT=0D0
ELSEIF(MSTP(91).EQ.1) THEN
PT=PARP(91)*SQRT(-LOG(PYR(0)))
ELSE
RPT1=PYR(0)
RPT2=PYR(0)
PT=-PARP(92)*LOG(RPT1*RPT2)
ENDIF
IF(PT.GT.PARP(93)) GOTO 120
ELSEIF(MINT(106+JT).EQ.3) THEN
PTA=SQRT(VINT(282+JT))
PTB=0D0
IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
PTB=PARP(99)*SQRT(-LOG(PYR(0)))
ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
RPT1=PYR(0)
RPT2=PYR(0)
PTB=-PARP(99)*LOG(RPT1*RPT2)
ENDIF
IF(PTB.GT.PARP(100)) GOTO 120
PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
PT=PT*0.8D0**MINT(57)
IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
IF(MSTP(93).LE.0) THEN
PT=0D0
ELSEIF(MSTP(93).EQ.1) THEN
PT=PARP(99)*SQRT(-LOG(PYR(0)))
ELSEIF(MSTP(93).EQ.2) THEN
RPT1=PYR(0)
RPT2=PYR(0)
PT=-PARP(99)*LOG(RPT1*RPT2)
ELSEIF(MSTP(93).EQ.3) THEN
HA=PARP(99)**2
HB=PARP(100)**2
PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
ELSE
HA=PARP(99)**2
HB=PARP(100)**2
IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
ENDIF
IF(PT.GT.PARP(100)) GOTO 120
ELSE
PT=0D0
ENDIF
VINT(156+JT)=PT
PHI=PARU(2)*PYR(0)
P(I,1)=PT*COS(PHI)
P(I,2)=PT*SIN(PHI)
PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
ENDIF
130 CONTINUE
IF(MINT(47).EQ.1) RETURN
C...Kinematics construction for initial partons.
I1=MINT(83)+3
I2=MINT(83)+4
IF(ISUB.EQ.95) THEN
SHS=0D0
SHR=0D0
ELSE
SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
& (P(I1,2)+P(I2,2))**2
SHR=SQRT(MAX(0D0,SHS))
IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
P(I2,4)=SHR-P(I1,4)
P(I2,3)=-P(I1,3)
C...Transform partons to overall CM-frame.
ROBO(3)=(P(I1,1)+P(I2,1))/SHR
ROBO(4)=(P(I1,2)+P(I2,2))/SHR
CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
ROBO(2)=PYANGL(P(I1,1),P(I1,2))
CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
ROBO(1)=PYANGL(P(I1,3),P(I1,1))
CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
ENDIF
C...Optionally fix up x and Q2 definitions for leptoproduction.
IDISXQ=0
IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
&MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
IF(IDISXQ.EQ.1) THEN
C...Find where incoming and outgoing leptons/partons are sitting.
LESD=1
IF(MINT(42).EQ.1) LESD=2
LPIN=MINT(83)+3-LESD
LEIN=MINT(84)+LESD
LQIN=MINT(84)+3-LESD
LEOUT=MINT(84)+2+LESD
LQOUT=MINT(84)+5-LESD
IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
LSCMS=0
DO 140 I=MINT(84)+5,N
IF(K(I,2).EQ.94) THEN
LSCMS=I
LEOUT=I+LESD
LQOUT=I+3-LESD
ENDIF
140 CONTINUE
LQBG=IPU1
IF(LESD.EQ.1) LQBG=IPU2
C...Calculate actual and wanted momentum transfer.
XNOM=VINT(43-LESD)
Q2NOM=-VINT(45)
HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
& P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
& (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
P(N+1,1)=FAC*P(LEOUT,1)
P(N+1,2)=FAC*P(LEOUT,2)
P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
& Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
& P(N+1,3)**2)
DO 150 J=1,4
QOLD(J)=P(LEIN,J)-P(LEOUT,J)
QNEW(J)=P(LEIN,J)-P(N+1,J)
150 CONTINUE
C...Boost outgoing electron and daughters.
IF(LSCMS.EQ.0) THEN
DO 160 J=1,4
P(LEOUT,J)=P(N+1,J)
160 CONTINUE
ELSE
DO 170 J=1,3
P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
170 CONTINUE
PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
DO 180 J=1,3
DBE(J)=PINV*P(N+2,J)
180 CONTINUE
DO 200 I=LSCMS+1,N
IORIG=I
190 IORIG=K(IORIG,3)
IF(IORIG.GT.LEOUT) GOTO 190
IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
& CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
200 CONTINUE
ENDIF
C...Copy shower initiator and all outgoing partons.
NCOP=N+1
K(NCOP,3)=LQBG
DO 210 J=1,5
P(NCOP,J)=P(LQBG,J)
210 CONTINUE
DO 240 I=MINT(84)+1,N
ICOP=0
IF(K(I,1).GT.10) GOTO 240
IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
ICOP=I
ELSE
IORIG=I
220 IORIG=K(IORIG,3)
IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
ICOP=IORIG
ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
GOTO 220
ENDIF
ENDIF
IF(ICOP.NE.0) THEN
NCOP=NCOP+1
K(NCOP,3)=I
DO 230 J=1,5
P(NCOP,J)=P(I,J)
230 CONTINUE
ENDIF
240 CONTINUE
C...Calculate relative rescaling factors.
SLC=3-2*LESD
PLCSUM=0D0
DO 250 I=N+2,NCOP
PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
250 CONTINUE
DO 260 I=N+2,NCOP
V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
260 CONTINUE
C...Transfer extra three-momentum of current.
DO 280 I=N+2,NCOP
DO 270 J=1,3
P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
270 CONTINUE
P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
280 CONTINUE
C...Iterate change of initiator momentum to get energy right.
ITER=0
290 ITER=ITER+1
PEEX=-P(N+1,4)-QNEW(4)
PEMV=-P(N+1,3)/P(N+1,4)
DO 300 I=N+2,NCOP
PEEX=PEEX+P(I,4)
PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
300 CONTINUE
IF(ABS(PEMV).LT.1D-10) THEN
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
PZCH=-PEEX/PEMV
P(N+1,3)=P(N+1,3)+PZCH
P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
DO 310 I=N+2,NCOP
P(I,3)=P(I,3)+V(I,1)*PZCH
P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
310 CONTINUE
IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
C...Modify momenta in event record.
HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
& ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
IF(ABS(HBE).GE.1D0) THEN
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
I=MINT(83)+5-LESD
CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
DO 330 I=N+1,NCOP
ICOP=K(I,3)
DO 320 J=1,4
P(ICOP,J)=P(I,J)
320 CONTINUE
330 CONTINUE
ENDIF
C...Check minimum invariant mass of remnant system(s).
PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
PMIN(0)=SQRT(PMS(0))
DO 340 JT=1,2
PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
PMIN(JT)=0D0
IF(MINT(44+JT).EQ.1) GOTO 340
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
IF(MINT(51).NE.0) THEN
MINT(57)=MINT(57)+1
RETURN
ENDIF
IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
& P(MINT(83)+JT+2,2)**2)
340 CONTINUE
IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
&PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
&PSYS(2,4))) THEN
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
C...Loop over two remnants; skip if none there.
I=NS
DO 410 JT=1,2
ISN(JT)=0
IF(MINT(44+JT).EQ.1) GOTO 410
IF(JT.EQ.1) IPU=IPU1
IF(JT.EQ.2) IPU=IPU2
C...Store first remnant parton.
I=I+1
IS(JT)=I
ISN(JT)=1
DO 350 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
350 CONTINUE
K(I,1)=1
K(I,2)=KFLSP(JT)
K(I,3)=MINT(83)+JT
P(I,5)=PYMASS(K(I,2))
C...First parton colour connections and kinematics.
KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
IF(KCOL.EQ.2) THEN
K(I,1)=3
K(I,4)=MSTU(5)*IPU+IPU
K(I,5)=MSTU(5)*IPU+IPU
K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
ELSEIF(KCOL.NE.0) THEN
K(I,1)=3
KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
K(I,KFLS+3)=IPU
K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
ENDIF
IF(KFLCH(JT).EQ.0) THEN
P(I,1)=-P(MINT(83)+JT+2,1)
P(I,2)=-P(MINT(83)+JT+2,2)
PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
P(I,3)=PSYS(JT,3)
P(I,4)=PSYS(JT,4)
C...When extra remnant parton or hadron: store extra remnant.
ELSE
I=I+1
ISN(JT)=2
DO 360 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
360 CONTINUE
K(I,1)=1
K(I,2)=KFLCH(JT)
K(I,3)=MINT(83)+JT
P(I,5)=PYMASS(K(I,2))
C...Find parton colour connections of extra remnant.
KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
IF(KCOL.EQ.2) THEN
K(I,1)=3
K(I,4)=MSTU(5)*IPU+IPU
K(I,5)=MSTU(5)*IPU+IPU
K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
ELSEIF(KCOL.NE.0) THEN
K(I,1)=3
KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
K(I,KFLS+3)=IPU
K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
ENDIF
C...Relative transverse momentum when two remnants.
LOOP=0
370 LOOP=LOOP+1
CALL PYPTDI(1,P(I-1,1),P(I-1,2))
IF(IABS(MINT(10+JT)).LT.20) THEN
P(I-1,1)=0D0
P(I-1,2)=0D0
ELSE
P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
ENDIF
PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
C...Meson or baryon; photon as meson. For splitup below.
IMB=1
IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
C***Relative distribution for electron into two electrons. Temporary!
IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
& THEN
CHI(JT)=PYR(0)
C...Relative distribution of electron energy into electron plus parton.
ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
XHRD=VINT(140+JT)
XE=VINT(154+JT)
CHI(JT)=(XE-XHRD)/(1D0-XHRD)
C...Relative distribution of energy for particle into two jets.
ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
CHIK=PARP(92+2*IMB)
IF(MSTP(92).LE.1) THEN
IF(IMB.EQ.1) CHI(JT)=PYR(0)
IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
ELSEIF(MSTP(92).EQ.2) THEN
CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
ELSEIF(MSTP(92).EQ.3) THEN
CUT=2D0*0.3D0/VINT(1)
380 CHI(JT)=PYR(0)**2
IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
& (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
ELSEIF(MSTP(92).EQ.4) THEN
CUT=2D0*0.3D0/VINT(1)
CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
390 CHIR=CUT*CUTR**PYR(0)
CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
ELSE
CUT=2D0*0.3D0/VINT(1)
CUTA=CUT**(1D0-PARP(98))
CUTB=(1D0+CUT)**(1D0-PARP(98))
400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
& (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
ENDIF
C...Relative distribution of energy for particle into jet plus particle.
ELSE
IF(MSTP(94).LE.1) THEN
IF(IMB.EQ.1) CHI(JT)=PYR(0)
IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
ELSEIF(MSTP(94).EQ.2) THEN
CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
ELSEIF(MSTP(94).EQ.3) THEN
CALL PYZDIS(1,0,PMS(JT+4),ZZ)
CHI(JT)=ZZ
ELSE
CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
CHI(JT)=ZZ
ENDIF
ENDIF
C...Construct total transverse mass; reject if too large.
CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
IF(LOOP.LT.100) THEN
GOTO 370
ELSE
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
ENDIF
PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
VINT(158+JT)=CHI(JT)
C...Subdivide longitudinal momentum according to value selected above.
PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
ENDIF
410 CONTINUE
N=I
C...Check if longitudinal boosts needed - if so pick two systems.
PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
&ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
IF(PDEV.LE.1D-6*VINT(1)) RETURN
IF(ISN(1).EQ.0) THEN
IR=0
IL=2
ELSEIF(ISN(2).EQ.0) THEN
IR=1
IL=0
ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
IR=1
IL=2
ELSEIF(VINT(143).GT.0.2D0) THEN
IR=1
IL=0
ELSEIF(VINT(144).GT.0.2D0) THEN
IR=0
IL=2
ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
IR=1
IL=0
ELSE
IR=0
IL=2
ENDIF
IG=3-IR-IL
C...E+-pL wanted for system to be modified.
IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
PPB=VINT(1)
PNB=VINT(1)
ELSE
PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
ENDIF
C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
PPB=PPB-(PSYS(0,4)+PSYS(0,3))
PNB=PNB-(PSYS(0,4)-PSYS(0,3))
DO 420 J=1,4
PSYS(0,J)=0D0
420 CONTINUE
DO 450 I=MINT(84)+1,NS
IF(K(I,1).GT.10) GOTO 450
INCL=0
IORIG=I
430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
IORIG=K(IORIG,3)
IF(IORIG.GT.LPIN) GOTO 430
IF(INCL.EQ.0) GOTO 450
DO 440 J=1,4
PSYS(0,J)=PSYS(0,J)+P(I,J)
440 CONTINUE
450 CONTINUE
PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
PPB=PPB+(PSYS(0,4)+PSYS(0,3))
PNB=PNB+(PSYS(0,4)-PSYS(0,3))
ENDIF
C...Construct longitudinal boosts.
DPMTB=PPB*PNB
DPMTR=PMS(IR)
DPMTL=PMS(IL)
DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
IF(DSQLAM.LE.1D-6*DPMTB) THEN
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
&(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
&(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
C...Perform longitudinal boosts.
IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
P(IS(1),3)=0D0
P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
ELSEIF(IR.EQ.1) THEN
CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
ELSEIF(IDISXQ.EQ.1) THEN
DO 470 I=I1,NS
INCL=0
IORIG=I
460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
IORIG=K(IORIG,3)
IF(IORIG.GT.LPIN) GOTO 460
IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
470 CONTINUE
ELSE
CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
ENDIF
IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
P(IS(2),3)=0D0
P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
ELSEIF(IL.EQ.2) THEN
CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
ELSEIF(IDISXQ.EQ.1) THEN
DO 490 I=I1,NS
INCL=0
IORIG=I
480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
IORIG=K(IORIG,3)
IF(IORIG.GT.LPIN) GOTO 480
IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
490 CONTINUE
ELSE
CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
ENDIF
C...Final check that energy-momentum conservation worked.
PESUM=0D0
PZSUM=0D0
DO 500 I=MINT(84)+1,N
IF(K(I,1).GT.10) GOTO 500
PESUM=PESUM+P(I,4)
PZSUM=PZSUM+P(I,3)
500 CONTINUE
PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
IF(PDEV.GT.1D-4*VINT(1)) THEN
MINT(51)=1
MINT(57)=MINT(57)+1
RETURN
ENDIF
C...Calculate rotation and boost from overall CM frame to
C...hadronic CM frame in leptoproduction.
MINT(91)=0
IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
MINT(91)=1
LESD=1
IF(MINT(42).EQ.1) LESD=2
LPIN=MINT(83)+3-LESD
C...Sum upp momenta of everything not lepton or photon to define boost.
DO 510 J=1,4
PSUM(J)=0D0
510 CONTINUE
DO 530 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
IF(K(I,2).EQ.22) GOTO 530
DO 520 J=1,4
PSUM(J)=PSUM(J)+P(I,J)
520 CONTINUE
530 CONTINUE
VINT(223)=-PSUM(1)/PSUM(4)
VINT(224)=-PSUM(2)/PSUM(4)
VINT(225)=-PSUM(3)/PSUM(4)
C...Boost incoming hadron to hadronic CM frame to determine rotations.
K(N+1,1)=1
DO 540 J=1,5
P(N+1,J)=P(LPIN,J)
V(N+1,J)=V(LPIN,J)
540 CONTINUE
CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
IF(LESD.EQ.2) THEN
VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
ELSE
VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYMIGN
C...Initializes treatment of new multiple interactions scenario,
C...selects kinematics of hardest interaction if low-pT physics
C...included in run, and generates all non-hardest interactions.
SUBROUTINE PYMIGN(MMUL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
EXTERNAL PYALPS
DOUBLE PRECISION PYALPS
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
C...Local arrays and saved variables.
DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
&WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
&CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
&RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
C...Initialization of multiple interaction treatment.
IF(MMUL.EQ.1) THEN
IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
ISUB=96
MINT(1)=96
VINT(63)=0D0
VINT(64)=0D0
VINT(143)=1D0
VINT(144)=1D0
C...Loop over phase space points: xT2 choice in 20 bins.
100 SIGSUM=0D0
DO 120 IXT2=1,20
NMUL(IXT2)=MSTP(83)
SIGM(IXT2)=0D0
DO 110 ITRY=1,MSTP(83)
RSCA=0.05D0*((21-IXT2)-PYR(0))
XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
XT2=MAX(0.01D0*VINT(149),XT2)
VINT(25)=XT2
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
C...Calculate differential cross-section.
VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
CALL PYSIGH(NCHN,SIGS)
SIGM(IXT2)=SIGM(IXT2)+SIGS
110 CONTINUE
SIGSUM=SIGSUM+SIGM(IXT2)
120 CONTINUE
SIGSUM=SIGSUM/(20D0*MSTP(83))
C...Reject result if sigma(parton-parton) is smaller than hadronic one.
IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
& PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
PARP(82)=0.9D0*PARP(82)
VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
& VINT(2)
GOTO 100
ENDIF
IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
& PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
C...Start iteration to find k factor.
YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
P83A=(1D0-PARP(83))**2
P83B=2D0*PARP(83)*(1D0-PARP(83))
P83C=PARP(83)**2
CQ2I=1D0/PARP(84)**2
CQ2R=2D0/(1D0+PARP(84)**2)
SO=0.5D0
XI=0D0
YI=0D0
XF=0D0
YF=0D0
XK=0.5D0
IIT=0
130 IF(IIT.EQ.0) THEN
XK=2D0*XK
ELSEIF(IIT.EQ.1) THEN
XK=0.5D0*XK
ELSE
XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
ENDIF
C...Evaluate overlap integrals. Find where to divide the b range.
IF(MSTP(82).EQ.2) THEN
SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
SOP=SP/PARU(1)
ELSE
IF(MSTP(82).EQ.3) THEN
DELTAB=0.02D0
ELSEIF(MSTP(82).EQ.4) THEN
DELTAB=MIN(0.01D0,0.05D0*PARP(84))
ELSE
POWIP=MAX(0.4D0,PARP(83))
RPWIP=2D0/POWIP-1D0
DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
SO=0D0
ENDIF
SP=0D0
SOP=0D0
BSP=0D0
SOHIGH=0D0
IBDIV=0
B=-0.5D0*DELTAB
140 B=B+DELTAB
IF(MSTP(82).EQ.3) THEN
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSE
OV=EXP(-B**POWIP)/PARU(2)
SO=SO+PARU(2)*B*DELTAB*OV
ENDIF
IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
SP=SP+PARU(2)*B*DELTAB*PACC
SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
BSP=BSP+B*PARU(2)*B*DELTAB*PACC
IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
IBDIV=1
BDIV=B+0.5D0*DELTAB
ENDIF
IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
ENDIF
YK=PARU(1)*XK*SO/SP
C...Continue iteration until convergence.
IF(YK.LT.YKE) THEN
XI=XK
YI=YK
IF(IIT.EQ.1) IIT=2
ELSE
XF=XK
YF=YK
IF(IIT.EQ.0) IIT=1
ENDIF
IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
C...Store some results for subsequent use.
BAVG=BSP/SP
VINT(145)=SIGSUM
VINT(146)=SOP/SO
VINT(147)=SOP/SP
VNT145=VINT(145)
VNT146=VINT(146)
VNT147=VINT(147)
C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
PIK=(VNT146/VNT147)*YKE
C...Find relative weight for low and high impact parameter..
PLOWB=PARU(1)*BDIV**2
IF(MSTP(82).EQ.3) THEN
PHIGHB=PIK*0.5*EXP(-BDIV**2)
ELSEIF(MSTP(82).EQ.4) THEN
S4A=P83A*EXP(-BDIV**2)
S4B=P83B*EXP(-BDIV**2*CQ2R)
S4C=P83C*EXP(-BDIV**2*CQ2I)
PHIGHB=PIK*0.5*(S4A+S4B+S4C)
ELSEIF(PARP(83).GE.1.999D0) THEN
PHIGHB=PIK*SOHIGH
B2RPDV=BDIV**POWIP
ELSE
PHIGHB=PIK*SOHIGH
B2RPDV=BDIV**POWIP
B2RPMX=MAX(2D0*RPWIP,B2RPDV)
ENDIF
PALLB=PLOWB+PHIGHB
C...Initialize iteration in xT2 for hardest interaction.
ELSEIF(MMUL.EQ.2) THEN
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
IF(MSTP(82).LE.0) THEN
ELSEIF(MSTP(82).EQ.1) THEN
XT2=1D0
SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
& VINT(317)/(VINT(318)*VINT(320))
XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
ELSEIF(MSTP(82).EQ.2) THEN
XT2=1D0
XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
& VINT(149)*(1D0+VINT(149))
ELSE
XC2=4D0*CKIN(3)**2/VINT(2)
IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
ENDIF
C...Select impact parameter for hardest interaction.
IF(MSTP(82).LE.2) RETURN
142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
C...Treatment in low b region.
MINT(39)=1
B=BDIV*SQRT(PYR(0))
IF(MSTP(82).EQ.3) THEN
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSE
OV=EXP(-B**POWIP)/PARU(2)
ENDIF
VINT(148)=OV/VNT147
PACC=1D0-EXP(-MIN(50D0,PIK*OV))
XT2=1D0
XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
& VINT(149)*(1D0+VINT(149))
ELSE
C...Treatment in high b region.
MINT(39)=2
IF(MSTP(82).EQ.3) THEN
B=SQRT(BDIV**2-LOG(PYR(0)))
OV=EXP(-B**2)/PARU(2)
ELSEIF(MSTP(82).EQ.4) THEN
S4RNDM=PYR(0)*(S4A+S4B+S4C)
IF(S4RNDM.LT.S4A) THEN
B=SQRT(BDIV**2-LOG(PYR(0)))
ELSEIF(S4RNDM.LT.S4A+S4B) THEN
B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
ELSE
B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
ENDIF
OV=(P83A*EXP(-MIN(50D0,B**2))+
& P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
ELSEIF(PARP(83).GE.1.999D0) THEN
144 B2RPW=B2RPDV-LOG(PYR(0))
ACCIP=(B2RPW/B2RPDV)**RPWIP
IF(ACCIP.LT.PYR(0)) GOTO 144
OV=EXP(-B2RPW)/PARU(2)
B=B2RPW**(1D0/POWIP)
ELSE
146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
IF(ACCIP.LT.PYR(0)) GOTO 146
OV=EXP(-B2RPW)/PARU(2)
B=B2RPW**(1D0/POWIP)
ENDIF
VINT(148)=OV/VNT147
PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
ENDIF
IF(PACC.LT.PYR(0)) GOTO 142
VINT(139)=B/BAVG
ELSEIF(MMUL.EQ.3) THEN
C...Low-pT or multiple interactions (first semihard interaction):
C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
IF(MSTP(82).LE.0) THEN
XT2=0D0
ELSEIF(MSTP(82).EQ.1) THEN
XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
C...Use with "Sudakov" for low b values when impact parameter dependence.
ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
& VINT(149)))).GT.PYR(0)) XT2=1D0
IF(XT2.GE.1D0) THEN
XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
& PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
& VINT(149)
ELSE
XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
& (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
& VINT(149)
ENDIF
XT2=MAX(0.01D0*VINT(149),XT2)
C...Use without "Sudakov" for high b values when impact parameter dep.
ELSE
XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
& PYR(0)*(1D0-XC2))-VINT(149)
XT2=MAX(0.01D0*VINT(149),XT2)
ENDIF
VINT(25)=XT2
C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
ISUB=95
MINT(1)=ISUB
VINT(21)=1D-12*VINT(149)
VINT(22)=0D0
VINT(23)=0D0
VINT(25)=1D-12*VINT(149)
ELSE
C...Multiple interactions (first semihard interaction).
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
ENDIF
VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
C...Store results of cross-section calculation.
ELSEIF(MMUL.EQ.4) THEN
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
XTS=VINT(25)
IF(ISET(ISUB).EQ.1) XTS=VINT(21)
IF(ISET(ISUB).EQ.2)
& XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
& (XTS+VINT(149))))
IRBIN=INT(1D0+20D0*RBIN)
IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
NMUL(IRBIN)=NMUL(IRBIN)+1
SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
ENDIF
C...Choose impact parameter if not already done.
ELSEIF(MMUL.EQ.5) THEN
ISUB=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
150 IF(MINT(39).GT.0) THEN
ELSEIF(MSTP(82).EQ.3) THEN
EXPB2=PYR(0)
B2=-LOG(PYR(0))
VINT(148)=EXPB2/(PARU(2)*VNT147)
VINT(139)=SQRT(B2)/BAVG
ELSEIF(MSTP(82).EQ.4) THEN
RTYPE=PYR(0)
IF(RTYPE.LT.P83A) THEN
B2=-LOG(PYR(0))
ELSEIF(RTYPE.LT.P83A+P83B) THEN
B2=-LOG(PYR(0))/CQ2R
ELSE
B2=-LOG(PYR(0))/CQ2I
ENDIF
VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
& P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
& P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
VINT(139)=SQRT(B2)/BAVG
ELSEIF(PARP(83).GE.1.999D0) THEN
POWIP=MAX(2D0,PARP(83))
RPWIP=2D0/POWIP-1D0
PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
160 IF(PYR(0).LT.PROB1) THEN
B2RPW=PYR(0)**(0.5D0*POWIP)
ACCIP=EXP(-B2RPW)
ELSE
B2RPW=1D0-LOG(PYR(0))
ACCIP=B2RPW**RPWIP
ENDIF
IF(ACCIP.LT.PYR(0)) GOTO 160
VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
VINT(139)=B2RPW**(1D0/POWIP)/BAVG
ELSE
POWIP=MAX(0.4D0,PARP(83))
RPWIP=2D0/POWIP-1D0
PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
170 IF(PYR(0).LT.PROB1) THEN
B2RPW=2D0*RPWIP*PYR(0)
ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
ELSE
B2RPW=2D0*(RPWIP-LOG(PYR(0)))
ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
ENDIF
IF(ACCIP.LT .PYR(0)) GOTO 170
VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
VINT(139)=B2RPW**(1D0/POWIP)/BAVG
ENDIF
C...Multiple interactions (variable impact parameter) : reject with
C...probability exp(-overlap*cross-section above pT/normalization).
C...Does not apply to low-b region, where "Sudakov" already included.
VINT(150)=1D0
IF(MINT(39).NE.1) THEN
RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
DO 180 IBIN=IRBIN+1,20
RNCOR=RNCOR+NMUL(IBIN)
SIGCOR=SIGCOR+SIGM(IBIN)
180 CONTINUE
SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
& SIGABV/MAX(1D-10,SIGT(0,0,5))))
ENDIF
IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
& ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
& .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
IF(VINT(150).LT.PYR(0)) GOTO 150
VINT(150)=1D0
ENDIF
C...Generate additional multiple semihard interactions.
ELSEIF(MMUL.EQ.6) THEN
C...Save data for hardest initeraction, to be restored.
ISUBSV=MINT(1)
VINT(145)=VNT145
VINT(146)=VNT146
VINT(147)=VNT147
M13SV=MINT(13)
M14SV=MINT(14)
M15SV=MINT(15)
M16SV=MINT(16)
M21SV=MINT(21)
M22SV=MINT(22)
DO 190 J=11,80
VINTSV(J)=VINT(J)
190 CONTINUE
V141SV=VINT(141)
V142SV=VINT(142)
C...Store data on hardest interaction.
XMI(1,1)=VINT(141)
XMI(2,1)=VINT(142)
PT2MI(1)=VINT(54)
IMISEP(0)=MINT(84)
IMISEP(1)=N
C...Change process to generate; sum of x values so far.
ISUB=96
MINT(1)=96
VINT(143)=1D0-VINT(141)
VINT(144)=1D0-VINT(142)
VINT(151)=0D0
VINT(152)=0D0
C...Initialize factors for PDF reshaping.
DO 230 JS=1,2
KFBEAM=MINT(10+JS)
KFABM=IABS(KFBEAM)
KFSBM=ISIGN(1,KFBEAM)
C...Zero flavour content of incoming beam particle.
KFIVAL(JS,1)=0
KFIVAL(JS,2)=0
KFIVAL(JS,3)=0
C...Flavour content of baryon.
IF(KFABM.GT.1000) THEN
KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
C...Flavour content of pi+-, K+-.
ELSEIF(KFABM.EQ.211) THEN
KFIVAL(JS,1)=KFSBM*2
KFIVAL(JS,2)=-KFSBM
ELSEIF(KFABM.EQ.321) THEN
KFIVAL(JS,1)=-KFSBM*3
KFIVAL(JS,2)=KFSBM*2
C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
ENDIF
C...Zero initial valence and companion content.
DO 200 IFL=-6,6
NVC(JS,IFL)=0
200 CONTINUE
C...Initiate listing of all incoming partons from two sides.
NMI(JS)=0
DO 210 I=MINT(84)+1,N
IF(K(I,3).EQ.MINT(83)+2+JS) THEN
IMI(JS,1,1)=I
IMI(JS,1,2)=0
ENDIF
210 CONTINUE
C...Decide whether quarks in hard scattering were valence or sea.
IFL=K(IMI(JS,1,1),2)
IF (IABS(IFL).GT.6) GOTO 230
C...Get PDFs at X and Q2 of the parton shower initiator for the
C...hard scattering.
X=VINT(140+JS)
IF(MSTP(61).GE.1) THEN
Q2=PARP(62)**2
ELSE
Q2=VINT(54)
ENDIF
C...Note: XPSVC = x*pdf.
MINT(30)=JS
CALL PYPDFU(KFBEAM,X,Q2,XPQ)
SEA=XPSVC(IFL,-1)
VAL=XPSVC(IFL,0)
C...Decide (Extra factor x cancels in the division).
RVCS=PYR(0)*(SEA+VAL)
IVNOW=1
220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
IVNOW=0
IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
& (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
ENDIF
IF(IVNOW.EQ.0) GOTO 220
C...Mark valence.
IMI(JS,1,2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
KFIVAL(JS,1)=IFL
KFIVAL(JS,2)=-IFL
ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
KFIVAL(JS,1)=IFL
IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
ENDIF
ENDIF
C...If sea, add opposite sign companion parton. Store X and I.
ELSE
NVC(JS,-IFL)=NVC(JS,-IFL)+1
XASSOC(JS,-IFL,NVC(JS,-IFL))=X
C...Set pointer to companion
IMI(JS,1,2)=-NVC(JS,-IFL)
ENDIF
230 CONTINUE
C...Update counter number of multiple interactions.
NMI(1)=1
NMI(2)=1
C...Set up starting values for iteration in xT2.
IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
& ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
& ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
& ISUBSV.NE.96)) THEN
XT2=(1D0-VINT(141))*(1D0-VINT(142))
ELSE
XT2=VINT(25)
IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
IF(ISET(ISUBSV).EQ.2)
& XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
ENDIF
IF(MSTP(82).LE.1) THEN
SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
& VINT(317)/(VINT(318)*VINT(320))
XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
ELSE
XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
& MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
ENDIF
VINT(63)=0D0
VINT(64)=0D0
C...Iterate downwards in xT2.
240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
XT2=0D0
GOTO 440
ELSEIF(MSTP(82).LE.1) THEN
XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
IF(XT2.LT.VINT(149)) GOTO 440
ELSE
IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
& LOG(PYR(0)))-VINT(149)
IF(XT2.LE.0D0) GOTO 440
XT2=MAX(0.01D0*VINT(149),XT2)
ENDIF
VINT(25)=XT2
C...Choose tau and y*. Calculate cos(theta-hat).
IF(PYR(0).LE.COEF(ISUB,1)) THEN
TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
ELSE
TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
ENDIF
VINT(21)=TAU
C...New: require shat > 1.
IF(TAU*VINT(2).LT.1D0) GOTO 240
CALL PYKLIM(2)
RYST=PYR(0)
MYST=1
IF(RYST.GT.COEF(ISUB,8)) MYST=2
IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
CALL PYKMAP(2,MYST,PYR(0))
VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
C...Check that x not used up. Accept or reject kinematical variables.
X1M=SQRT(TAU)*EXP(VINT(22))
X2M=SQRT(TAU)*EXP(-VINT(22))
IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
CALL PYSIGH(NCHN,SIGS)
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
C...Reset K, P and V vectors.
DO 260 I=N+1,N+4
DO 250 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
250 CONTINUE
260 CONTINUE
PT=0.5D0*VINT(1)*SQRT(XT2)
C...Choose flavour of reacting partons (and subprocess).
RSIGS=SIGS*PYR(0)
DO 270 ICHN=1,NCHN
KFL1=ISIG(ICHN,1)
KFL2=ISIG(ICHN,2)
ICONMI=ISIG(ICHN,3)
RSIGS=RSIGS-SIGH(ICHN)
IF(RSIGS.LE.0D0) GOTO 280
270 CONTINUE
C...Reassign to appropriate process codes.
280 ISUBMI=ICONMI/10
ICONMI=MOD(ICONMI,10)
C...Choose new quark flavour for annihilation graphs
IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
SH=TAU*VINT(2)
CALL PYWIDT(21,SH,WDTP,WDTE)
290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
DO 300 I=1,MDCY(21,3)
KFLF=KFDP(I+MDCY(21,2)-1,1)
RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
IF(RKFL.LE.0D0) GOTO 310
300 CONTINUE
310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
IF(KFLF.GE.4) GOTO 290
ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
KFLF=4
ICONMI=ICONMI-2
ELSEIF(ISUBMI.EQ.53) THEN
KFLF=5
ICONMI=ICONMI-4
ENDIF
ENDIF
C...Final state flavours and colour flow: default values
JS=1
KFL3=KFL1
KFL4=KFL2
KCC=20
KCS=ISIGN(1,KFL1)
IF(ISUBMI.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
KCC=ICONMI
IF(KFL1*KFL2.LT.0) KCC=KCC+2
ELSEIF(ISUBMI.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
KFL3=ISIGN(KFLF,KFL1)
KFL4=-KFL3
KCC=4
ELSEIF(ISUBMI.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
KFL3=21
KFL4=21
KCC=ICONMI+4
ELSEIF(ISUBMI.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
IF(KFL1.EQ.21) JS=2
KCC=ICONMI+6
IF(KFL1.EQ.21) KCC=KCC+2
IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
ELSEIF(ISUBMI.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
KCS=(-1)**INT(1.5D0+PYR(0))
KFL3=ISIGN(KFLF,KCS)
KFL4=-KFL3
KCC=ICONMI+10
ELSEIF(ISUBMI.EQ.68) THEN
C...g + g -> g + g; th arbitrary
KCC=ICONMI+12
KCS=(-1)**INT(1.5D0+PYR(0))
ENDIF
C...Store flavours of scattering.
MINT(13)=KFL1
MINT(14)=KFL2
MINT(15)=KFL1
MINT(16)=KFL2
MINT(21)=KFL3
MINT(22)=KFL4
C...Set flavours and mothers of scattering partons.
K(N+1,1)=14
K(N+2,1)=14
K(N+3,1)=3
K(N+4,1)=3
K(N+1,2)=KFL1
K(N+2,2)=KFL2
K(N+3,2)=KFL3
K(N+4,2)=KFL4
K(N+1,3)=MINT(83)+1
K(N+2,3)=MINT(83)+2
K(N+3,3)=N+1
K(N+4,3)=N+2
C...Store colour connection indices.
DO 320 J=1,2
JC=J
IF(KCS.EQ.-1) JC=3-J
IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
320 CONTINUE
C...Store incoming and outgoing partons in their CM-frame.
SHR=SQRT(TAU)*VINT(1)
P(N+1,3)=0.5D0*SHR
P(N+1,4)=0.5D0*SHR
P(N+2,3)=-0.5D0*SHR
P(N+2,4)=0.5D0*SHR
P(N+3,5)=PYMASS(K(N+3,2))
P(N+4,5)=PYMASS(K(N+4,2))
IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
P(N+4,4)=SHR-P(N+3,4)
P(N+4,3)=-P(N+3,3)
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
PHI=PARU(2)*PYR(0)
CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
C...Set up default values before showers.
MINT(31)=MINT(31)+1
IPU1=N+1
IPU2=N+2
IPU3=N+3
IPU4=N+4
VINT(141)=VINT(41)
VINT(142)=VINT(42)
N=N+4
C...Showering of initial state partons (optional).
C...Note: no showering of final state partons here; it comes later.
IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
MINT(51)=0
ALAMSV=PARJ(81)
PARJ(81)=PARP(72)
NSAV=N
DO 340 I=1,4
DO 330 J=1,5
KSAV(I,J)=K(N-4+I,J)
PSAV(I,J)=P(N-4+I,J)
330 CONTINUE
340 CONTINUE
CALL PYSSPA(IPU1,IPU2)
PARJ(81)=ALAMSV
C...If shower failed then restore to situation before shower.
IF(MINT(51).GE.1) THEN
N=NSAV
DO 360 I=1,4
DO 350 J=1,5
K(N-4+I,J)=KSAV(I,J)
P(N-4+I,J)=PSAV(I,J)
350 CONTINUE
360 CONTINUE
IPU1=N-3
IPU2=N-2
VINT(141)=VINT(41)
VINT(142)=VINT(42)
ENDIF
ENDIF
C...Keep track of loose colour ends and information on scattering.
370 IMI(1,MINT(31),1)=IPU1
IMI(2,MINT(31),1)=IPU2
IMI(1,MINT(31),2)=0
IMI(2,MINT(31),2)=0
XMI(1,MINT(31))=VINT(141)
XMI(2,MINT(31))=VINT(142)
PT2MI(MINT(31))=VINT(54)
IMISEP(MINT(31))=N
C...Decide whether quarks in last scattering were valence, companion or
C...sea.
DO 430 JS=1,2
KFBEAM=MINT(10+JS)
KFSBM=ISIGN(1,MINT(10+JS))
IFL=K(IMI(JS,MINT(31),1),2)
IMI(JS,MINT(31),2)=0
IF (IABS(IFL).GT.6) GOTO 430
C...Get PDFs at X and Q2 of the parton shower initiator for the
C...last scattering. At this point VINT(143:144) do not yet
C...include the scattered x values VINT(141:142).
X=VINT(140+JS)/VINT(142+JS)
IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
Q2=PARP(62)**2
ELSE
Q2=VINT(54)
ENDIF
C...Note: XPSVC = x*pdf.
MINT(30)=JS
CALL PYPDFU(KFBEAM,X,Q2,XPQ)
SEA=XPSVC(IFL,-1)
VAL=XPSVC(IFL,0)
CMP=0D0
DO 380 IVC=1,NVC(JS,IFL)
CMP=CMP+XPSVC(IFL,IVC)
380 CONTINUE
C...Decide (Extra factor x cancels in the dvision).
RVCS=PYR(0)*(SEA+VAL+CMP)
IVNOW=1
390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
IVNOW=0
IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
& (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
ELSE
DO 400 I1=1,NMI(JS)
IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
& IVNOW=IVNOW-1
400 CONTINUE
ENDIF
IF(IVNOW.EQ.0) GOTO 390
C...Mark valence.
IMI(JS,MINT(31),2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
IF(KFIVAL(JS,1).EQ.0) THEN
IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
KFIVAL(JS,1)=IFL
KFIVAL(JS,2)=-IFL
ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
KFIVAL(JS,1)=IFL
IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
ENDIF
ENDIF
ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
C...If sea, add opposite sign companion parton. Store X and I.
NVC(JS,-IFL)=NVC(JS,-IFL)+1
XASSOC(JS,-IFL,NVC(JS,-IFL))=X
C...Set pointer to companion
IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
ELSE
C...If companion, decide which one.
CMPSUM=VAL+SEA
ISEL=0
410 ISEL=ISEL+1
CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
C...Find original sea (anti-)quark:
IASSOC=0
DO 420 I1=1,NMI(JS)
IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
IF (-IMI(JS,I1,2).EQ.ISEL) THEN
IMI(JS,MINT(31),2)=IMI(JS,I1,1)
IMI(JS,I1,2)=IMI(JS,MINT(31),1)
ENDIF
420 CONTINUE
C...Change X to what associated companion had, so that the correct
C...amount of momentum can be subtracted from the companion sum below.
X=XASSOC(JS,IFL,ISEL)
C...Mark companion read.
XASSOC(JS,IFL,ISEL)=0D0
ENDIF
430 CONTINUE
C...Global statistics.
MINT(351)=MINT(351)+1
VINT(351)=VINT(351)+PT
IF (MINT(351).EQ.1) VINT(356)=PT
C...Update remaining energy and other counters.
IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
MINT(51)=1
RETURN
ENDIF
NMI(1)=NMI(1)+1
NMI(2)=NMI(2)+1
VINT(151)=VINT(151)+VINT(41)
VINT(152)=VINT(152)+VINT(42)
VINT(143)=VINT(143)-VINT(141)
VINT(144)=VINT(144)-VINT(142)
C...Iterate, with more interactions allowed.
IF(MINT(31).LT.240) GOTO 240
440 CONTINUE
C...Restore saved quantities for hardest interaction.
MINT(1)=ISUBSV
MINT(13)=M13SV
MINT(14)=M14SV
MINT(15)=M15SV
MINT(16)=M16SV
MINT(21)=M21SV
MINT(22)=M22SV
DO 450 J=11,80
VINT(J)=VINTSV(J)
450 CONTINUE
VINT(141)=V141SV
VINT(142)=V142SV
ENDIF
C...Format statements for printout.
5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
&'actions for MSTP(82) =',I2,' ******')
5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
&D9.2,' mb: rejected')
5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
&D9.2,' mb: accepted')
RETURN
END
C*********************************************************************
C...PYMIHK
C...Finds left-behind remnant flavour content and hooks up
C...the colour flow between the hard scattering and remnants
SUBROUTINE PYMIHK
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...The event record
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
C...Parameters
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of dangling ends
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
C...Local variables
PARAMETER (NERSIZ=4000)
COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
& ,MACCPT
COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
SAVE /PYCBLS/,/PYCTAG/
DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
& ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
DATA NERRPR/0/
SAVE NERRPR
FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1)
C...Set up error checkers
IBOOST=0
C...Initialize colour arrays: MCO (Original) and MCT (New)
DO 110 I=MINT(84)+1,NERSIZ
DO 100 JC=1,2
MCT(I,JC)=0
MCO(I,JC)=0
100 CONTINUE
C...Also zero colour tracing information, if existed.
IF (I.LE.N) THEN
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
ENDIF
110 CONTINUE
C...Initialize colour tag collapse arrays:
C...JCCO (Original) and JCCN (New).
DO 130 MG=MINT(84)+1,NERSIZ
DO 120 JC=1,2
JCCO(MG,JC)=0
JCCN(MG,JC)=0
120 CONTINUE
130 CONTINUE
C...Zero gluon insertion array
DO 150 IM=1,1000
DO 140 J=1,3
INSR(IM,J)=0
140 CONTINUE
150 CONTINUE
C...Compute hard scattering system rapidities
IF (MSTP(89).EQ.1) THEN
DO 160 IM=1,240
IF (IM.LE.MINT(31)) THEN
YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
ELSE
C...Set (unsigned) rapidity = 100 for beam remnant systems.
YMI(IM)=100D0
ENDIF
160 CONTINUE
ENDIF
C...Treat each side separately
DO 290 JS=1,2
C...Initialize side.
NG(JS)=0
JV=0
KFS=ISIGN(1,MINT(10+JS))
C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
IF(KFIVAL(JS,1).EQ.0) THEN
IF(MINT(10+JS).EQ.111) THEN
KFIVAL(JS,1)=INT(1.5D0+PYR(0))
KFIVAL(JS,2)=-KFIVAL(JS,1)
ELSEIF(MINT(10+JS).EQ.22) THEN
PYRKF=PYR(0)
KFIVAL(JS,1)=1
IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
KFIVAL(JS,2)=-KFIVAL(JS,1)
ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
IF(PYR(0).GT.0.5D0) THEN
KFIVAL(JS,1)=1
KFIVAL(JS,2)=-3
ELSE
KFIVAL(JS,1)=3
KFIVAL(JS,2)=-1
ENDIF
ENDIF
ENDIF
C...Initialize beam remnant sea and valence content flavour by flavour.
NVSUM(JS)=0
NBRTOT(JS)=0
DO 210 JFA=1,6
C...Count up original number of JFA valence quarks and antiquarks.
NVALQ=0
NVALQB=0
NSEA=0
DO 170 J=1,3
IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
170 CONTINUE
NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
C...Subtract kicked out valence and determine sea from flavour cons.
DO 180 IM=1,NMI(JS)
IFL = K(IMI(JS,IM,1),2)
IFA = IABS(IFL)
IFS = ISIGN(1,IFL)
IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
C...Subtract K.O. valence quark from remainder.
NVALQ=NVALQ-1
JV=NVSUM(JS)-NVALQ-NVALQB
IV(JS,JV)=IMI(JS,IM,1)
ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
C...Subtract K.O. valence antiquark from remainder.
NVALQB=NVALQB-1
JV=NVSUM(JS)-NVALQ-NVALQB
IV(JS,JV)=IMI(JS,IM,1)
ELSEIF (IFA.EQ.JFA) THEN
C...Outside sea without companion: add opposite sea flavour inside.
IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
ENDIF
180 CONTINUE
C...Check if space left in PYJETS for additional BR flavours
NFLSUM=IABS(NSEA)+NVALQ+NVALQB
NBRTOT(JS)=NBRTOT(JS)+NFLSUM
IF (N+NFLSUM+1.GT.MSTU(4)) THEN
CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
MINT(51)=1
RETURN
ENDIF
C...Add required val+sea content to beam remnant.
IF (NFLSUM.GT.0) THEN
DO 200 IA=1,NFLSUM
C...Insert beam remnant quark as p.t. symbolic parton in ER.
N=N+1
DO 190 IX=1,5
K(N,IX)=0
P(N,IX)=0D0
V(N,IX)=0D0
190 CONTINUE
K(N,1)=3
K(N,2)=ISIGN(JFA,NSEA)
IF (IA.LE.NVALQ) K(N,2)=JFA
IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
K(N,3)=MINT(83)+JS
C...Also update NMI, IMI, and IV arrays.
NMI(JS)=NMI(JS)+1
IMI(JS,NMI(JS),1)=N
IMI(JS,NMI(JS),2)=-1
IF (IA.LE.NVALQ+NVALQB) THEN
IMI(JS,NMI(JS),2)=0
JV=JV+1
IV(JS,JV)=IMI(JS,NMI(JS),1)
ENDIF
200 CONTINUE
ENDIF
210 CONTINUE
IM=0
220 IM=IM+1
IF (IM.LE.NMI(JS)) THEN
IF (K(IMI(JS,IM,1),2).EQ.21) THEN
NG(JS)=NG(JS)+1
C...Add fictitious parent gluons for companion pairs.
ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
C...Randomly assign companions to sea quarks which have none.
IF (IMI(JS,IM,2).LT.0) THEN
IMC=PYR(0)*NMI(JS)
230 IMC=MOD(IMC,NMI(JS))+1
IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
IF (IMI(JS,IMC,2).GE.0) GOTO 230
IMI(JS, IM,2) = IMI(JS,IMC,1)
IMI(JS,IMC,2) = IMI(JS, IM,1)
ENDIF
C...Add fictitious parent gluon
N=N+1
DO 240 IX=1,5
K(N,IX)=0
P(N,IX)=0D0
V(N,IX)=0D0
240 CONTINUE
K(N,1)=14
K(N,2)=21
K(N,3)=MINT(83)+JS
C...Set gluon (anti-)colour daughter pointers
K(N,4)=IMI(JS, IM,1)
K(N,5)=IMI(JS, IM,2)
C...Set quark (anti-)colour parent pointers
K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
C...Add gluon to IMI
NMI(JS)=NMI(JS)+1
IMI(JS,NMI(JS),1)=N
IMI(JS,NMI(JS),2)=0
ENDIF
GOTO 220
ENDIF
C...If incoming (anti-)baryon, insert inside (anti-)junction.
C...Set up initial v-v-j-v configuration. Otherwise set up
C...mesonic v-vbar configuration
IF (IABS(MINT(10+JS)).GT.1000) THEN
C...Determine junction type (1: B=1 2: B=-1)
ITJUNC(JS) = (3-KFS)/2
C...Insert junction.
N=N+1
DO 250 IX=1,5
K(N,IX)=0
P(N,IX)=0D0
V(N,IX)=0D0
250 CONTINUE
C...Set special junction codes:
K(N,1)=42
K(N,2)=88
C...Set parent to side.
K(N,3)=MINT(83)+JS
K(N,4)=ITJUNC(JS)*MSTU(5)
K(N,5)=0
C...Connect valence quarks to junction.
MOUT(JS)=0
MANTI=ITJUNC(JS)-1
C...Set (anti)colour mother = junction.
DO 260 JV=1,3
K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
& +MSTU(5)*N
C...Keep track of partons adjacent to junction:
JST(JS,JV)=IV(JS,JV)
260 CONTINUE
ELSE
C...Mesons: set up initial q-qbar topology
ITJUNC(JS)=0
IF (K(IV(JS,1),2).GT.0) THEN
IQ=IV(JS,1)
IQBAR=IV(JS,2)
ELSE
IQ=IV(JS,2)
IQBAR=IV(JS,1)
ENDIF
IV(JS,3)=0
JST(JS,1)=IQ
JST(JS,2)=IQBAR
JST(JS,3)=0
K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
C...Special for mesons. Insert gluon if BR empty.
IF (NBRTOT(JS).EQ.0) THEN
N=N+1
DO 270 IX=1,5
K(N,IX)=0
P(N,IX)=0D0
V(N,IX)=0D0
270 CONTINUE
K(N,1)=3
K(N,2)=21
K(N,3)=MINT(83)+JS
K(N,4)=0
K(N,5)=0
NBRTOT(JS)=1
NG(JS)=NG(JS)+1
C...Add gluon to IMI
NMI(JS)=NMI(JS)+1
IMI(JS,NMI(JS),1)=N
IMI(JS,NMI(JS),2)=0
ENDIF
MOUT(JS)=0
ENDIF
C...Count up number of valence quarks outside BR.
DO 280 JV=1,3
IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
& MOUT(JS)=MOUT(JS)+1
280 CONTINUE
290 CONTINUE
C...Now both sides have been prepared in an initial vvjv (baryonic) or
C...v(g)vbar (mesonic) configuration.
C...Create colour line tags starting from initiators.
NCT=0
DO 320 IM=1,MINT(31)
C...Consider each side in turn.
DO 310 JS=1,2
I1=IMI(JS,IM,1)
I2=IMI(3-JS,IM,1)
DO 300 JCS=4,5
IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
& GOTO 300
IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
KCS=JCS
CALL PYCTTR(I1,KCS,I2)
IF(MINT(51).NE.0) RETURN
300 CONTINUE
310 CONTINUE
320 CONTINUE
DO 340 JS=1,2
C...Create colour tags for beam remnant partons.
DO 330 IM=MINT(31)+1,NMI(JS)
IP=IMI(JS,IM,1)
IF (K(IP,2).NE.21) THEN
JC=(3-ISIGN(1,K(IP,2)))/2
IF (MCT(IP,JC).EQ.0) THEN
NCT=NCT+1
MCT(IP,JC)=NCT
ENDIF
ELSE
C...Gluons
ICD=K(IP,4)
IAD=K(IP,5)
IF (ICD.NE.0) THEN
C...Fictituous gluons just inherit from their quark daughters.
ICC=MCT(ICD,1)
IAC=MCT(IAD,2)
ELSE
C...Real beam remnant gluons get their own colours
ICC=NCT+1
IAC=NCT+2
NCT=NCT+2
ENDIF
MCT(IP,1)=ICC
MCT(IP,2)=IAC
ENDIF
330 CONTINUE
340 CONTINUE
C...Create colour tags for colour lines which are detached from the
C...initial state.
DO 360 MQGST=1,2
DO 350 I=MINT(84)+1,N
C...Look for coloured string endpoint, or (later) leftover gluon.
IF (K(I,1).NE.3) GOTO 350
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 350
KQ=KCHG(KC,2)
IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
C...Pick up loose string end with no previous tag.
KCS=4
IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
IF(MCT(I,KCS-3).NE.0) GOTO 350
CALL PYCTTR(I,KCS,I)
IF(MINT(51).NE.0) RETURN
350 CONTINUE
360 CONTINUE
C...Store original colour tags
DO 370 I=MINT(84)+1,N
MCO(I,1)=MCT(I,1)
MCO(I,2)=MCT(I,2)
370 CONTINUE
C...Iteratively add gluons to already existing string pieces, enforcing
C...various possible orderings, and rejecting insertions that would give
C...rise to singlet gluons.
C...<kappa tau> normalization.
RM0=1.5D0
MRETRY=0
PARP80=PARP(80)
C...Set up simplified kinematics.
C...Boost hard interaction systems.
IBOOST=IBOOST+1
DO 380 IM=1,MINT(31)
BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
380 CONTINUE
C...Assign preliminary beam remnant momenta.
DO 390 I=MINT(53)+1,N
JS=K(I,3)
P(I,1)=0D0
P(I,2)=0D0
IF (K(I,2).NE.88) THEN
P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
P(I,3)=P(I,4)
IF (JS.EQ.2) P(I,3)=-P(I,3)
ELSE
C...Junctions are wildcards for the present.
P(I,4)=0D0
P(I,3)=0D0
ENDIF
390 CONTINUE
C...Reset colour processing information.
400 DO 410 I=MINT(84)+1,N
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
410 CONTINUE
NCC=0
DO 430 JS=1,2
C...If meson, without gluon in BR, collapse q-qbar colour tags:
IF (ITJUNC(JS).EQ.0) THEN
JC1=MCT(JST(JS,1),1)
JC2=MCT(JST(JS,2),2)
NCC=NCC+1
JCCO(NCC,1)=MAX(JC1,JC2)
JCCO(NCC,2)=MIN(JC1,JC2)
C...Collapse colour tags in event record
DO 420 I=MINT(84)+1,N
IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
420 CONTINUE
ENDIF
430 CONTINUE
440 JS=1
IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
IF (NG(JS).GT.0) THEN
NOPT=0
RLOPT=1D9
C...Start at random gluon (optimizes speed for random attachments)
NMGL=0
IMGL=PYR(0)*NMI(JS)+1
450 IMGL=MOD(IMGL,NMI(JS))+1
NMGL=NMGL+1
C...Only loop through NMI once (with upper limit to save time)
IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
IGL = IMI(JS,IMGL,1)
C...If not gluon or if already connected, try next.
IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
& .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
C...Now loop through all possible insertions of this gluon.
NMP1=0
IMP1=PYR(0)*NMI(JS)+1
460 IMP1=MOD(IMP1,NMI(JS))+1
NMP1=NMP1+1
IF (IMP1.EQ.IMGL) GOTO 460
C...Only loop through NMI once (with upper limit to save time).
IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
IP1 = IMI(JS,IMP1,1)
C...Try both colour mother and colour anti-mother.
C...Randomly select which one to try first.
NANTI=0
MANTI=PYR(0)*2
470 MANTI=MOD(MANTI+1,2)
NANTI=NANTI+1
IF (NANTI.LE.2) THEN
IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
C...Reject if no appropriate mother (or if mother is fictitious
C...parent gluon.)
IF (IP2.LE.0) GOTO 470
IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
C...Also reject if this link has already been tried.
IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
C...Set flag to indicate that this link has now been tried for this
C...gluon. IP2 may be junction, which has several mothers.
K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
IF (K(IP2,2).NE.88) THEN
K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
ENDIF
C...JCG1: Original colour tag of gluon on IP1 side
C...JCG2: Original colour tag of gluon on IP2 side
C...JCP1: Original colour tag of IP1 on gluon side
C...JCP2: Original colour tag of IP2 on gluon side.
JCG1=MCO(IGL,2-MANTI)
JCG2=MCO(IGL,1+MANTI)
JCP1=MCO(IP1,1+MANTI)
JCP2=MCO(IP2,2-MANTI)
CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
C...Reject gluon attachments that give rise to singlet gluons.
IF (MACCPT.EQ.0) GOTO 470
C...Update colours
JCG1=MCT(IGL,2-MANTI)
JCG2=MCT(IGL,1+MANTI)
JCP1=MCT(IP1,1+MANTI)
JCP2=MCT(IP2,2-MANTI)
C...Select whether to accept this insertion
IF (MSTP(89).EQ.0) THEN
C...Random insertions: no measure.
RL=1D0
C...For random ordering, we want to suppress beam remnant breakups
C...already at this point.
IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
& .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
NMP1=0
NMGL=0
GOTO 470
ENDIF
ELSEIF (MSTP(89).EQ.1) THEN
C...Rapidity ordering:
C...YGL = Rapidity of gluon.
YGL=YMI(IMGL)
C...If fictitious gluon
IF (YGL.EQ.100D0) THEN
YGL=(3-2*JS)*100D0
IDA1=MOD(K(IGL,4),MSTU(5))
IDA2=MOD(K(IGL,5),MSTU(5))
DO 480 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
& THEN
IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
ENDIF
480 CONTINUE
ENDIF
C...YP1 = Rapidity IP1
YP1=YMI(IMP1)
C...If fictitious gluon
IF (YP1.EQ.100D0) THEN
YP1=(3-2*JS)*YP1
IDA1=MOD(K(IP1,4),MSTU(5))
IDA2=MOD(K(IP1,5),MSTU(5))
DO 490 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
& THEN
IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
ENDIF
490 CONTINUE
ENDIF
C...YP2 = Rapidity of mother system
IF (K(IP2,2).NE.88) THEN
DO 500 IMT=1,NMI(JS)
IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
500 CONTINUE
C...If fictitious gluon
IF (YP2.EQ.100D0) THEN
YP2=(3-2*JS)*YP2
IDA1=MOD(K(IP2,4),MSTU(5))
IDA2=MOD(K(IP2,5),MSTU(5))
DO 510 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
& ) THEN
IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
ENDIF
510 CONTINUE
ENDIF
C...Assign (arbitrarily) 100D0 to junction also
ELSE
YP2=(3-2*JS)*100D0
ENDIF
RL=ABS(YGL-YP1)+ABS(YGL-YP2)
ELSEIF (MSTP(89).EQ.2) THEN
C...Lambda ordering:
C...Compute lambda measure for this insertion.
RL=1D0
DO 520 IST=1,6
ISTR(IST)=0
520 CONTINUE
C...If IP2 is junction, not caught below.
IF (JCP2.EQ.0) THEN
ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
C...Anti-junction is colour endpoint et vv., always on JCG2.
ISTR(5-ITJU)=IP2
ENDIF
DO 530 I=MINT(84)+1,N
IF (K(I,1).LT.10) THEN
C...The new string pieces
IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
ENDIF
530 CONTINUE
C...Also identify junctions as string endpoints.
DO 540 I=MINT(84)+1,N
ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
C...Find partons adjacent to junctions.
IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
& .EQ.0) ISTR(2) = ICMO
IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
& .EQ.0) ISTR(4) = ICMO
ENDIF
IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
& .EQ.0) ISTR(1) = IAMO
IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
& .EQ.0) ISTR(3) = IAMO
ENDIF
540 CONTINUE
C...The old string piece
ISTR(5)=ISTR(1+2*MANTI)
ISTR(6)=ISTR(4-2*MANTI)
IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
& ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
C...If one or more of the colour tags for this connection is/are still
C...dangling, skip this attempt for the time being.
RL=1D6
ELSE
RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
& ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
RL=LOG(RL)
ENDIF
ENDIF
C...Allow some breadth to speed things up.
IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
NOPT=NOPT+1
ELSEIF (RL.GT.RLOPT) THEN
GOTO 470
ELSE
NOPT=1
RLOPT=RL
ENDIF
C...INSR(NOPT,1)=Gluon colour mother
C...INSR(NOPT,2)=Gluon
C...INSR(NOPT,3)=Gluon anticolour mother
IF (NOPT.GT.1000) GOTO 470
INSR(NOPT,1+2*MANTI)=IP2
INSR(NOPT,2)=IGL
INSR(NOPT,3-2*MANTI)=IP1
IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
ENDIF
IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
ENDIF
C...Reset link test information.
DO 550 I=MINT(84)+1,N
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
550 CONTINUE
IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
ENDIF
C...Now we have a list of best gluon insertions, none of which cause
C...singlets to arise. If list is empty, try again a few times. Note:
C...this should never happen if we have a meson with a gluon inserted
C...in the beam remnant, since that breaks up the colour line.
IF (NOPT.EQ.0) THEN
C...Abandon BR-g-BR suppression for retries. This is not serious, it
C...just means we happened to start with trying a bad sequence.
PARP80=1D0
IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
& .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
MRETRY=MRETRY+1
DO 590 JS=1,2
IF (ITJUNC(JS).NE.0) THEN
JST(JS,1)=IV(JS,1)
JST(JS,2)=IV(JS,2)
JST(JS,3)=IV(JS,3)
C...Reset valence quark parent pointers
DO 560 I=MINT(53)+1,N
IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
560 CONTINUE
MANTI=ITJUNC(JS)-1
C...Set (anti)colour mother = junction.
DO 570 JV=1,3
K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
& +MSTU(5)*IJU
570 CONTINUE
ELSE
C...Same for mesons. JST unchanged, so needn't be restored.
IQ=JST(JS,1)
IQBAR=JST(JS,2)
K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
ENDIF
C...Also reset gluon parent pointers.
NG(JS)=0
DO 580 IM=1,NMI(JS)
I=IMI(JS,IM,1)
IF (K(I,2).EQ.21) THEN
K(I,4)=MOD(K(I,4),MSTU(5))
K(I,5)=MOD(K(I,5),MSTU(5))
NG(JS)=NG(JS)+1
ENDIF
580 CONTINUE
590 CONTINUE
C...Reset colour tags
DO 600 I=MINT(84)+1,N
MCT(I,1)=MCO(I,1)
MCT(I,2)=MCO(I,2)
600 CONTINUE
GOTO 400
ELSE
IF(NERRPR.LT.5) THEN
NERRPR=NERRPR+1
CALL PYLIST(4)
CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
ENDIF
C...Kill event and start another.
MINT(51)=1
RETURN
ENDIF
ELSE
C...Select between insertions, suppressing insertions wholly in the BR.
IIN=PYR(0)*NOPT+1
610 IIN=MOD(IIN,NOPT)+1
IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
& .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
ENDIF
C...Now we know which gluon to insert where. Colour tags in JCCO and
C...colour connection information should be updated, NG(JS) should be
C...counted down, and a new loop performed if there are still gluons
C...left on any side.
ICM=INSR(IIN,1)
IACM=INSR(IIN,3)
IGL=INSR(IIN,2)
C...JCG : Original gluon colour tag
C...JCAG: Original gluon anticolour tag.
C...JCM : Original anticolour tag of gluon colour mother
C...JACM: Original colour tag of gluon anticolour mother
JCG=MCO(IGL,1)
JCM=MCO(ICM,2)
JACG=MCO(IGL,2)
JACM=MCO(IACM,1)
CALL PYMIHG(JACM,JACG,JCM,JCG)
IF (MACCPT.EQ.0) THEN
IF(NERRPR.LT.5) THEN
NERRPR=NERRPR+1
CALL PYLIST(4)
CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
ENDIF
C...Kill event and start another.
MINT(51)=1
RETURN
ELSE
C...If everything went fine, store new JCCN in JCCO.
NCC=NCC+1
DO 620 ICC=1,NCC
JCCO(ICC,1)=JCCN(ICC,1)
JCCO(ICC,2)=JCCN(ICC,2)
620 CONTINUE
ENDIF
C...One gluon attached is counted as equivalent to one end outside.
MOUT(JS)=1
C...Set IGL colour mother = ICM.
K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
C...Set ICM anticolour mother = IGL colour.
IF (K(ICM,2).NE.88) THEN
K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
ELSE
C...If ICM is junction, just update JST array for now.
DO 630 MSJ=1,3
IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
630 CONTINUE
ENDIF
C...Set IGL anticolour mother = IACM.
K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
C...Set IACM anticolour mother = IGL anticolour.
IF (K(IACM,2).NE.88) THEN
K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
ELSE
C...If IACM is junction, just update JST array for now.
DO 640 MSJ=1,3
IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
640 CONTINUE
ENDIF
C...Count down # unconnected gluons.
NG(JS)=NG(JS)-1
ENDIF
IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
DO 840 JS=1,2
C...Collapse fictitious gluons.
DO 670 IGL=MINT(53)+1,N
IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
& K(IGL,1).EQ.14) THEN
ICM=K(IGL,4)/MSTU(5)
IAM=K(IGL,5)/MSTU(5)
ICD=MOD(K(IGL,4),MSTU(5))
IAD=MOD(K(IGL,5),MSTU(5))
C...Set gluon daughters pointing to gluon mothers
K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
C...Set gluon mothers pointing to gluon daughters.
IF (K(ICM,2).NE.88) THEN
K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
ELSE
C...Special case: mother=junction. Just update JST array for now.
DO 650 MSJ=1,3
IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
650 CONTINUE
ENDIF
IF (K(IAM,2).NE.88) THEN
K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
ELSE
DO 660 MSJ=1,3
IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
660 CONTINUE
ENDIF
ENDIF
670 CONTINUE
C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
IM=NMI(JS)+1
680 IM=IM-1
IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
IF (IM.GT.MINT(31)) THEN
NMI(JS)=NMI(JS)-1
DO 690 IMR=IM,NMI(JS)
IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
690 CONTINUE
GOTO 680
ENDIF
C...Finally, connect junction.
IF (ITJUNC(JS).NE.0) THEN
DO 700 I=MINT(53)+1,N
IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
700 CONTINUE
C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
NBRJQ =0
NBRVQ =0
DO 720 MSJ=1,3
IDQ(MSJ)=0
C...Find jq with no glue inbetween inside beam remnant.
IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
& THEN
NBRJQ=NBRJQ+1
C...Set IDQ = -I if q non-valence and = +I if q valence.
IDQ(NBRJQ)=-JST(JS,MSJ)
DO 710 JV=1,3
IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
IDQ(NBRJQ)=JST(JS,MSJ)
NBRVQ=NBRVQ+1
ENDIF
710 CONTINUE
ENDIF
I12=MOD(MSJ+1,2)
I45=5
IF (MSJ.EQ.3) I45=4
K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
720 CONTINUE
C...Check if diquark can be formed.
IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
& .GE.1)) THEN
C...If there is less than 2 valence quarks connected to junction
C...and MSTP(88)>1, use random non-valence quarks to fill up.
IF (NBRVQ.LE.1) THEN
NDIQ=NBRVQ
730 JFLIP=NBRJQ*PYR(0)+1
IF (IDQ(JFLIP).LT.0) THEN
IDQ(JFLIP)=-IDQ(JFLIP)
NDIQ=NDIQ+1
ENDIF
IF (NDIQ.LE.1) GOTO 730
ENDIF
C...Place selected quarks first in IDQ, ordered in flavour.
DO 740 JDQ=1,3
IF (IDQ(JDQ).LE.0) THEN
ITEMP1 = IDQ(JDQ)
IDQ(JDQ)= IDQ(3)
IDQ(3) = -ITEMP1
IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
ITEMP1 = IDQ(1)
IDQ(1) = IDQ(2)
IDQ(2) = ITEMP1
ENDIF
ENDIF
740 CONTINUE
C...Choose diquark spin.
IF (NBRVQ.EQ.2) THEN
C...If the selected quarks are both valence, we may use SU(6) rules
C...to figure out which spin the diquark has, by a subdivision of the
C...original beam hadron into the selected diquark system plus a kicked
C...out quark, IKO.
JKO=6
DO 760 JDQ=1,2
DO 750 JV=1,3
IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
750 CONTINUE
760 CONTINUE
IKO=IV(JS,JKO)
CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
ELSE
C...If one or more of the selected quarks are not valence, we cannot use
C...SU(6) subdivisions of the original beam hadron. Instead, with the
C...flavours of the diquark already selected, we assume for now
C...50:50 spin-1:spin-0 (where spin-0 possible).
KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
IS=3
IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
& (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
KFDQ=KFDQ+ISIGN(IS,KFDQ)
ENDIF
C...Collapse diquark-j-quark system to baryon, if allowed and possible.
C...Note: third quark can per definition not also be valence,
C...therefore we can only do this if we are allowed to use sea quarks.
770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
NTRY=0
780 NTRY=NTRY+1
CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
GOTO 780
ELSEIF(NTRY.GT.100) THEN
C...If no baryon can be found, give up and form diquark.
IDQ(3)=0
GOTO 770
ELSE
C...Replace junction by baryon.
K(IJU,1)=1
K(IJU,2)=KFBAR
K(IJU,3)=MINT(83)+JS
K(IJU,4)=0
K(IJU,5)=0
P(IJU,5)=PYMASS(KFBAR)
DO 790 MSJ=1,3
C...Prepare removal of participating quarks from ER.
K(JST(JS,MSJ),1)=-1
790 CONTINUE
ENDIF
ELSE
C...If collapse to baryon not possible or not allowed, replace junction
C...by diquark. This way, collapsed gluons that were pointing at the
C...junction will now point (correctly) at diquark.
MANTI=ITJUNC(JS)-1
K(IJU,1)=3
K(IJU,2)=KFDQ
K(IJU,3)=MINT(83)+JS
K(IJU,4)=0
K(IJU,5)=0
DO 800 MSJ=1,3
IP=JST(JS,MSJ)
IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
K(IJU,4+MANTI)=0
K(IJU,5-MANTI)=IP*MSTU(5)
K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
& MSTU(5)*IJU
MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
ELSE
C...Prepare removal of participating quarks from ER.
K(IP,1)=-1
ENDIF
800 CONTINUE
ENDIF
C...Update so ER pointers to collapsed quarks
C...now go to collapsed object.
DO 820 I=MINT(84)+1,N
IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
& .K(I,1).GT.0) THEN
DO 810 ISID=4,5
IMO=K(I,ISID)/MSTU(5)
IDA=MOD(K(I,ISID),MSTU(5))
IF (IMO.GT.0) THEN
IF (K(IMO,1).EQ.-1) IMO=IJU
ENDIF
IF (IDA.GT.0) THEN
IF (K(IDA,1).EQ.-1) IDA=IJU
ENDIF
K(I,ISID)=IDA+MSTU(5)*IMO
810 CONTINUE
ENDIF
820 CONTINUE
ENDIF
ENDIF
C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
C...(this only happens for baryons, where we want to force the gluon
C...to sit next to the junction. Mesons handled above.)
IF (NBRTOT(JS).EQ.0) THEN
N=N+1
DO 830 IX=1,5
K(N,IX)=0
P(N,IX)=0D0
V(N,IX)=0D0
830 CONTINUE
IGL=N
K(IGL,1)=3
K(IGL,2)=21
K(IGL,3)=MINT(83)+JS
IF (ITJUNC(JS).NE.0) THEN
C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
JLEG=PYR(0)*NVSUM(JS)+1
I1=JST(JS,JLEG)
JST(JS,JLEG)=IGL
JCT=MCT(I1,ITJUNC(JS))
MCT(IGL,3-ITJUNC(JS))=JCT
NCT=NCT+1
MCT(IGL,ITJUNC(JS))=NCT
MANTI=ITJUNC(JS)-1
ELSE
C...Meson. Should not happen.
CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
IF(NERRPR.LT.5) THEN
WRITE(MSTU(11),*) 'This should not have been possible!'
CALL PYLIST(4)
NERRPR=NERRPR+1
ENDIF
MINT(51)=1
RETURN
ENDIF
I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
IF (K(I2,2).NE.88) THEN
K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
ELSE
IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
ELSE
K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
ENDIF
ENDIF
ENDIF
840 CONTINUE
C...Remove collapsed quarks and junctions from ER and update IMI.
CALL PYEDIT(11)
C...Also update beam remnant part of IMI.
NMI(1)=MINT(31)
NMI(2)=MINT(31)
DO 850 I=MINT(53)+1,N
IF (K(I,1).LE.0) GOTO 850
C...Restore BR quark/diquark/baryon pointers in IMI.
IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
JS=K(I,3)-MINT(83)
NMI(JS)=NMI(JS)+1
IMI(JS,NMI(JS),1)=I
IMI(JS,NMI(JS),2)=0
ENDIF
850 CONTINUE
C...Restore companion information from collapsed gluons.
DO 870 I=MINT(53)+1,N
IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
JS=K(I,3)-MINT(83)
JCD=MOD(K(I,4),MSTU(5))
JAD=MOD(K(I,5),MSTU(5))
DO 860 IM=1,NMI(JS)
IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
860 CONTINUE
IMI(JS,IMC,2)=IMI(JS,IMA,1)
IMI(JS,IMA,2)=IMI(JS,IMC,1)
ENDIF
870 CONTINUE
C...Renumber colour lines (since some have disappeared)
JCT=0
JCD=0
880 JCT=JCT+1
MFOUND=0
I=MINT(84)
890 I=I+1
IF (I.EQ.N+1) THEN
IF (MFOUND.EQ.0) JCD=JCD+1
ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
MCT(I,1)=JCT-JCD
MFOUND=1
ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
MCT(I,2)=JCT-JCD
MFOUND=1
ENDIF
IF (I.LE.N) GOTO 890
IF (JCT.LT.NCT) GOTO 880
NCT=JCT-JCD
C...Reset hard interaction subsystems to their CM frames.
IF (IBOOST.EQ.1) THEN
DO 900 IM=1,MINT(31)
BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
900 CONTINUE
C...Zero beam remnant longitudinal momenta and energies
DO 910 I=MINT(53)+1,N
P(I,3)=0D0
P(I,4)=0D0
910 CONTINUE
ELSE
CALL PYERRM(9
& ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
C...Kill event and start another.
MINT(51)=1
RETURN
ENDIF
9999 RETURN
END
C*********************************************************************
C...PYCTTR
C...Adapted from PYPREP.
C...Assigns LHA1 colour tags to coloured partons based on
C...K(I,4) and K(I,5) colour connection record.
C...KCS negative signifies that a previous tracing should be continued.
C...(in case the tag to be continued is empty, the routine exits)
C...Starts at I and ends at I or IEND.
C...Special considerations for systems with junctions.
C...Special: if IEND=-1, means trace this parton to its color partner,
C... then exit. If no partner found, exit with 0.
SUBROUTINE PYCTTR(I,KCS,IEND)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
COMMON/PYCTAG/NCT,MCT(4000,2)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
DATA NERRPR/0/
SAVE NERRPR
C...Skip if parton not existing or does not have KCS
IF (K(I,1).LE.0) GOTO 120
KC=PYCOMP(K(I,2))
IF (KC.EQ.0) GOTO 120
KQ=KCHG(KC,2)
IF (KQ.EQ.0) GOTO 120
IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
& GOTO 120
IF (KCS.GT.0) THEN
NCT=NCT+1
C...Set colour tag of first parton.
MCT(I,KCS-3)=NCT
NCS=NCT
ELSE
KCS=-KCS
NCS=MCT(I,KCS-3)
IF (NCS.EQ.0) GOTO 120
ENDIF
IA=I
NSTP=0
100 NSTP=NSTP+1
IF(NSTP.GT.4*N) THEN
CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
GOTO 120
ENDIF
C...Finished if reached final-state triplet.
IF(K(IA,1).EQ.3) THEN
IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
ENDIF
C...Also finished if reached junction.
IF(K(IA,1).EQ.42) THEN
GOTO 120
ENDIF
C...GOTO next parton in colour space.
110 IB=IA
C...If IB's KCS daughter not traced and exists, goto KCS daughter.
IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
& .NE.0) THEN
IA=MOD(K(IB,KCS),MSTU(5))
K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
MREV=0
ELSE
C...If KCS mother traced or KCS mother nonexistent, switch colour.
IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
& MSTU(5)).EQ.0) THEN
KCS=9-KCS
NCT=NCT+1
NCS=NCT
C...Assign new colour tag on other side of old parton.
MCT(IB,KCS-3)=NCT
ENDIF
C...Goto (new) KCS mother, set mother traced tag
IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
MREV=1
ENDIF
IF(IA.LE.0.OR.IA.GT.N) THEN
IF (IEND.EQ.-1) THEN
IEND=0
GOTO 120
ENDIF
CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
IF(NERRPR.LT.5) THEN
write(*,*) 'began at ',I
write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
& ' NCS=',NCS,' MREV=',MREV
CALL PYLIST(4)
NERRPR=NERRPR+1
ENDIF
MINT(51)=1
RETURN
ENDIF
IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
& MSTU(5)).EQ.IB) THEN
IF(MREV.EQ.1) KCS=9-KCS
IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
C...Set KSC mother traced tag for IA
K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
ELSE
IF(MREV.EQ.0) KCS=9-KCS
IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
C...Set KCS daughter traced tag for IA
K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
ENDIF
C...Assign new colour tag
MCT(IA,KCS-3)=NCS
C...Finish if IEND=-1 and found final-state color partner
IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
IEND=IA
GOTO 120
ENDIF
IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
120 RETURN
END
*********************************************************************
C...PYMIHG
C...Collapse JCP1 and connecting tags to JCG1.
C...Collapse JCP2 and connecting tags to JCG2.
SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...The event record
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
C...Parameters
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYINT1/
C...Local variables
COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
COMMON /PYCTAG/NCT,MCT(4000,2)
SAVE /PYCBLS/,/PYCTAG/
C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
C...in temporary tag collapse array JCCN. Only break up one connection.
MACCPT=1
MCLPS=0
DO 100 ICC=1,NCC
JCCN(ICC,1)=JCCO(ICC,1)
JCCN(ICC,2)=JCCO(ICC,2)
C...If there was a mother, it was previously connected to JCP1.
C...Should be changed to JCP2.
IF (MCLPS.EQ.0) THEN
IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
& ,JCP2)) THEN
JCCN(ICC,1)=MAX(JCG2,JCP2)
JCCN(ICC,2)=MIN(JCG2,JCP2)
MCLPS=1
ENDIF
ENDIF
100 CONTINUE
C...Also collapse colours on JCP1 side of JCG1
IF (JCP1.NE.0) THEN
JCCN(NCC+1,1)=MAX(JCP1,JCG1)
JCCN(NCC+1,2)=MIN(JCP1,JCG1)
ELSE
JCCN(NCC+1,1)=MAX(JCP2,JCG2)
JCCN(NCC+1,2)=MIN(JCP2,JCG2)
ENDIF
C...Initialize event record colour tag array MCT array to MCO.
DO 110 I=MINT(84)+1,N
MCT(I,1)=MCO(I,1)
MCT(I,2)=MCO(I,2)
110 CONTINUE
C...Collapse tags:
C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
DO 160 IS=1,4
C...Skip if junction.
IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
C...Define starting point in tag space.
C...JCA = previous tag
C...JCO = present tag
C...JCN = new tag
IF (MOD(IS,2).EQ.1) THEN
JCO=JCP1
JCN=JCG1
JCALL=JCG1
ELSEIF (MOD(IS,2).EQ.0) THEN
JCO=JCP2
JCN=JCG2
JCALL=JCG2
ENDIF
ITRACE=0
120 ITRACE=ITRACE+1
IF (ITRACE.GT.1000) THEN
C...NB: Proper error message should be defined here.
CALL PYERRM(14
& ,'(PYMIHG:) Inf loop when collapsing colours.')
MINT(57)=MINT(57)+1
MINT(51)=1
RETURN
ENDIF
C...Collapse all JCN tags to JCALL
DO 130 I=MINT(84)+1,N
IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
130 CONTINUE
C...IS = 1,2: first step forward. IS = 3,4: first step backward.
IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
JCA=JCN
JCN=JCO
ELSE
JCA=JCO
JCO=JCN
ENDIF
C...If possible, step from JCO to new tag JCN not equal to JCA.
DO 140 ICC=1,NCC+1
IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
& JCCN(ICC,2)
IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
& JCCN(ICC,1)
140 CONTINUE
C...Iterate if new colour was arrived at, but don't go in circles.
IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
C...Change all JCN tags in MCO to JCALL in MCT.
DO 150 I=MINT(84)+1,N
IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
C...If gluon and colour tag = anticolour tag (and not = 0) try again.
IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
& .NE.0) MACCPT=0
150 CONTINUE
160 CONTINUE
DO 200 JCL=NCT,1,-1
JCA=0
JCN=JCL
170 JCO=JCN
DO 180 ICC=1,NCC+1
IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
& =JCCN(ICC,2)
IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
& =JCCN(ICC,1)
180 CONTINUE
C...Overpaint all JCN with JCL
IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
DO 190 I=MINT(84)+1,N
IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
C...If gluon and colour tag = anticolour tag (and not = 0) try again.
IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
& .NE.0) MACCPT=0
190 CONTINUE
JCA=JCO
GOTO 170
ENDIF
200 CONTINUE
RETURN
END
C*********************************************************************
C...PYMIRM
C...Picks primordial kT and shares longitudinal momentum among
C...beam remnants.
SUBROUTINE PYMIRM
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...The event record
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
C...Parameters
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
COMMON/PYCTAG/NCT,MCT(4000,2)
C...The common block of dangling ends
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
C...Local variables
DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
C...W(I,J)| J=0 | 1 | 2 |
C... I=0 | Wrem**2 | W+ | W- |
C... 1 | W1**2 | W1+ | W1- |
C... 2 | W2**2 | W2+ | W2- |
C...4-product
FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
C...Tentative parametrization of <kT> as a function of Q.
SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
C...Lambda kinematic function.
FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
C...Beginning and end of beam remnant partons
NOUT=MINT(53)
ISUB=MINT(1)
C...Loopback point if kinematic choices gives impossible configuration.
NTRY=0
100 NTRY=NTRY+1
C...Assign kT values on each side separately.
DO 180 JS=1,2
C...First zero all kT on this side. Skip if no kT to generate.
DO 110 IM=1,NMI(JS)
P(IMI(JS,IM,1),1)=0D0
P(IMI(JS,IM,1),2)=0D0
110 CONTINUE
IF(MSTP(91).LE.0) GOTO 180
C...Now assign kT to each (non-collapsed) parton in IMI.
DO 170 IM=1,NMI(JS)
I=IMI(JS,IM,1)
C...Select kT according to truncated gaussian or 1/kt6 tails.
C...For first interaction, either use rms width = PARP(91) or fitted.
IF (IM.EQ.1) THEN
SIGMA=PARP(91)
IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
Q=SQRT(PT2MI(IM))
SIGMA=SIGPT(Q)
ENDIF
ELSE
C...For subsequent interactions and BR partons use fragmentation width.
SIGMA=PARJ(21)
ENDIF
PHI=PARU(2)*PYR(0)
PT=0D0
IF(NTRY.LE.100) THEN
111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
PT=GETPT(Q,SIGMA)
PTX=PT*COS(PHI)
PTY=PT*SIN(PHI)
ELSEIF (MSTP(91).EQ.2) THEN
CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
& 'available, using MSTP(91)=1.')
CALL PYGIVE('MSTP(91)=1')
GOTO 111
ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
C...Use distribution with kt**6 tails, rms width = PARP(91).
EPS=SQRT(3D0/2D0)*SIGMA
C...Generate PTX and PTY separately, each propto 1/KT**6
DO 119 IXY=1,2
C...Decide which interval to try
112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
IF (PYR(0).LT.P12) THEN
C...Use flat approx with accept/reject up to EPS.
PT=PYR(0)*EPS
WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
IF (PYR(0).GT.WT) GOTO 112
ELSE
C...Above EPS, use 1/kt**6 approx with accept/reject.
PT=EPS/(PYR(0)**(1D0/5D0))
WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
IF (PYR(0).GT.WT) GOTO 112
ENDIF
MSIGN=1
IF (PYR(0).GT.0.5D0) MSIGN=-1
IF (IXY.EQ.1) PTX=MSIGN*PT
IF (IXY.EQ.2) PTY=MSIGN*PT
119 CONTINUE
ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
ENDIF
C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
PT=SQRT(PTX**2+PTY**2)
WT=1D0
IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
PTX=PTX*WT
PTY=PTY*WT
PT=SQRT(PTX**2+PTY**2)
ENDIF
P(I,1)=P(I,1)+PTX
P(I,2)=P(I,2)+PTY
C...Compensation kicks, with varying degree of local anticorrelations.
MCORR=MSTP(90)
IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
PTCX=-PTX/(NMI(JS)-1)
PTCY=-PTY/(NMI(JS)-1)
IF(ISUB.EQ.95) THEN
PTCX=-PTX/(NMI(JS)-2)
PTCY=-PTY/(NMI(JS)-2)
ENDIF
DO 120 IMC=1,NMI(JS)
IF (IMC.EQ.IM) GOTO 120
IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
120 CONTINUE
ELSEIF (MCORR.GE.1) THEN
DO 140 MSID=4,5
NNXT(MSID-3)=0
C...Count up # of neighbours on either side
IMO=I
130 IMO=K(IMO,MSID)/MSTU(5)
IF (IMO.EQ.0) GOTO 140
NNXT(MSID-3)=NNXT(MSID-3)+1
C...Stop at quarks and junctions
IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
140 CONTINUE
C...How should compensation be shared when unequal numbers on the
C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
NSUM=NNXT(1)+NNXT(2)
T1=0
DO 160 MSID=4,5
C...Total momentum to be compensated on this side
IF (NNXT(MSID-3).EQ.0) GOTO 160
PTCX=-(NNXT(MSID-3)*PTX)/NSUM
PTCY=-(NNXT(MSID-3)*PTY)/NSUM
C...RS: compensation supression factor as we go out from parton I.
C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
C...since (for now) MSTP(90) provides enough variability.
RS=0.5D0
FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
IMO=I
150 IDA=IMO
IMO=K(IMO,MSID)/MSTU(5)
IF (IMO.EQ.0) GOTO 160
FAC=FAC*RS
IF (K(IMO,2).NE.88) THEN
P(IMO,1)=P(IMO,1)+FAC*PTCX
P(IMO,2)=P(IMO,2)+FAC*PTCY
IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
C...If we reach junction, divide out the kT that would have been
C...assigned to the junction on each of its other legs.
ELSE
L1=MOD(K(IMO,4),MSTU(5))
L2=K(IMO,5)/MSTU(5)
L3=MOD(K(IMO,5),MSTU(5))
P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
ENDIF
160 CONTINUE
ENDIF
170 CONTINUE
C...End assignment of kT values to initiators and remnants.
180 CONTINUE
C...Check kinematics constraints for non-BR partons.
DO 190 IM=1,MINT(31)
SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
& +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
IF(NTRY.GE.100) THEN
C...Kill this event and start another.
CALL PYERRM(1,
& '(PYMIRM:) No consistent (x,kT) sets found')
MINT(51)=1
RETURN
ENDIF
GOTO 100
ENDIF
190 CONTINUE
C...Calculate W+ and W- available for combined remnant system.
W(0,1)=VINT(1)
W(0,2)=VINT(1)
DO 200 IM=1,MINT(31)
PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
& +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
200 CONTINUE
C...Also store Wrem**2 = W+ * W-
W(0,0)=W(0,1)*W(0,2)
IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
IF(NTRY.GE.100) THEN
C...Kill this event and start another.
CALL PYERRM(1,
& '(PYMIRM:) Negative beam remnant mass squared unavoidable')
MINT(51)=1
RETURN
ENDIF
GOTO 100
ENDIF
C...Assign unscaled x values to partons/hadrons in each of the
C...beam remnants and calculate unscaled W+ and W- from them.
NTRYX=0
210 NTRYX=NTRYX+1
DO 280 JS=1,2
W(JS,1)=0D0
W(JS,2)=0D0
DO 270 IM=MINT(31)+1,NMI(JS)
I=IMI(JS,IM,1)
KF=K(I,2)
KFA=IABS(KF)
ICOMP=IMI(JS,IM,2)
C...Skip collapsed gluons and junctions. Reset.
IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
IF (KFA.EQ.88) GOTO 270
X=0D0
IVALQ(1)=0
IVALQ(2)=0
ICOMQ(1)=0
ICOMQ(2)=0
C...If gluon then only beam remnant, so takes all.
IF(KFA.EQ.21) THEN
X=1D0
C...If valence quark then use parametrized valence distribution.
ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
IVALQ(1)=KF
C...If companion quark then derive from companion x.
ELSEIF(KFA.LE.6) THEN
ICOMQ(1)=ICOMP
C...If valence diquark then use two parametrized valence distributions.
ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
& ICOMP.EQ.0) THEN
IVALQ(1)=ISIGN(KFA/1000,KF)
IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
C...If valence+sea diquark then combine valence + companion choices.
ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
& ICOMP.LT.MSTU(5)) THEN
IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
ELSE
IVALQ(1)=ISIGN(KFA/1000,KF)
ENDIF
ICOMQ(1)=ICOMP
C...Extra code: workaround for diquark made out of two sea
C...quarks, but where not (yet) ICOMP > MSTU(5).
DO 220 IM1=1,MINT(31)
IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
ICOMQ(2)=IMI(JS,IM1,1)
IVALQ(1)=0
ENDIF
220 CONTINUE
C...If sea diquark then sum of two derived from companion x.
ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
ICOMQ(1)=MOD(ICOMP,MSTU(5))
ICOMQ(2)=ICOMP/MSTU(5)
C...If meson or baryon then use fragmentation function.
C...Somewhat arbitrary split into old and new flavour, but OK normally.
ELSE
KFL3=MOD(KFA/10,10)
IF(MOD(KFA/1000,10).EQ.0) THEN
KFL1=MOD(KFA/100,10)
ELSE
KFL1=MOD(KFA,10000)-10*KFL3-1
IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
& MOD(KFA,10).EQ.2) KFL1=KFL1+2
ENDIF
PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
CALL PYZDIS(KFL1,KFL3,PR,X)
ENDIF
DO 260 IQ=1,2
C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
C...In other baryons combine u and d from proton appropriately.
IF(IVALQ(IQ).NE.0) THEN
NVAL=0
IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
C...Meson.
IF(KFIVAL(JS,3).EQ.0) THEN
MDU=0
C...Baryon with three identical quarks: mix u and d forms.
ELSEIF(NVAL.EQ.3) THEN
MDU=INT(PYR(0)+5D0/3D0)
C...Baryon, one of two identical quarks: u form.
ELSEIF(NVAL.EQ.2) THEN
MDU=2
C...Baryon with two identical quarks, but not the one picked: d form.
ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
& KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
MDU=1
C...Baryon with three nonidentical quarks: mix u and d forms.
ELSE
MDU=INT(PYR(0)+5D0/3D0)
ENDIF
XPOW=0.8D0
IF(MDU.EQ.1) XPOW=3.5D0
IF(MDU.EQ.2) XPOW=2D0
230 XX=PYR(0)**2
IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
X=X+XX
ENDIF
C...Calculation of x of companion quark.
IF(ICOMQ(IQ).NE.0) THEN
XCOMP=1D-4
DO 240 IM1=1,MINT(31)
IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
240 CONTINUE
NPOW=MAX(0,MIN(4,MSTP(87)))
250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
& (XCOMP**2+XX**2)/(XCOMP+XX)**2
IF(CORR.LT.PYR(0)) GOTO 250
X=X+XX
ENDIF
260 CONTINUE
C...Optionally enchance x of composite systems (e.g. diquarks)
IF (KFA.GT.100) X=PARP(79)*X
C...Store x. Also calculate light cone energies of each system.
XMI(JS,IM)=X
W(JS,JS)=W(JS,JS)+X
W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
270 CONTINUE
W(JS,JS)=W(JS,JS)*W(0,JS)
W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
W(JS,0)=W(JS,1)*W(JS,2)
280 CONTINUE
C...Check W1 W2 < Wrem (can be done before rescaling, since W
C...insensitive to global rescalings of the BR x values).
IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
& THEN
GOTO 210
ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
GOTO 100
ELSEIF (NTRYX.GT.100) THEN
CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
MINT(57)=MINT(57)+1
MINT(51)=1
RETURN
ENDIF
C...Compute x rescaling factors
COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
IF (R1.LT.0.OR.R2.LT.0) THEN
CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
MINT(57)=MINT(57)+1
MINT(51)=1
ENDIF
C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
W(1,1)=W(1,1)*R1
W(1,2)=W(1,2)/R1
W(2,1)=W(2,1)/R2
W(2,2)=W(2,2)*R2
C...Rescale BR x values.
DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
XMI(1,IM)=XMI(1,IM)*R1
XMI(2,IM)=XMI(2,IM)*R2
290 CONTINUE
C...Now we have a consistent set of x and kT values.
C...First set up the initiators and their daughters correctly.
DO 300 IM=1,MINT(31)
I1=IMI(1,IM,1)
I2=IMI(2,IM,1)
ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
& (P(I1,2)+P(I2,2))**2
PT12=P(I1,1)**2+P(I1,2)**2
PT22=P(I2,1)**2+P(I2,2)**2
C...p_z
P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
P(I2,3)=-P(I1,3)
C...Energies (masses should be zero at this stage)
P(I1,4)=SQRT(PT12+P(I1,3)**2)
P(I2,4)=SQRT(PT22+P(I2,3)**2)
C...Transverse 12 system initiator velocity:
VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
C...Boost to overall initiator system rest frame
CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
C...Compute phi,theta coordinates of I1 and rotate z axis.
PHI=PYANGL(P(I1,1),P(I1,2))
THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
IMIN=IMISEP(IM-1)+1
C...(include documentation lines if MI = 1)
IF (IM.EQ.1) IMIN=MINT(83)+5
IMAX=IMISEP(IM)
C...Rotate entire system in phi
CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
C...Only rotate 12 system in theta
CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
C...Now boost entire system back to LAB
VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
300 CONTINUE
C...For the beam remnant partons/hadrons, we only need to set pz and E.
DO 320 JS=1,2
DO 310 IM=MINT(31)+1,NMI(JS)
I=IMI(JS,IM,1)
C...Skip collapsed gluons and junctions.
IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
IF (KFA.EQ.88) GOTO 310
RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
IF (JS.EQ.2) P(I,3)=-P(I,3)
310 CONTINUE
320 CONTINUE
C...Documentation lines
DO 340 JS=1,2
IN=MINT(83)+JS+2
IO=IMI(JS,1,1)
K(IN,1)=21
K(IN,2)=K(IO,2)
K(IN,3)=MINT(83)+JS
K(IN,4)=0
K(IN,5)=0
DO 330 J=1,5
P(IN,J)=P(IO,J)
V(IN,J)=V(IO,J)
330 CONTINUE
MCT(IN,1)=MCT(IO,1)
MCT(IN,2)=MCT(IO,2)
340 CONTINUE
C...Final state colour reconnections.
IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
C...Number of colour tags for which a recoupling will be tried.
NTOT=NCT
C...Number of recouplings to try
MINT(34)=0
NRECP=0
NITER=0
350 NRECP=MINT(34)
NITER=NITER+1
IITER=0
360 IITER=IITER+1
IF (IITER.LE.PARP(78)*NTOT) THEN
C...Select two colour tags at random
C...NB: jj strings do not have colour tags assigned to them,
C...thus they are as yet not affected by anything done here.
JCT=PYR(0)*NCT+1
KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
IJ1=0
IJ2=0
IK1=0
IK2=0
C...Find final state partons with this (anti)colour
DO 370 I=MINT(84)+1,N
IF (K(I,1).EQ.3) THEN
IF (MCT(I,1).EQ.JCT) IJ1=I
IF (MCT(I,2).EQ.JCT) IJ2=I
IF (MCT(I,1).EQ.KCT) IK1=I
IF (MCT(I,2).EQ.KCT) IK2=I
ENDIF
370 CONTINUE
C...Only consider recouplings not involving junctions for now.
IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
MCT(IJ2,2)=KCT
MCT(IK2,2)=JCT
C...Count up number of reconnections
MINT(34)=MINT(34)+1
ENDIF
IF (MINT(34).LE.1000) THEN
GOTO 360
ELSE
CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
GOTO 380
ENDIF
ENDIF
IF (NRECP.LT.MINT(34)) GOTO 350
C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
380 MINT(33)=1
RETURN
END
C*********************************************************************
C...PYFSCR
C...Performs colour annealing.
C...MSTP(95) : CR Type
C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
C... = 2 : Type I(no gg loops); hadron-hadron only
C... = 3 : Type I(no gg loops); all beams
C... = 4 : Type II(gg loops) ; hadron-hadron only
C... = 5 : Type II(gg loops) ; all beams
C... = 6 : Type S ; hadron-hadron only
C... = 7 : Type S ; all beams
C... = 8 : Type P ; hadron-hadron only
C... = 9 : Type P ; all beams
C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
C...Type S is driven by starting only from free triplets, not octets.
C...Type P is also driven by free triplets, but the reconnect probability
C...is computed from the string density per unit rapidity, where the axis
C...with respect to which the rapidity is computed is the Thrust axis of the
C...event.
C...A string piece remains unchanged with probability
C... PKEEP = (1-PARP(78))**N
C...This scaling corresponds to each string piece having to go through
C...N other ones, each with probability PARP(78) for reconnection.
C...For types I, II, and S, N is chosen simply as the number of multiple
C...interactions, for a rough scaling with the general level of activity.
C...For type P, N is chosen to be the number of string pieces in a given
C...interval of rapidity (minus one, since the string doesn't reconnect
C...with itself), and the reconnect probability is interpreted as the
C...probability per unit rapidity.
C...It also also possible to apply a dampening factor to the CR strength,
C...using PARP(77), which will cause reconnections among high-pT string
C...pieces to be suppressed.
SUBROUTINE PYFSCR(IP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
COMMON/PYCTAG/NCT,MCT(4000,2)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
&/PYPARS/
C...MCN: Temporary storage of new colour tags
INTEGER MCN(4000,2)
C...Arrays for storing color strings
PARAMETER (NBINY=100)
INTEGER ICR(4000),MSCR(4000)
INTEGER IOPT(4000), NSTRY(NBINY)
DOUBLE PRECISION RLOPTC(4000)
C...Function to give four-product.
FOUR(I,J)=P(I,4)*P(J,4)
& -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
C...Check valid range of MSTP(95), local copy
IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
MSTP95=MOD(MSTP(95),10)
C...Set whether CR allowed inside resonance systems or not
C...(not implemented yet)
C MRESCR=1
C IF (MSTP(95).GE.10) MRESCR=0
C...Check whether colour tags already defined
IF (MINT(33).EQ.0) THEN
C...Erase any existing colour tags for this event
DO 100 I=1,N
MCT(I,1)=0
MCT(I,2)=0
100 CONTINUE
C...Create colour tags for this event
DO 120 I=1,N
IF (K(I,1).EQ.3) THEN
DO 110 KCS=4,5
KCSIN=KCS
IF (MCT(I,KCSIN-3).EQ.0) THEN
CALL PYCTTR(I,KCSIN,I)
ENDIF
110 CONTINUE
ENDIF
120 CONTINUE
C...Instruct PYPREP to use colour tags
MINT(33)=1
ENDIF
C...For MSTP(95) even, only apply to hadron-hadron
KA1=IABS(MINT(11))
KA2=IABS(MINT(12))
IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
C...Initialize new tag array (but do not delete old yet)
LCT=NCT
DO 130 I=MAX(1,IP),N
MCN(I,1)=0
MCN(I,2)=0
130 CONTINUE
C...For Paquis type, determine thrust axis (default along Z axis)
TX=0D0
TY=0D0
TZ=1D0
IF (MSTP95.GE.8) THEN
CALL PYTHRU(THRDUM,OBLDUM)
TX = P(N+1,1)
TY = P(N+1,2)
TZ = P(N+1,3)
ENDIF
C...For each final-state dipole, check whether string should be
C...preserved.
NCR=0
IA=0
IC=0
RAPMAX=0.0
ICTMIN=NCT
DO 150 ICT=1,NCT
IA=0
IC=0
DO 140 I=MAX(1,IP),N
IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
140 CONTINUE
IF (IC.NE.0.AND.IA.NE.0) THEN
C...Save smallest NCT value so far
ICTMIN = MIN(ICTMIN,ICT)
C...For Paquis algorithm, just store all string pieces for now
IF (MSTP95.GE.8) THEN
C... Add coloured parton
NCR=NCR+1
ICR(NCR)=IC
MSCR(NCR)=1
IOPT(NCR)=0
C... Store rapidity (along Thrust axis) in RLOPT for the time being
C... Add pion mass headroom to energy for this calculation
EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
C... Add anti-coloured parton
NCR = NCR+1
ICR(NCR) = IA
MSCR(NCR) = 2
IOPT(NCR) = 0
C... Store rapidity (along Thrust axis) in RLOPT for the time being
EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
C... Keep track of largest endpoint "rapidity"
RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
ELSE
CRMODF=1D0
C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
C... (so far ignores the possibility that the whole "muck" may be moving.)
IF (PARP(77).GT.0D0) THEN
PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
IF (KA1.LT.100.AND.KA2.LT.100) THEN
P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
ELSE
P2STR = 3D0/2D0 * PT2STR
ENDIF
RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
C... Estimate number of particles ~ log(M2), cut off at 1.
RLOGM2=MAX(1D0,LOG(RM2STR))
P2AVG=P2STR/RLOGM2
C... Supress reconnection probability by 1/(1+P77*P2AVG)
CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
ENDIF
PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
IF (PYR(0).LE.PKEEP) THEN
LCT=LCT+1
MCN(IC,1)=LCT
MCN(IA,2)=LCT
ELSE
C... Add coloured parton
NCR=NCR+1
ICR(NCR)=IC
MSCR(NCR)=1
IOPT(NCR)=0
RLOPTC(NCR)=1D19
C... Add anti-coloured parton
NCR=NCR+1
ICR(NCR)=IA
MSCR(NCR)=2
IOPT(NCR)=0
RLOPTC(NCR)=1D19
ENDIF
ENDIF
ENDIF
150 CONTINUE
C...PAQUIS TYPE
IF (MSTP95.GE.8) THEN
C... For Paquis type, make "histogram" of string densities along thrust axis
RAPMIN = -RAPMAX
DRAP = 2*RAPMAX/(1D0*NBINY)
C... Explicitly zero histogram bin content
DO 147 IBINY=1,NBINY
NSTRY(IBINY)=0
147 CONTINUE
DO 152 ISTR=1,NCR-1,2
IC = ICR(ISTR)
IA = ICR(ISTR+1)
Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
DO 153 IBINY=1,NBINY
YBINLO = RAPMIN + (IBINY-1)*DRAP
C... If bin inside string piece, add 1 in this bin
C... (Strictly speaking: if it starts before midpoint and ends after midpoint)
IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
& NSTRY(IBINY) = NSTRY(IBINY) + 1
153 CONTINUE
152 CONTINUE
C... Loop over pieces to find individual reconnect probability
DO 167 IS=1,NCR-1,2
DNSUM = 0D0
DNAVG = 0D0
C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
C...Make sure integer bin numbers lie inside proper range
IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
C...(also smaller than DRAP if a one-unit wide piece is stretched
C... over 2 bins, thus making the computation more accurate)
DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
C... Decide whether to suppress reconnections in high-pT string pieces
CRMODF = 1D0
IF (PARP(77).GT.0D0) THEN
C... Total string piece energy, momentum squared, and components
EES = P(ICR(IS),4) + P(ICR(IS+1),4)
PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
& + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
& + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ
& + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
PTTS = SQRT(PPS2 - PZTS**2)
C... Mass of string piece in units of mpi (at least 1)
RMPI2 = 0.135D0
RM2STR = MAX(RMPI2,EES**2 - PPS2)
C... Estimate number of pions ~ log(M2) (at least 1)
RNPI = LOG(RM2STR/RMPI2)+1D0
PT2AVG = (PTTS / RNPI)**2
C... Supress reconnection probability by 1/(1+P77*P2AVG)
CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
ENDIF
PKEEP = 1.0
DO 178 IBINY=IBINLO,IBINHI
C DNSUM = DNSUM + 1D0
DNOVL = MAX(0,NSTRY(IBINY)-1)
PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
178 CONTINUE
C DNAVG = DNAVG / DNSUM
C... If keeping string piece, save
IF (PYR(0).LE.PKEEP) THEN
LCT = LCT+1
MCN(ICR(IS),1)=LCT
MCN(ICR(IS+1),2)=LCT
ENDIF
167 CONTINUE
ENDIF
C...Skip if there is only one possibility
IF (NCR.LE.2) THEN
GOTO 9999
ENDIF
C...Reorder, so ordered in I (in order to correspond to old algorithm)
NLOOP=0
151 NLOOP=NLOOP+1
MORD=1
DO 155 IC1=1,NCR-1
I1=ICR(IC1)
I2=ICR(IC1+1)
IF (I1.GT.I2) THEN
IT=I1
MST=MSCR(IC1)
ICR(IC1)=I2
MSCR(IC1)=MSCR(IC1+1)
ICR(IC1+1)=IT
MSCR(IC1+1)=MST
MORD=0
ENDIF
155 CONTINUE
C...Max do 1000 reordering loops
IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
C...PS: 03 May 2010
C...For Seattle and Paquis types, check if there is a dangling tag
C...Needed for special case when entire reconnected state was one or
C...more gluon loops in original topology in which case these CR
C...algorithms need to be told they shouldn't look for a dangling tag.
M3FREE=0
IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
DO 157 IC1=1,NCR
I1=ICR(IC1)
C...Color charge
MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
IF (MCI.EQ.2) THEN
IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
ENDIF
157 CONTINUE
ENDIF
C...Loop over CR partons
C...(Ignore junctions for now.)
NLOOP=0
160 NLOOP=NLOOP+1
RLMAX=0D0
ICRMAX=0
C...Loop over coloured partons
DO 230 IC1=1,NCR
C...Retrieve parton Event Record index and Colour Side
I=ICR(IC1)
MSI=MSCR(IC1)
C...Skip already connected partons
IF (MCN(I,MSI).NE.0) GOTO 230
C...Shorthand for colour charge
MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
C...For Seattle algorithm, only start from partons with one dangling
C...colour tag (unless there aren't any, cf. M3FREE above.)
IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0
& .AND.M3FREE.EQ.1) THEN
GOTO 230
ENDIF
ENDIF
C...Retrieve saved optimal partner
IO=IOPT(IC1)
IF (IO.NE.0) THEN
C...Reject saved optimal partner if latter is now connected
C...(Also reject if using model S1, since saved partner may
C...now give rise to gg loop.)
IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
IOPT(IC1)=0
RLOPTC(IC1)=1D19
ENDIF
ENDIF
RLOPT=RLOPTC(IC1)
C...Search for new optimal partner if necessary
IF (IOPT(IC1).EQ.0) THEN
MBROPT=0
MGGOPT=0
RLOPT=1D19
C...Loop over partons you can connect to
DO 210 IC2=1,NCR
J=ICR(IC2)
MSJ=MSCR(IC2)
C...Skip if already connected
IF (MCN(J,MSJ).NE.0) GOTO 210
C...Skip if this not colour-anticolour pair
IF (MSI.EQ.MSJ) GOTO 210
C...And do not let gluons connect to themselves
IF (I.EQ.J) GOTO 210
C...Suppress direct connections between partons in same Beam Remnant
MBRSTR=0
IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
& MBRSTR=1
C...Shorthand for colour charge
MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
C...Check for gluon loops
MGGSTR=0
IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
& MCN(I,2).NE.0) MGGSTR=1
ENDIF
C...Save connection with smallest lambda measure
RL=FOUR(I,J)
C...If best so far was a BR string and this is not, also save.
C...If best so far was a gg string and this is not, also save.
C...NB: this is not fool-proof. If the algorithm finds a BR or gg
C...string with a small Lambda measure as the last step, this connection
C...will be saved regardless of whether other possibilities existed.
C...I.e., there should really be a check whether another possibility has
C...already been found, but since these models are now actively in use
C...and uncertainties are anyway large, the algorithm is left as it is.
C...(correction --> Pythia 8 ?)
IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
& .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
& .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
C...Paquis type: fix problem above
MPAQ = 0
IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
ENDIF
IF (MPAQ.EQ.0) THEN
RLOPT=RL
RLOPTC(IC1)=RLOPT
IOPT(IC1)=J
MBROPT=MBRSTR
MGGOPT=MGGSTR
ENDIF
ENDIF
210 CONTINUE
ENDIF
IF (IOPT(IC1).NE.0) THEN
C...Save pair with largest RLOPT so far
IF (RLOPT.GE.RLMAX) THEN
ICRMAX=IC1
RLMAX=RLOPT
ENDIF
ENDIF
230 CONTINUE
C...Save and iterate
ICMAX=0
IF (ICRMAX.GT.0) THEN
LCT=LCT+1
ILMAX=ICR(ICRMAX)
JLMAX=IOPT(ICRMAX)
ICMAX=MSCR(ICRMAX)
JCMAX=3-ICMAX
MCN(ILMAX,ICMAX)=LCT
MCN(JLMAX,JCMAX)=LCT
IF (NLOOP.LE.2*(N-IP)) THEN
GOTO 160
ELSE
CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
CALL PYSTOP(11)
ENDIF
ELSE
C...Save and exit. First check for leftover gluon(s)
DO 260 I=MAX(1,IP),N
C...Check colour charge
MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
C...Decide where to put left-over gluon (minimal insertion)
ICMAX=0
RLMAX=1D19
C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
DO 250 KCT=ICTMIN,LCT
IC=0
IA=0
DO 240 IT=MAX(1,IP),N
IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
IF (MCN(IT,1).EQ.KCT) IC=IT
IF (MCN(IT,2).EQ.KCT) IA=IT
240 CONTINUE
C...Skip if this color tag no longer present in event record
IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250
RL=FOUR(IC,I)*FOUR(IA,I)
IF (RL.LT.RLMAX) THEN
RLMAX=RL
ICMAX=IC
IAMAX=IA
ENDIF
250 CONTINUE
LCT=LCT+1
MCN(I,1)=MCN(ICMAX,1)
MCN(I,2)=LCT
MCN(ICMAX,1)=LCT
ENDIF
260 CONTINUE
C...Here we need to loop over entire event.
DO 270 IZ=MAX(1,IP),N
C...Do not erase parton shower colour history
IF (K(IZ,1).NE.3) GOTO 270
C...Check colour charge
MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
IF (MCI.EQ.0) GOTO 270
IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
270 CONTINUE
ENDIF
9999 RETURN
END
C*********************************************************************
C...PYDIFF
C...Handles diffractive and elastic scattering.
SUBROUTINE PYDIFF
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
C...Reset K, P and V vectors. Store incoming particles.
DO 110 JT=1,MSTP(126)+10
I=MINT(83)+JT
DO 100 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
100 CONTINUE
110 CONTINUE
N=MINT(84)
MINT(3)=0
MINT(21)=0
MINT(22)=0
MINT(23)=0
MINT(24)=0
MINT(4)=4
DO 130 JT=1,2
I=MINT(83)+JT
K(I,1)=21
K(I,2)=MINT(10+JT)
DO 120 J=1,5
P(I,J)=VINT(285+5*JT+J)
120 CONTINUE
130 CONTINUE
MINT(6)=2
C...Subprocess; kinematics.
SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
PZ=SQRT(SQLAM)/(2D0*VINT(1))
DO 200 JT=1,2
I=MINT(83)+JT
PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
KFH=MINT(102+JT)
C...Elastically scattered particle. (Except elastic GVMD states.)
IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
& MINT(106+JT).NE.3)) THEN
N=N+1
K(N,1)=1
K(N,2)=KFH
K(N,3)=I+2
P(N,3)=PZ*(-1)**(JT+1)
P(N,4)=PE
P(N,5)=SQRT(VINT(62+JT))
C...Decay rho from elastic scattering of gamma with sin**2(theta)
C...distribution of decay products (in rho rest frame).
IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
NSAV=N
DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
P(N,3)=0D0
P(N,4)=P(N,5)
CALL PYDECY(NSAV)
IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
140 CTHE=2D0*PYR(0)-1D0
IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
ENDIF
CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
ENDIF
C...Diffracted particle: low-mass system to two particles.
ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
N=N+2
K(N-1,1)=1
K(N,1)=1
K(N-1,3)=I+2
K(N,3)=I+2
PMMAS=SQRT(VINT(62+JT))
NTRY=0
150 NTRY=NTRY+1
IF(NTRY.LT.20) THEN
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
CALL PYSPLI(KFH,21,KFL1,KFL2)
CALL PYKFDI(KFL1,0,KFL3,KF1)
IF(KF1.EQ.0) GOTO 150
CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
IF(KF2.EQ.0) GOTO 150
ELSE
KF1=KFH
KF2=111
ENDIF
PM1=PYMASS(KF1)
PM2=PYMASS(KF2)
IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
K(N-1,2)=KF1
K(N,2)=KF2
P(N-1,5)=PM1
P(N,5)=PM2
PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
& 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
P(N-1,3)=PZP
P(N,3)=-PZP
P(N-1,4)=SQRT(PM1**2+PZP**2)
P(N,4)=SQRT(PM2**2+PZP**2)
CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
& 0D0,0D0,0D0)
DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
C...Diffracted particle: valence quark kicked out.
ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
& PARP(101))) THEN
N=N+2
K(N-1,1)=2
K(N,1)=1
K(N-1,3)=I+2
K(N,3)=I+2
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
P(N-1,5)=PYMASS(K(N-1,2))
P(N,5)=PYMASS(K(N,2))
SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
& 4D0*P(N-1,5)**2*P(N,5)**2
P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
& P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
C...Diffracted particle: gluon kicked out.
ELSE
N=N+3
K(N-2,1)=2
K(N-1,1)=2
K(N,1)=1
K(N-2,3)=I+2
K(N-1,3)=I+2
K(N,3)=I+2
MINT(105)=MINT(102+JT)
MINT(109)=MINT(106+JT)
CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
K(N-1,2)=21
P(N-2,5)=PYMASS(K(N-2,2))
P(N-1,5)=0D0
P(N,5)=PYMASS(K(N,2))
C...Energy distribution for particle into two jets.
160 IMB=1
IF(MOD(KFH/1000,10).NE.0) IMB=2
CHIK=PARP(92+2*IMB)
IF(MSTP(92).LE.1) THEN
IF(IMB.EQ.1) CHI=PYR(0)
IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
ELSEIF(MSTP(92).EQ.2) THEN
CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
ELSEIF(MSTP(92).EQ.3) THEN
CUT=2D0*0.3D0/VINT(1)
170 CHI=PYR(0)**2
IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
& PYR(0)) GOTO 170
ELSEIF(MSTP(92).EQ.4) THEN
CUT=2D0*0.3D0/VINT(1)
CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
180 CHIR=CUT*CUTR**PYR(0)
CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
ELSE
CUT=2D0*0.3D0/VINT(1)
CUTA=CUT**(1D0-PARP(98))
CUTB=(1D0+CUT)**(1D0-PARP(98))
190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
& (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
ENDIF
IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
& VINT(62+JT)) GOTO 160
SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
& (2D0*VINT(62+JT))
PEI=SQRT(PZI**2+SQM)
PQQP=(1D0-CHI)*(PEI+PZI)
P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
P(N-1,3)=P(N-1,4)*(-1)**JT
P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
ENDIF
C...Documentation lines.
K(I+2,1)=21
IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
& MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
K(I+2,3)=I
P(I+2,3)=PZ*(-1)**(JT+1)
P(I+2,4)=PE
P(I+2,5)=SQRT(VINT(62+JT))
200 CONTINUE
C...Rotate outgoing partons/particles using cos(theta).
IF(VINT(23).LT.0.9D0) THEN
CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
ELSE
CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
ENDIF
RETURN
END
C*********************************************************************
C...PYDISG
C...Set up a DIS process as gamma* + f -> f, with beam remnant
C...and showering added consecutively. Photon flux by the PYGAGA
C...routine (if at all).
SUBROUTINE PYDISG
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION PMS(4)
C...Choice of subprocess, number of documentation lines
IDOC=7
MINT(3)=IDOC-6
MINT(4)=IDOC
IPU1=MINT(84)+1
IPU2=MINT(84)+2
IPU3=MINT(84)+3
ISIDE=1
IF(MINT(107).EQ.4) ISIDE=2
C...Reset K, P and V vectors. Store incoming particles
DO 110 JT=1,MSTP(126)+20
I=MINT(83)+JT
DO 100 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
100 CONTINUE
110 CONTINUE
DO 130 JT=1,2
I=MINT(83)+JT
K(I,1)=21
K(I,2)=MINT(10+JT)
DO 120 J=1,5
P(I,J)=VINT(285+5*JT+J)
120 CONTINUE
130 CONTINUE
MINT(6)=2
C...Store incoming partons in hadronic CM-frame
DO 140 JT=1,2
I=MINT(84)+JT
K(I,1)=14
K(I,2)=MINT(14+JT)
K(I,3)=MINT(83)+2+JT
140 CONTINUE
IF(MINT(15).EQ.22) THEN
P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
P(MINT(84)+1,5)=-SQRT(VINT(307))
P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
KFRES=MINT(16)
ISIDE=2
ELSE
P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
P(MINT(84)+1,5)=-SQRT(VINT(308))
KFRES=MINT(15)
ISIDE=1
ENDIF
SIDESG=(-1D0)**(ISIDE-1)
C...Copy incoming partons to documentation lines.
DO 170 JT=1,2
I1=MINT(83)+4+JT
I2=MINT(84)+JT
K(I1,1)=21
K(I1,2)=K(I2,2)
K(I1,3)=I1-2
DO 150 J=1,5
P(I1,J)=P(I2,J)
150 CONTINUE
C...Second copy for partons before ISR shower, since no such.
I1=MINT(83)+2+JT
K(I1,1)=21
K(I1,2)=K(I2,2)
K(I1,3)=I1-2
DO 160 J=1,5
P(I1,J)=P(I2,J)
160 CONTINUE
170 CONTINUE
C...Define initial partons.
NTRY=0
180 NTRY=NTRY+1
IF(NTRY.GT.100) THEN
MINT(51)=1
RETURN
ENDIF
C...Scattered quark in hadronic CM frame.
I=MINT(83)+7
K(IPU3,1)=3
K(IPU3,2)=KFRES
K(IPU3,3)=I
P(IPU3,5)=PYMASS(KFRES)
P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
P(IPU3,5)=0D0
K(I,1)=21
K(I,2)=KFRES
K(I,3)=MINT(83)+4+ISIDE
P(I,3)=P(IPU3,3)
P(I,4)=P(IPU3,4)
P(I,5)=P(IPU3,5)
N=IPU3
MINT(21)=KFRES
MINT(22)=0
C...No primordial kT, or chosen according to truncated Gaussian or
C...exponential, or (for photon) predetermined or power law.
190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
IF(MSTP(91).LE.0) THEN
PT=0D0
ELSEIF(MSTP(91).EQ.1) THEN
PT=PARP(91)*SQRT(-LOG(PYR(0)))
ELSE
RPT1=PYR(0)
RPT2=PYR(0)
PT=-PARP(92)*LOG(RPT1*RPT2)
ENDIF
IF(PT.GT.PARP(93)) GOTO 190
ELSEIF(MINT(106+ISIDE).EQ.3) THEN
PTA=SQRT(VINT(282+ISIDE))
PTB=0D0
IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
PTB=PARP(99)*SQRT(-LOG(PYR(0)))
ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
RPT1=PYR(0)
RPT2=PYR(0)
PTB=-PARP(99)*LOG(RPT1*RPT2)
ENDIF
IF(PTB.GT.PARP(100)) GOTO 190
PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
IF(MSTP(93).LE.0) THEN
PT=0D0
ELSEIF(MSTP(93).EQ.1) THEN
PT=PARP(99)*SQRT(-LOG(PYR(0)))
ELSEIF(MSTP(93).EQ.2) THEN
RPT1=PYR(0)
RPT2=PYR(0)
PT=-PARP(99)*LOG(RPT1*RPT2)
ELSEIF(MSTP(93).EQ.3) THEN
HA=PARP(99)**2
HB=PARP(100)**2
PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
ELSE
HA=PARP(99)**2
HB=PARP(100)**2
IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
ENDIF
IF(PT.GT.PARP(100)) GOTO 190
ELSE
PT=0D0
ENDIF
VINT(156+ISIDE)=PT
PHI=PARU(2)*PYR(0)
P(IPU3,1)=PT*COS(PHI)
P(IPU3,2)=PT*SIN(PHI)
P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
PCP=P(IPU3,4)+ABS(P(IPU3,3))
C...Find one or two beam remnants.
MINT(105)=MINT(102+ISIDE)
MINT(109)=MINT(106+ISIDE)
CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
IF(MINT(51).NE.0) THEN
MINT(51)=0
GOTO 180
ENDIF
C...Store first remnant parton, with colour info and kinematics.
I=N+1
K(I,1)=1
K(I,2)=KFLSP
K(I,3)=MINT(83)+ISIDE
P(I,5)=PYMASS(K(I,2))
KCOL=KCHG(PYCOMP(KFLSP),2)
IF(KCOL.NE.0) THEN
K(I,1)=3
KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
K(I,KFLS+3)=MSTU(5)*IPU3
K(IPU3,6-KFLS)=MSTU(5)*I
ICOLR=I
ENDIF
IF(KFLCH.EQ.0) THEN
P(I,1)=-P(IPU3,1)
P(I,2)=-P(IPU3,2)
PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
P(I,3)=-P(IPU3,3)
P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
PRP=P(I,4)+ABS(P(I,3))
C...When extra remnant parton or hadron: store extra remnant.
ELSE
I=I+1
K(I,1)=1
K(I,2)=KFLCH
K(I,3)=MINT(83)+ISIDE
P(I,5)=PYMASS(K(I,2))
KCOL=KCHG(PYCOMP(KFLCH),2)
IF(KCOL.NE.0) THEN
K(I,1)=3
KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
K(I,KFLS+3)=MSTU(5)*IPU3
K(IPU3,6-KFLS)=MSTU(5)*I
ICOLR=I
ENDIF
C...Relative transverse momentum when two remnants.
LOOP=0
200 LOOP=LOOP+1
CALL PYPTDI(1,P(I-1,1),P(I-1,2))
P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
P(I,1)=-P(IPU3,1)-P(I-1,1)
P(I,2)=-P(IPU3,2)-P(I-1,2)
PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
C...Relative distribution of energy for particle into jet plus particle.
IMB=1
IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
IF(MSTP(94).LE.1) THEN
IF(IMB.EQ.1) CHI=PYR(0)
IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
ELSEIF(MSTP(94).EQ.2) THEN
CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
ELSEIF(MSTP(94).EQ.3) THEN
CALL PYZDIS(1,0,PMS(4),ZZ)
CHI=ZZ
ELSE
CALL PYZDIS(1000,0,PMS(4),ZZ)
CHI=ZZ
ENDIF
C...Construct total transverse mass; reject if too large.
CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
IF(LOOP.LT.10) GOTO 200
GOTO 180
ENDIF
VINT(158+ISIDE)=CHI
C...Subdivide longitudinal momentum according to value selected above.
PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
PW1=(1D0-CHI)*PRP
P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
PW2=CHI*PRP
P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
ENDIF
N=I
C...Boost current and remnant systems to correct frame.
IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
&(2D0*VINT(1)*PCP)
DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
&(2D0*VINT(1)*PRP)
DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
C...Let current quark shower; recoil but no showering by colour partner.
QMAX=2D0*SQRT(VINT(309-ISIDE))
MSTJ48=MSTJ(48)
MSTJ(48)=1
PARJ86=PARJ(86)
PARJ(86)=0D0
IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
MSTJ(48)=MSTJ48
PARJ(86)=PARJ86
RETURN
END
C*********************************************************************
C...PYDOCU
C...Handles the documentation of the process in MSTI and PARI,
C...and also computes cross-sections based on accumulated statistics.
SUBROUTINE PYDOCU
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
&/PYINT5/
C...Calculate Monte Carlo estimates of cross-sections.
ISUB=MINT(1)
IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
NGEN(0,3)=NGEN(0,3)+1
XSEC(0,3)=0D0
DO 100 I=1,500
IF(I.EQ.96.OR.I.EQ.97) THEN
XSEC(I,3)=0D0
ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
& I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
& DBLE(NGEN(96,2)))
ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
& DBLE(NGEN(96,2)))
ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
XSEC(I,3)=0D0
ELSEIF(NGEN(I,2).EQ.0) THEN
XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
& DBLE(NGEN(0,2)))
ELSE
XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
& DBLE(NGEN(I,2)))
ENDIF
XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
100 CONTINUE
C...Rescale to known low-pT cross-section for standard QCD processes.
IF(MSUB(95).EQ.1) THEN
XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
& XSEC(68,3)+XSEC(95,3)
XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
FAC=XSECW/XSECH
XSEC(11,3)=FAC*XSEC(11,3)
XSEC(12,3)=FAC*XSEC(12,3)
XSEC(13,3)=FAC*XSEC(13,3)
XSEC(28,3)=FAC*XSEC(28,3)
XSEC(53,3)=FAC*XSEC(53,3)
XSEC(68,3)=FAC*XSEC(68,3)
XSEC(95,3)=FAC*XSEC(95,3)
XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
ENDIF
ENDIF
C...Save information for gamma-p and gamma-gamma.
IF(MINT(121).GT.1) THEN
IGA=MINT(122)
CALL PYSAVE(2,IGA)
CALL PYSAVE(5,0)
ENDIF
C...Reset information on hard interaction.
DO 110 J=1,200
MSTI(J)=0
PARI(J)=0D0
110 CONTINUE
C...Copy integer valued information from MINT into MSTI.
DO 120 J=1,32
MSTI(J)=MINT(J)
120 CONTINUE
IF(MINT(121).GT.1) MSTI(9)=MINT(122)
C...Store cross-section variables in PARI.
PARI(1)=XSEC(0,3)
PARI(2)=XSEC(0,3)/MINT(5)
PARI(7)=VINT(97)
PARI(9)=VINT(99)
PARI(10)=VINT(100)
VINT(98)=VINT(98)+VINT(100)
IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
C...Store kinematics variables in PARI.
PARI(11)=VINT(1)
PARI(12)=VINT(2)
IF(ISUB.NE.95) THEN
DO 130 J=13,26
PARI(J)=VINT(30+J)
130 CONTINUE
PARI(29)=VINT(39)
PARI(30)=VINT(40)
PARI(31)=VINT(141)
PARI(32)=VINT(142)
PARI(33)=VINT(41)
PARI(34)=VINT(42)
PARI(35)=PARI(33)-PARI(34)
PARI(36)=VINT(21)
PARI(37)=VINT(22)
PARI(38)=VINT(26)
PARI(39)=VINT(157)
PARI(40)=VINT(158)
PARI(41)=VINT(23)
PARI(42)=2D0*VINT(47)/VINT(1)
ENDIF
C...Store information on scattered partons in PARI.
IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
DO 140 IS=7,8
I=MINT(IS)
PARI(36+IS)=P(I,3)/VINT(1)
PARI(38+IS)=P(I,4)/VINT(1)
PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
& SQRT(PR),1D20)),P(I,3))
PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
& SQRT(PR),1D20)),P(I,3))
PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
PARI(48+IS)=PYANGL(P(I,1),P(I,2))
140 CONTINUE
ENDIF
C...Store sum up transverse and longitudinal momenta.
PARI(65)=2D0*PARI(17)
IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
DO 150 I=MSTP(126)+1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
PT=SQRT(P(I,1)**2+P(I,2)**2)
PARI(69)=PARI(69)+PT
IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
150 CONTINUE
PARI(67)=PARI(68)
PARI(71)=VINT(151)
PARI(72)=VINT(152)
PARI(73)=VINT(151)
PARI(74)=VINT(152)
ELSE
PARI(66)=PARI(65)
PARI(69)=PARI(65)
ENDIF
C...Store various other pieces of information into PARI.
PARI(61)=VINT(148)
PARI(75)=VINT(155)
PARI(76)=VINT(156)
PARI(77)=VINT(159)
PARI(78)=VINT(160)
PARI(81)=VINT(138)
C...Store information on lepton -> lepton + gamma in PYGAGA.
MSTI(71)=MINT(141)
MSTI(72)=MINT(142)
PARI(101)=VINT(301)
PARI(102)=VINT(302)
DO 160 I=103,114
PARI(I)=VINT(I+202)
160 CONTINUE
C...Set information for PYTABU.
IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
MSTU(161)=MINT(21)
MSTU(162)=0
ELSEIF(ISET(ISUB).EQ.5) THEN
MSTU(161)=MINT(23)
MSTU(162)=0
ELSE
MSTU(161)=MINT(21)
MSTU(162)=MINT(22)
ENDIF
RETURN
END
C*********************************************************************
C...PYFRAM
C...Performs transformations between different coordinate frames.
SUBROUTINE PYFRAM(IFRAME)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Check that transformation can and should be done.
IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
&MINT(91).EQ.1)) THEN
IF(IFRAME.EQ.MINT(6)) RETURN
ELSE
WRITE(MSTU(11),5000) IFRAME,MINT(6)
RETURN
ENDIF
IF(MINT(6).EQ.1) THEN
C...Transform from fixed target or user specified frame to
C...overall CM frame.
CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
ELSEIF(MINT(6).EQ.3) THEN
C...Transform from hadronic CM frame in DIS to overall CM frame.
CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
& -VINT(225))
ENDIF
IF(IFRAME.EQ.1) THEN
C...Transform from overall CM frame to fixed target or user specified
C...frame.
CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
ELSEIF(IFRAME.EQ.3) THEN
C...Transform from overall CM frame to hadronic CM frame in DIS.
CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
ENDIF
C...Set information about new frame.
MINT(6)=IFRAME
MSTI(6)=IFRAME
5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
&'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
&1X,I5)
RETURN
END
C*********************************************************************
C...PYWIDT
C...Calculates full and partial widths of resonances.
SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
C...Local arrays and saved variables.
COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
&WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
C...UED: equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
PARAMETER(KKFLMI=451,KKFLMA=475)
DIMENSION CHIDEL(3), IUEDPR(25)
DIMENSION IUEDEQ(KKFLMA),MUED(2)
COMMON/SW1/SW21,CW21
DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
& 6100001,6100002,6100003,6100004,6100005,6100006,
& 5100001,5100002,5100003,5100004,5100005,5100006,
& 6100011,6100013,6100015,
& 5100012,5100011,5100014,5100013,5100016,5100015,
& 5100021,5100022,5100023,5100024/
C...Save local variables
SAVE MOFSV,WIDWSV,WID2SV
C...Initial values
DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
DATA IUEDPR/25*0/
C...UED: inline functions used in kk width calculus
FKAC1(X,Y)=1.-X**2/Y**2
FKAC2(X,Y)=2.+X**2/Y**2
C...Compressed code and sign; mass.
KFLA=IABS(KFLR)
KFLS=ISIGN(1,KFLR)
KC=PYCOMP(KFLA)
SHR=SQRT(SH)
PMR=PMAS(KC,1)
C...Reset width information.
DO 110 I=0,MDCY(KC,3)
WDTP(I)=0D0
DO 100 J=0,5
WDTE(I,J)=0D0
100 CONTINUE
110 CONTINUE
C...Allow for fudge factor to rescale resonance width.
FUDGE=1D0
IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
&(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
IF(MSTP(110).EQ.KFLA) THEN
FUDGE=PARP(110)
ELSEIF(MSTP(110).EQ.-1) THEN
IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
ELSEIF(MSTP(110).EQ.-2) THEN
FUDGE=PARP(110)
ENDIF
ENDIF
C...Not to be treated as a resonance: return.
IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
&KFLA.NE.22) THEN
WDTP(0)=1D0
WDTE(0,0)=1D0
MINT(61)=0
MINT(62)=0
MINT(63)=0
RETURN
C...Treatment as a resonance based on tabulated branching ratios.
ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
C...Loop over possible decay channels; skip irrelevant ones.
DO 120 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 120
C...Read out decay products and nominal masses.
KFD1=KFDP(IDC,1)
KFC1=PYCOMP(KFD1)
C...Skip dummy modes or unrecognized particles
IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
PM1=PMAS(KFC1,1)
KFD2=KFDP(IDC,2)
KFC2=PYCOMP(KFD2)
IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
PM2=PMAS(KFC2,1)
KFD3=KFDP(IDC,3)
PM3=0D0
IF(KFD3.NE.0) THEN
KFC3=PYCOMP(KFD3)
IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
PM3=PMAS(KFC3,1)
ENDIF
C...Naive partial width and alternative threshold factors.
WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
& PM1+PM2+PM3.GE.SHR) THEN
WDTP(I)=0D0
ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
& 4D0*PM1**2*PM2**2))/SH
ELSEIF(MDME(IDC,2).EQ.52) THEN
PMA=MAX(PM1,PM2,PM3)
PMC=MIN(PM1,PM2,PM3)
PMB=PM1+PM2+PM3-PMA-PMC
PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
PMAN=PMA**2/SH
PMBN=PMB**2/SH
PMCN=PMC**2/SH
PMBCN=PMBC**2/SH
WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
& ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
& ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
& ((SHR-PMA)**2-(PMB+PMC)**2)*
& (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
& ((1D0-PMBCN)*PMBCN*SH)
ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
WDTP(I)=WDTP(I)*SQRT(
& MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
& MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
ELSEIF(MDME(IDC,2).EQ.53) THEN
PMA=MAX(PM1,PM2,PM3)
PMC=MIN(PM1,PM2,PM3)
PMB=PM1+PM2+PM3-PMA-PMC
PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
PMAN=PMA**2/SH
PMBN=PMB**2/SH
PMCN=PMC**2/SH
PMBCN=PMBC**2/SH
FACACT=SQRT(MAX(0D0,
& ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
& ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
& ((SHR-PMA)**2-(PMB+PMC)**2)*
& (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
& ((1D0-PMBCN)*PMBCN*SH)
PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
PMAN=PMA**2/PMR**2
PMBN=PMB**2/PMR**2
PMCN=PMC**2/PMR**2
PMBCN=PMBC**2/PMR**2
FACNOM=SQRT(MAX(0D0,
& ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
& ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
& ((PMR-PMA)**2-(PMB+PMC)**2)*
& (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
& ((1D0-PMBCN)*PMBCN*PMR**2)
WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
C...Calculate secondary width (at most two identical/opposite).
WID2=1D0
IF(MDME(IDC,1).GT.0) THEN
IF(KFD2.EQ.KFD1) THEN
IF(KCHG(KFC1,3).EQ.0) THEN
WID2=WIDS(KFC1,1)
ELSEIF(KFD1.GT.0) THEN
WID2=WIDS(KFC1,4)
ELSE
WID2=WIDS(KFC1,5)
ENDIF
IF(KFD3.GT.0) THEN
WID2=WID2*WIDS(KFC3,2)
ELSEIF(KFD3.LT.0) THEN
WID2=WID2*WIDS(KFC3,3)
ENDIF
ELSEIF(KFD2.EQ.-KFD1) THEN
WID2=WIDS(KFC1,1)
IF(KFD3.GT.0) THEN
WID2=WID2*WIDS(KFC3,2)
ELSEIF(KFD3.LT.0) THEN
WID2=WID2*WIDS(KFC3,3)
ENDIF
ELSEIF(KFD3.EQ.KFD1) THEN
IF(KCHG(KFC1,3).EQ.0) THEN
WID2=WIDS(KFC1,1)
ELSEIF(KFD1.GT.0) THEN
WID2=WIDS(KFC1,4)
ELSE
WID2=WIDS(KFC1,5)
ENDIF
IF(KFD2.GT.0) THEN
WID2=WID2*WIDS(KFC2,2)
ELSEIF(KFD2.LT.0) THEN
WID2=WID2*WIDS(KFC2,3)
ENDIF
ELSEIF(KFD3.EQ.-KFD1) THEN
WID2=WIDS(KFC1,1)
IF(KFD2.GT.0) THEN
WID2=WID2*WIDS(KFC2,2)
ELSEIF(KFD2.LT.0) THEN
WID2=WID2*WIDS(KFC2,3)
ENDIF
ELSEIF(KFD3.EQ.KFD2) THEN
IF(KCHG(KFC2,3).EQ.0) THEN
WID2=WIDS(KFC2,1)
ELSEIF(KFD2.GT.0) THEN
WID2=WIDS(KFC2,4)
ELSE
WID2=WIDS(KFC2,5)
ENDIF
IF(KFD1.GT.0) THEN
WID2=WID2*WIDS(KFC1,2)
ELSEIF(KFD1.LT.0) THEN
WID2=WID2*WIDS(KFC1,3)
ENDIF
ELSEIF(KFD3.EQ.-KFD2) THEN
WID2=WIDS(KFC2,1)
IF(KFD1.GT.0) THEN
WID2=WID2*WIDS(KFC1,2)
ELSEIF(KFD1.LT.0) THEN
WID2=WID2*WIDS(KFC1,3)
ENDIF
ELSE
IF(KFD1.GT.0) THEN
WID2=WIDS(KFC1,2)
ELSE
WID2=WIDS(KFC1,3)
ENDIF
IF(KFD2.GT.0) THEN
WID2=WID2*WIDS(KFC2,2)
ELSE
WID2=WID2*WIDS(KFC2,3)
ENDIF
IF(KFD3.GT.0) THEN
WID2=WID2*WIDS(KFC3,2)
ELSEIF(KFD3.LT.0) THEN
WID2=WID2*WIDS(KFC3,3)
ENDIF
ENDIF
C...Store effective widths according to case.
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
120 CONTINUE
C...Return.
MINT(61)=0
MINT(62)=0
MINT(63)=0
RETURN
ENDIF
C...Here begins detailed dynamical calculation of resonance widths.
C...Shared treatment of Higgs states.
KFHIGG=25
IHIGG=1
IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
KFHIGG=KFLA
IHIGG=KFLA-33
ENDIF
C...Common electroweak and strong constants.
XW=PARU(102)
XWV=XW
IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
XW1=1D0-XW
AEM=PYALEM(SH)
IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
AS=PYALPS(SH)
RADC=1D0+AS/PARU(1)
IF(KFLA.EQ.6) THEN
C...t quark.
FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
RADCT=1D0-2.5D0*AS/PARU(1)
DO 140 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 140
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
WID2=1D0
IF(I.GE.4.AND.I.LE.7) THEN
C...t -> W + q; including approximate QCD correction factor.
WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)
IF(I.EQ.7) WID2=WID2*WIDS(7,2)
ELSE
WID2=WIDS(24,3)
IF(I.EQ.7) WID2=WID2*WIDS(7,3)
ENDIF
ELSEIF(I.EQ.9) THEN
C...t -> H + b.
RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
& 4D0*SQRT(RM2R*RM2))
WID2=WIDS(37,2)
IF(KFLR.LT.0) WID2=WIDS(37,3)
CMRENNA++
ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
BETA=ATAN(RMSS(5))
SINB=SIN(BETA)
TANW=SQRT(PARU(102)/(1D0-PARU(102)))
ET=KCHG(6,1)/3D0
T3L=SIGN(0.5D0,ET)
KFC1=PYCOMP(KFDP(IDC,1))
KFC2=PYCOMP(KFDP(IDC,2))
PMNCHI=PMAS(KFC1,1)
PMSTOP=PMAS(KFC2,1)
IF(SHR.GT.PMNCHI+PMSTOP) THEN
IZ=I-9
DO 130 IK=1,4
ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
130 CONTINUE
AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
AR=-ET*ZMIXC(IZ,1)*TANW
BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
BR=AL
FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
& (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
& ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
& SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
IF(KFLR.GT.0) THEN
WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
ELSE
WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
ENDIF
ENDIF
ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
C...t -> ~g + ~t
KFC1=PYCOMP(KFDP(IDC,1))
KFC2=PYCOMP(KFDP(IDC,2))
PMNCHI=PMAS(KFC1,1)
PMSTOP=PMAS(KFC2,1)
IF(SHR.GT.PMNCHI+PMSTOP) THEN
RL=SFMIX(6,1)
RR=-SFMIX(6,2)
PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
& (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
& (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
IF(KFLR.GT.0) THEN
WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
ELSE
WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
ENDIF
ENDIF
ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
C...t -> ~gravitino + ~t
XMP2=RMSS(29)**2
KFC1=PYCOMP(KFDP(IDC,1))
XMGR2=PMAS(KFC1,1)**2
WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
KFC2=PYCOMP(KFDP(IDC,2))
WID2=WIDS(KFC2,2)
IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
CMRENNA--
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
140 CONTINUE
ELSEIF(KFLA.EQ.7) THEN
C...b' quark.
FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
DO 150 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 150
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
WID2=1D0
IF(I.GE.4.AND.I.LE.7) THEN
C...b' -> W + q.
WDTP(I)=FAC*VCKM(I-3,4)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
IF(KFLR.GT.0) THEN
WID2=WIDS(24,3)
IF(I.EQ.6) WID2=WID2*WIDS(6,2)
IF(I.EQ.7) WID2=WID2*WIDS(8,2)
ELSE
WID2=WIDS(24,2)
IF(I.EQ.6) WID2=WID2*WIDS(6,3)
IF(I.EQ.7) WID2=WID2*WIDS(8,3)
ENDIF
WID2=WIDS(24,3)
IF(KFLR.LT.0) WID2=WIDS(24,2)
ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
C...b' -> H + q.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
IF(KFLR.GT.0) THEN
WID2=WIDS(37,3)
IF(I.EQ.10) WID2=WID2*WIDS(6,2)
ELSE
WID2=WIDS(37,2)
IF(I.EQ.10) WID2=WID2*WIDS(6,3)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
150 CONTINUE
ELSEIF(KFLA.EQ.8) THEN
C...t' quark.
FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
DO 160 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 160
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
WID2=1D0
IF(I.GE.4.AND.I.LE.7) THEN
C...t' -> W + q.
WDTP(I)=FAC*VCKM(4,I-3)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)
IF(I.EQ.7) WID2=WID2*WIDS(7,2)
ELSE
WID2=WIDS(24,3)
IF(I.EQ.7) WID2=WID2*WIDS(7,3)
ENDIF
ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
C...t' -> H + q.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
IF(KFLR.GT.0) THEN
WID2=WIDS(37,2)
IF(I.EQ.10) WID2=WID2*WIDS(7,2)
ELSE
WID2=WIDS(37,3)
IF(I.EQ.10) WID2=WID2*WIDS(7,3)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
160 CONTINUE
ELSEIF(KFLA.EQ.17) THEN
C...tau' lepton.
FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
DO 170 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 170
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
WID2=1D0
IF(I.EQ.3) THEN
C...tau' -> W + nu'_tau.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
IF(KFLR.GT.0) THEN
WID2=WIDS(24,3)
WID2=WID2*WIDS(18,2)
ELSE
WID2=WIDS(24,2)
WID2=WID2*WIDS(18,3)
ENDIF
ELSEIF(I.EQ.5) THEN
C...tau' -> H + nu'_tau.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
IF(KFLR.GT.0) THEN
WID2=WIDS(37,3)
WID2=WID2*WIDS(18,2)
ELSE
WID2=WIDS(37,2)
WID2=WID2*WIDS(18,3)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
170 CONTINUE
ELSEIF(KFLA.EQ.18) THEN
C...nu'_tau neutrino.
FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
DO 180 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 180
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
WID2=1D0
IF(I.EQ.2) THEN
C...nu'_tau -> W + tau'.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)
WID2=WID2*WIDS(17,2)
ELSE
WID2=WIDS(24,3)
WID2=WID2*WIDS(17,3)
ENDIF
ELSEIF(I.EQ.3) THEN
C...nu'_tau -> H + tau'.
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
IF(KFLR.GT.0) THEN
WID2=WIDS(37,2)
WID2=WID2*WIDS(17,2)
ELSE
WID2=WIDS(37,3)
WID2=WID2*WIDS(17,3)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
180 CONTINUE
ELSEIF(KFLA.EQ.21) THEN
C...QCD:
C***Note that widths are not given in dimensional quantities here.
DO 190 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 190
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
WID2=1D0
IF(I.LE.8) THEN
C...QCD -> q + qbar
WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
IF(I.EQ.6) WID2=WIDS(6,1)
IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
190 CONTINUE
ELSEIF(KFLA.EQ.22) THEN
C...QED photon.
C***Note that widths are not given in dimensional quantities here.
DO 200 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 200
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
WID2=1D0
IF(I.LE.8) THEN
C...QED -> q + qbar.
EF=KCHG(I,1)/3D0
FCOF=3D0*RADC
IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
IF(I.EQ.6) WID2=WIDS(6,1)
IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
ELSEIF(I.LE.12) THEN
C...QED -> l+ + l-.
EF=KCHG(9+2*(I-8),1)/3D0
WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
IF(I.EQ.12) WID2=WIDS(17,1)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
200 CONTINUE
ELSEIF(KFLA.EQ.23) THEN
C...Z0:
ICASE=1
XWC=1D0/(16D0*XW*XW1)
FAC=(AEM*XWC/3D0)*SHR
210 CONTINUE
IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
VINT(111)=0D0
VINT(112)=0D0
VINT(114)=0D0
ENDIF
IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
KFI=IABS(MINT(15))
IF(KFI.GT.20) KFI=IABS(MINT(16))
EI=KCHG(KFI,1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
SQMZ=PMAS(23,1)**2
HZ=SHR*WDTP(0)
IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
IF(MSTP(43).EQ.3) VINT(112)=
& 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
& XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
ENDIF
DO 220 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 220
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
WID2=1D0
IF(I.LE.8) THEN
C...Z0 -> q + qbar
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
FCOF=3D0*RADC
IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
IF(I.EQ.6) WID2=WIDS(6,1)
IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
ELSEIF(I.LE.16) THEN
C...Z0 -> l+ + l-, nu + nubar
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
FCOF=1D0
IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
ENDIF
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(ICASE.EQ.1) THEN
WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
& BE34
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
& EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
& (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
ENDIF
IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
& (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
& WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
& VINT(111)+FGGF*WID2
IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
& VINT(114)+FZZF*WID2
ENDIF
ENDIF
220 CONTINUE
IF(MINT(61).GE.1) ICASE=3-ICASE
IF(ICASE.EQ.2) GOTO 210
ELSEIF(KFLA.EQ.24) THEN
C...W+/-:
FAC=(AEM/(24D0*XW))*SHR
DO 230 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 230
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
WID2=1D0
IF(I.LE.16) THEN
C...W+/- -> q + qbar'
FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
IF(KFLR.GT.0) THEN
IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
IF(I.GE.13) WID2=WID2*WIDS(7,3)
ELSE
IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
IF(I.GE.13) WID2=WID2*WIDS(7,2)
ENDIF
ELSEIF(I.LE.20) THEN
C...W+/- -> l+/- + nu
FCOF=1D0
IF(KFLR.GT.0) THEN
IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
ELSE
IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
ENDIF
ENDIF
WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
230 CONTINUE
ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
C...h0 (or H0, or A0):
SHFS=SH
FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
DO 270 I=1,MDCY(KFHIGG,3)
IDC=I+MDCY(KFHIGG,2)-1
IF(MDME(IDC,1).LT.0) GOTO 270
KFC1=PYCOMP(KFDP(IDC,1))
KFC2=PYCOMP(KFDP(IDC,2))
RM1=PMAS(KFC1,1)**2/SH
RM2=PMAS(KFC2,1)**2/SH
IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
& GOTO 270
WID2=1D0
IF(I.LE.8) THEN
C...h0 -> q + qbar
WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
& SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
C...A0 behaves like beta, ho and H0 like beta**3.
IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
IF(IHIGG.NE.3) THEN
WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
& PARU(151+10*IHIGG))**2
ENDIF
ENDIF
ENDIF
IF(I.EQ.6) WID2=WIDS(6,1)
IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
ELSEIF(I.LE.12) THEN
C...h0 -> l+ + l-
WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
C...A0 behaves like beta, ho and H0 like beta**3.
IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
& PARU(153+10*IHIGG)**2
IF(I.EQ.12) WID2=WIDS(17,1)
ELSEIF(I.EQ.13) THEN
C...h0 -> g + g; quark loop contribution only
ETARE=0D0
ETAIM=0D0
DO 240 J=1,2*MSTP(1)
EPS=(2D0*PMAS(J,1))**2/SH
C...Loop integral; function of eps=4m^2/shat; different for A0.
IF(EPS.LE.1D0) THEN
IF(EPS.GT.1D-4) THEN
ROOT=SQRT(1D0-EPS)
RLN=LOG((1D0+ROOT)/(1D0-ROOT))
ELSE
RLN=LOG(4D0/EPS-2D0)
ENDIF
PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
PHIIM=0.5D0*PARU(1)*RLN
ELSE
PHIRE=(ASIN(1D0/SQRT(EPS)))**2
PHIIM=0D0
ENDIF
IF(IHIGG.LE.2) THEN
ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
ELSE
ETAREJ=-0.5D0*EPS*PHIRE
ETAIMJ=-0.5D0*EPS*PHIIM
ENDIF
C...Couplings (=1 for standard model Higgs).
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
IF(MOD(J,2).EQ.1) THEN
ETAREJ=ETAREJ*PARU(151+10*IHIGG)
ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
ELSE
ETAREJ=ETAREJ*PARU(152+10*IHIGG)
ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
ENDIF
ENDIF
ETARE=ETARE+ETAREJ
ETAIM=ETAIM+ETAIMJ
240 CONTINUE
ETA2=ETARE**2+ETAIM**2
WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
ELSEIF(I.EQ.14) THEN
C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
ETARE=0D0
ETAIM=0D0
JMAX=3*MSTP(1)+1
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
DO 250 J=1,JMAX
IF(J.LE.2*MSTP(1)) THEN
EJ=KCHG(J,1)/3D0
EPS=(2D0*PMAS(J,1))**2/SH
ELSEIF(J.LE.3*MSTP(1)) THEN
JL=2*(J-2*MSTP(1))-1
EJ=KCHG(10+JL,1)/3D0
EPS=(2D0*PMAS(10+JL,1))**2/SH
ELSEIF(J.EQ.3*MSTP(1)+1) THEN
EPS=(2D0*PMAS(24,1))**2/SH
ELSE
EPS=(2D0*PMAS(37,1))**2/SH
ENDIF
C...Loop integral; function of eps=4m^2/shat.
IF(EPS.LE.1D0) THEN
IF(EPS.GT.1D-4) THEN
ROOT=SQRT(1D0-EPS)
RLN=LOG((1D0+ROOT)/(1D0-ROOT))
ELSE
RLN=LOG(4D0/EPS-2D0)
ENDIF
PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
PHIIM=0.5D0*PARU(1)*RLN
ELSE
PHIRE=(ASIN(1D0/SQRT(EPS)))**2
PHIIM=0D0
ENDIF
IF(J.LE.3*MSTP(1)) THEN
C...Fermion loops: loop integral different for A0; charges.
IF(IHIGG.LE.2) THEN
PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
ELSE
PHIPRE=-0.5D0*EPS*PHIRE
PHIPIM=-0.5D0*EPS*PHIIM
ENDIF
IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
EJC=3D0*EJ**2
EJH=PARU(151+10*IHIGG)
ELSEIF(J.LE.2*MSTP(1)) THEN
EJC=3D0*EJ**2
EJH=PARU(152+10*IHIGG)
ELSE
EJC=EJ**2
EJH=PARU(153+10*IHIGG)
ENDIF
IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
ETAREJ=EJC*EJH*PHIPRE
ETAIMJ=EJC*EJH*PHIPIM
ELSEIF(J.EQ.3*MSTP(1)+1) THEN
C...W loops: loop integral and charges.
ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
ETAREJ=ETAREJ*PARU(155+10*IHIGG)
ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
ENDIF
ELSE
C...Charged H loops: loop integral and charges.
FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
& PARU(158+10*IHIGG+2*(IHIGG/3))
ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
ETAIMJ=-EPS**2*PHIIM*FACHHH
ENDIF
ETARE=ETARE+ETAREJ
ETAIM=ETAIM+ETAIMJ
250 CONTINUE
ETA2=ETARE**2+ETAIM**2
WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
ELSEIF(I.EQ.15) THEN
C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
ETARE=0D0
ETAIM=0D0
JMAX=3*MSTP(1)+1
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
DO 260 J=1,JMAX
IF(J.LE.2*MSTP(1)) THEN
EJ=KCHG(J,1)/3D0
AJ=SIGN(1D0,EJ+0.1D0)
VJ=AJ-4D0*EJ*XWV
EPS=(2D0*PMAS(J,1))**2/SH
EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
ELSEIF(J.LE.3*MSTP(1)) THEN
JL=2*(J-2*MSTP(1))-1
EJ=KCHG(10+JL,1)/3D0
AJ=SIGN(1D0,EJ+0.1D0)
VJ=AJ-4D0*EJ*XWV
EPS=(2D0*PMAS(10+JL,1))**2/SH
EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
ELSE
EPS=(2D0*PMAS(24,1))**2/SH
EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
ENDIF
C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
IF(EPS.LE.1D0) THEN
ROOT=SQRT(1D0-EPS)
IF(EPS.GT.1D-4) THEN
RLN=LOG((1D0+ROOT)/(1D0-ROOT))
ELSE
RLN=LOG(4D0/EPS-2D0)
ENDIF
PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
PHIIM=0.5D0*PARU(1)*RLN
PSIRE=0.5D0*ROOT*RLN
PSIIM=-0.5D0*ROOT*PARU(1)
ELSE
PHIRE=(ASIN(1D0/SQRT(EPS)))**2
PHIIM=0D0
PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
PSIIM=0D0
ENDIF
IF(EPSP.LE.1D0) THEN
ROOT=SQRT(1D0-EPSP)
IF(EPSP.GT.1D-4) THEN
RLN=LOG((1D0+ROOT)/(1D0-ROOT))
ELSE
RLN=LOG(4D0/EPSP-2D0)
ENDIF
PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
PHIIMP=0.5D0*PARU(1)*RLN
PSIREP=0.5D0*ROOT*RLN
PSIIMP=-0.5D0*ROOT*PARU(1)
ELSE
PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
PHIIMP=0D0
PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
PSIIMP=0D0
ENDIF
FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
& (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
& (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
IF(J.LE.3*MSTP(1)) THEN
C...Fermion loops: loop integral different for A0; charges.
IF(IHIGG.EQ.3) FXYRE=0D0
IF(IHIGG.EQ.3) FXYIM=0D0
IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
EJC=-3D0*EJ*VJ
EJH=PARU(151+10*IHIGG)
ELSEIF(J.LE.2*MSTP(1)) THEN
EJC=-3D0*EJ*VJ
EJH=PARU(152+10*IHIGG)
ELSE
EJC=-EJ*VJ
EJH=PARU(153+10*IHIGG)
ENDIF
IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
ELSEIF(J.EQ.3*MSTP(1)+1) THEN
C...W loops: loop integral and charges.
HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
ETAREJ=ETAREJ*PARU(155+10*IHIGG)
ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
ENDIF
ELSE
C...Charged H loops: loop integral and charges.
FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
& PARU(158+10*IHIGG+2*(IHIGG/3))
ETAREJ=FACHHH*FXYRE
ETAIMJ=FACHHH*FXYIM
ENDIF
ETARE=ETARE+ETAREJ
ETAIM=ETAIM+ETAIMJ
260 CONTINUE
ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
WID2=WIDS(23,2)
ELSEIF(I.LE.17) THEN
C...h0 -> Z0 + Z0, W+ + W-
PM1=PMAS(IABS(KFDP(IDC,1)),1)
PG1=PMAS(IABS(KFDP(IDC,1)),2)
IF(MINT(62).GE.1) THEN
IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
& CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
& MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
MOFSV(IHIGG,I-15)=0
WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
& 1D0-4D0*RM1))
WID2=1D0
ELSE
MOFSV(IHIGG,I-15)=1
RMAS=SQRT(MAX(0D0,SH))
CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
& WID2)
WIDWSV(IHIGG,I-15)=WIDW
WID2SV(IHIGG,I-15)=WID2
ENDIF
ELSE
IF(MOFSV(IHIGG,I-15).EQ.0) THEN
WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
& 1D0-4D0*RM1))
WID2=1D0
ELSE
WIDW=WIDWSV(IHIGG,I-15)
WID2=WID2SV(IHIGG,I-15)
ENDIF
ENDIF
WDTP(I)=FAC*WIDW/(2D0*(18-I))
IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
& PARU(138+I+10*IHIGG)**2
WID2=WID2*WIDS(7+I,1)
ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
C...H0 -> Z0 + h0, A0-> Z0 + h0
WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
& (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
IF(IHIGG.EQ.2) THEN
WDTP(I)=WDTP(I)*PARU(179)**2
ELSEIF(IHIGG.EQ.3) THEN
WDTP(I)=WDTP(I)*PARU(186)**2
ENDIF
WID2=WIDS(23,2)*WIDS(25,2)
ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
C...H0 -> h0 + h0, A0-> h0 + h0
WDTP(I)=FAC*0.25D0*
& PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IHIGG.EQ.2) THEN
WDTP(I)=WDTP(I)*PARU(176)**2
ELSEIF(IHIGG.EQ.3) THEN
WDTP(I)=WDTP(I)*PARU(169)**2
ENDIF
WID2=WIDS(25,1)
ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
& (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
& *PARU(195+IHIGG)**2
IF(I.EQ.20) THEN
WID2=WIDS(24,2)*WIDS(37,3)
ELSEIF(I.EQ.21) THEN
WID2=WIDS(24,3)*WIDS(37,2)
ENDIF
ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
C...H0 -> Z0 + A0.
WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
& (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(36,2)*WIDS(23,2)
ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
C...H0 -> h0 + A0.
WDTP(I)=FAC*0.5D0*PARU(180)**2*
& PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
WID2=WIDS(25,2)*WIDS(36,2)
ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
C...H0 -> A0 + A0
WDTP(I)=FAC*0.25D0*PARU(177)**2*
& PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
WID2=WIDS(36,1)
CMRENNA++
ELSE
C...Add in SUSY decays (two-body) by rescaling by phase space factor.
RM10=RM1*SH/PMR**2
RM20=RM2*SH/PMR**2
WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
WFAC=0D0
ELSE
WFAC=WFAC/WFAC0
ENDIF
WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
CMRENNA--
IF(KFC2.EQ.KFC1) THEN
WID2=WIDS(KFC1,1)
ELSE
KSGN1=2
IF(KFDP(IDC,1).LT.0) KSGN1=3
KSGN2=2
IF(KFDP(IDC,2).LT.0) KSGN2=3
WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
270 CONTINUE
ELSEIF(KFLA.EQ.32) THEN
C...Z'0:
ICASE=1
XWC=1D0/(16D0*XW*XW1)
FAC=(AEM*XWC/3D0)*SHR
VINT(117)=0D0
280 CONTINUE
IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
VINT(111)=0D0
VINT(112)=0D0
VINT(113)=0D0
VINT(114)=0D0
VINT(115)=0D0
VINT(116)=0D0
ENDIF
IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
KFAI=IABS(MINT(15))
EI=KCHG(KFAI,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
KFAIC=1
IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
VPI=PARU(119+2*KFAIC)
API=PARU(120+2*KFAIC)
ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
VPI=PARJ(178+2*KFAIC)
API=PARJ(179+2*KFAIC)
ELSE
VPI=PARJ(186+2*KFAIC)
API=PARJ(187+2*KFAIC)
ENDIF
SQMZ=PMAS(23,1)**2
HZ=SHR*VINT(117)
SQMZP=PMAS(32,1)**2
HZP=SHR*WDTP(0)
IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
& MSTP(44).EQ.7) VINT(111)=1D0
IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
& 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
& 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
& MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
& 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
& (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
& MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
ENDIF
DO 290 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 290
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
WID2=1D0
IF(I.LE.16) THEN
IF(I.LE.8) THEN
C...Z'0 -> q + qbar
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
IF(I.LE.2) THEN
VPF=PARU(123-2*MOD(I,2))
APF=PARU(124-2*MOD(I,2))
ELSEIF(I.LE.4) THEN
VPF=PARJ(182-2*MOD(I,2))
APF=PARJ(183-2*MOD(I,2))
ELSE
VPF=PARJ(190-2*MOD(I,2))
APF=PARJ(191-2*MOD(I,2))
ENDIF
FCOF=3D0*RADC
IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
& PYHFTH(SH,SH*RM1,1D0)
IF(I.EQ.6) WID2=WIDS(6,1)
IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
ELSEIF(I.LE.16) THEN
C...Z'0 -> l+ + l-, nu + nubar
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
IF(I.LE.10) THEN
VPF=PARU(127-2*MOD(I,2))
APF=PARU(128-2*MOD(I,2))
ELSEIF(I.LE.12) THEN
VPF=PARJ(186-2*MOD(I,2))
APF=PARJ(187-2*MOD(I,2))
ELSE
VPF=PARJ(194-2*MOD(I,2))
APF=PARJ(195-2*MOD(I,2))
ENDIF
FCOF=1D0
IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
ENDIF
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(ICASE.EQ.1) THEN
WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
& APF**2*(1D0-4D0*RM1))*BE34
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
& EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
& VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
& VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
& AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
& VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
ELSEIF(MINT(61).EQ.2) THEN
FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
& BE34
FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
& BE34
ENDIF
ELSEIF(I.EQ.17) THEN
C...Z'0 -> W+ + W-
WDTPZP=PARU(129)**2*XW1**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
IF(ICASE.EQ.1) THEN
WDTPZ=0D0
WDTP(I)=FAC*WDTPZP
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
ELSEIF(MINT(61).EQ.2) THEN
FGGF=0D0
FGZF=0D0
FGZPF=0D0
FZZF=0D0
FZZPF=0D0
FZPZPF=WDTPZP
ENDIF
WID2=WIDS(24,1)
ELSEIF(I.EQ.18) THEN
C...Z'0 -> H+ + H-
CZC=2D0*(1D0-2D0*XW)
BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
IF(ICASE.EQ.1) THEN
WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
& VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
& (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
& (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
& (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
ELSEIF(MINT(61).EQ.2) THEN
FGGF=0.25D0*BE34C
FGZF=0.25D0*PARU(142)*CZC*BE34C
FGZPF=0.25D0*PARU(143)*CZC*BE34C
FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
ENDIF
WID2=WIDS(37,1)
ELSEIF(I.EQ.19) THEN
C...Z'0 -> Z0 + gamma.
ELSEIF(I.EQ.20) THEN
C...Z'0 -> Z0 + h0
FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
& (3D0*RM1+0.25D0*FLAM**2)*FLAM
IF(ICASE.EQ.1) THEN
WDTPZ=0D0
WDTP(I)=FAC*WDTPZP
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
ELSEIF(MINT(61).EQ.2) THEN
FGGF=0D0
FGZF=0D0
FGZPF=0D0
FZZF=0D0
FZZPF=0D0
FZPZPF=WDTPZP
ENDIF
WID2=WIDS(23,2)*WIDS(25,2)
ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
C...Z' -> h0 + A0 or H0 + A0.
BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
IF(I.EQ.21) THEN
CZAH=PARU(186)
CZPAH=PARU(188)
ELSE
CZAH=PARU(187)
CZPAH=PARU(189)
ENDIF
IF(ICASE.EQ.1) THEN
WDTPZ=CZAH**2*BE34C
WDTP(I)=FAC*CZPAH**2*BE34C
ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
& (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
& VINT(116))*BE34C
ELSEIF(MINT(61).EQ.2) THEN
FGGF=0D0
FGZF=0D0
FGZPF=0D0
FZZF=CZAH**2*BE34C
FZZPF=CZAH*CZPAH*BE34C
FZPZPF=CZPAH**2*BE34C
ENDIF
IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
ENDIF
IF(ICASE.EQ.1) THEN
VINT(117)=VINT(117)+FAC*WDTPZ
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
ENDIF
IF(MDME(IDC,1).GT.0) THEN
IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
& (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
& WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
& MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
& FGZF*WID2
IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
& FGZPF*WID2
IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
& MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
& FZZPF*WID2
IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
& MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
ENDIF
ENDIF
290 CONTINUE
IF(MINT(61).GE.1) ICASE=3-ICASE
IF(ICASE.EQ.2) GOTO 280
ELSEIF(KFLA.EQ.34) THEN
C...W'+/-:
FAC=(AEM/(24D0*XW))*SHR
DO 300 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 300
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
WID2=1D0
IF(I.LE.20) THEN
IF(I.LE.16) THEN
C...W'+/- -> q + qbar'
CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
IF(KFLR.GT.0) THEN
IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
IF(I.GE.13) WID2=WID2*WIDS(7,3)
ELSE
IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
IF(I.GE.13) WID2=WID2*WIDS(7,2)
ENDIF
ELSEIF(I.LE.20) THEN
C...W'+/- -> l+/- + nu
FCOF=PARU(133)**2+PARU(134)**2
FCOF2=PARU(133)**2-PARU(134)**2
IF(KFLR.GT.0) THEN
IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
ELSE
IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
ENDIF
ENDIF
WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
& *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
C...PS 28/06/2010
C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
& *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
ELSEIF(I.EQ.21) THEN
C...W'+/- -> W+/- + Z0
WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
ELSEIF(I.EQ.23) THEN
C...W'+/- -> W+/- + h0
FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
300 CONTINUE
ELSEIF(KFLA.EQ.37) THEN
C...H+/-:
C IF(MSTP(49).EQ.0) THEN
SHFS=SH
C ELSE
C SHFS=PMAS(37,1)**2
C ENDIF
FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
DO 310 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 310
KFC1=PYCOMP(KFDP(IDC,1))
KFC2=PYCOMP(KFDP(IDC,2))
RM1=PMAS(KFC1,1)**2/SH
RM2=PMAS(KFC2,1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
WID2=1D0
IF(I.LE.4) THEN
C...H+/- -> q + qbar'
RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
& RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
IF(KFLR.GT.0) THEN
IF(I.EQ.3) WID2=WIDS(6,2)
IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
ELSE
IF(I.EQ.3) WID2=WIDS(6,3)
IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
ENDIF
ELSEIF(I.LE.8) THEN
C...H+/- -> l+/- + nu
WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
& (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
& (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
IF(KFLR.GT.0) THEN
IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
ELSE
IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
ENDIF
ELSEIF(I.EQ.9) THEN
C...H+/- -> W+/- + h0.
WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
& (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
CMRENNA++
ELSE
C...Add in SUSY decays (two-body) by rescaling by phase space factor.
RM10=RM1*SH/PMR**2
RM20=RM2*SH/PMR**2
WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
WFAC=0D0
ELSE
WFAC=WFAC/WFAC0
ENDIF
WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
CMRENNA--
KSGN1=2
IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
KSGN2=2
IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
310 CONTINUE
ELSEIF(KFLA.EQ.41) THEN
C...R:
FAC=(AEM/(12D0*XW))*SHR
DO 320 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 320
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
WID2=1D0
IF(I.LE.6) THEN
C...R -> q + qbar'
FCOF=3D0*RADC
ELSEIF(I.LE.9) THEN
C...R -> l+ + l'-
FCOF=1D0
ENDIF
WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
IF(KFLR.GT.0) THEN
IF(I.EQ.4) WID2=WIDS(6,3)
IF(I.EQ.5) WID2=WIDS(7,3)
IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
IF(I.EQ.9) WID2=WIDS(17,3)
ELSE
IF(I.EQ.4) WID2=WIDS(6,2)
IF(I.EQ.5) WID2=WIDS(7,2)
IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
IF(I.EQ.9) WID2=WIDS(17,2)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
320 CONTINUE
ELSEIF(KFLA.EQ.42) THEN
C...LQ (leptoquark).
FAC=(AEM/4D0)*PARU(151)*SHR
DO 330 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 330
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=1D0
ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
330 CONTINUE
C...UED: kk state width decays : flav: 451 476
ELSEIF(IUED(1).EQ.1.AND.
& PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
& PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
KCLA=PYCOMP(KFLA)
C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
RMFLAS=PMAS(KCLA,1)
FACSH=SH/PMAS(KCLA,1)**2
ALPHEM=PYALEM(RMFLAS**2)
ALPHS=PYALPS(RMFLAS**2)
C...uedcor parameters (alpha_s is calculated at mkk scale)
C...alpha_em is calculated at z pole !
ALPHEM=PARU(101)
FACSH=1.
DO 1070 I=1,MDCY(KCLA,3)
IDC=I+MDCY(KCLA,2)-1
IF(MDME(IDC,1).LT.0) GOTO 1070
KFC1=PYCOMP(ABS(KFDP(IDC,1)))
KFC2=PYCOMP(ABS(KFDP(IDC,2)))
RM1=PMAS(KFC1,1)**2/SH
RM2=PMAS(KFC2,1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
& GOTO 1070
WID2=1D0
C...N.B. RINV=RUED(1)
RMKK=RUED(1)
RMWKK=PMAS(475,1)
RMZKK=PMAS(474,1)
SW2=PARU(102)
CW2=1.-SW2
KKCLA=KCLA-KKFLMI+1
IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
IF(KKCLA.LE.6) THEN
C...q*_S -> q + gamma* (in first time sw21=0)
FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
C...Eventually change the following by enabling a choice of open or closed.
C...Only the gamma_kk channel is open.
IF(MOD(I,2).EQ.0)
+ WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
WDTP(I)=FACSH*WDTP(I)
WID2=WIDS(473,2)
ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
C...q*_D -> q + Z*/W*
FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
IF(I.EQ.1)THEN
C...q*_D -> q + Z*
WDTP(I)=0.5*GAMMAW
WID2=WIDS(474,2)
ELSEIF(I.EQ.2)THEN
C...q*_D -> q + W*
WDTP(I)=GAMMAW
WID2=WIDS(475,2)
ENDIF
WDTP(I)=FACSH*WDTP(I)
C...q*_D -> q + gamma* is closed
ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
FAC=ALPHEM/4.*RMFLAS/CW2/8.
RMGAKK=PMAS(473,1)
WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
+ FKAC1(RMGAKK,RMFLAS)**2
WDTP(I)=FACSH*WDTP(I)
WID2=WIDS(473,2)
ELSEIF(KKCLA.EQ.22)THEN
RMQST=PMAS(KKPART,1)
WID2=WIDS(KKPART,2)
C...g* -> q*_S/q*_D + q
FAC=10.*ALPHS/12.*RMFLAS
WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
WDTP(I)=FACSH*WDTP(I)
ELSEIF(KKCLA.EQ.23)THEN
C...gamma* decays to graviton + gamma : initial value is used
ICHI=IUED(4)/2
WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
& *CHIDEL(ICHI)
ELSEIF(KKCLA.EQ.24)THEN
C...Z* -> l*_S + l is closed
C... Z* -> l*_D + l
IF(I.LE.3)GOTO 1070
c... After closing the channels for a Z* decaying into positively charged
C... KK lepton singlets, close the channels for a Z* decaying into negatively
C... charged KK lepton singlets + positively charged SM particles
IF(I.GE.10.AND.I.LE.12)GOTO 1070
FAC=3./2.*ALPHEM/24./SW2*RMZKK
RMLST=PMAS(KKPART,1)
WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
WDTP(I)=FACSH*WDTP(I)
WID2=WIDS(KKPART,2)
ELSEIF(KKCLA.EQ.25)THEN
C...W* -> l*_D lbar
FAC=3.*ALPHEM/12./SW2*RMWKK
RMLST=PMAS(KKPART,1)
WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
WDTP(I)=FACSH*WDTP(I)
WID2=WIDS(KKPART,2)
ENDIF
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
1070 CONTINUE
IUEDPR(KKCLA)=1
ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
C...Techni-pi0 and techni-pi0':
FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
DO 340 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 340
PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
RM1=PM1**2/SH
RM2=PM2**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
WID2=1D0
C...pi_tc -> g + g
IF(I.EQ.8) THEN
FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
& /(8D0*PARU(1))*SH*SHR
IF(KFLA.EQ.KTECHN+111) THEN
FACP=FACP*RTCM(9)
ELSE
FACP=FACP*RTCM(10)
ENDIF
WDTP(I)=FACP
ELSE
C...pi_tc -> f + fbar.
FCOF=1D0
IKA=IABS(KFDP(IDC,1))
IF(IKA.LT.10) FCOF=3D0*RADC
HM1=PM1
HM2=PM2
IF(IKA.GE.4.AND.IKA.LE.6) THEN
FCOF=FCOF*RTCM(1+IKA)**2
HM1=PYMRUN(KFDP(IDC,1),SH)
HM2=PYMRUN(KFDP(IDC,2),SH)
ELSEIF(IKA.EQ.15) THEN
FCOF=FCOF*RTCM(8)**2
ENDIF
WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
340 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+211) THEN
C...pi+_tc
FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
DO 350 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 350
PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
PM3=0D0
IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
RM1=PM1**2/SH
RM2=PM2**2/SH
RM3=PM3**2/SH
IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
WID2=1D0
C...pi_tc -> f + f'.
FCOF=1D0
IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
C...pi_tc+ -> W b b~
IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
FCOF=3D0*RADC
XMT2=PMAS(6,1)**2/SH
FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
KFC3=PYCOMP(KFDP(IDC,3))
CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
CHECK = SQRT(RM1)
T0 = (1D0-CHECK**2)*
& (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
& (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
& -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
& +T3*LOG(CHECK))
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)
ELSE
WID2=WIDS(24,3)
ENDIF
ELSE
FCOF=1D0
IKA=IABS(KFDP(IDC,1))
IF(IKA.LT.10) FCOF=3D0*RADC
HM1=PM1
HM2=PM2
IF(I.GE.1.AND.I.LE.5) THEN
IF(I.LE.2) THEN
FCOF=FCOF*RTCM(5)**2
ELSEIF(I.LE.4) THEN
FCOF=FCOF*RTCM(6)**2
ELSEIF(I.EQ.5) THEN
FCOF=FCOF*RTCM(7)**2
ENDIF
HM1=PYMRUN(KFDP(IDC,1),SH)
HM2=PYMRUN(KFDP(IDC,2),SH)
ELSEIF(I.EQ.8) THEN
FCOF=FCOF*RTCM(8)**2
ENDIF
WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
350 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+331) THEN
C...Techni-eta.
FAC=(SH/PARP(46)**2)*SHR
DO 360 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 360
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
WID2=1D0
IF(I.LE.2) THEN
WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
IF(I.EQ.2) WID2=WIDS(6,1)
ELSE
WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
360 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+113) THEN
C...Techni-rho0:
ALPRHT=2.16D0*(3D0/ITCM(1))
FAC=(ALPRHT/12D0)*SHR
FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
SHP=SH
CALL PYWIDX(23,SHP,WDTPP,WDTEP)
GMMZ=SHR*WDTPP(0)
XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
DO 370 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 370
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
WID2=1D0
IF(I.EQ.1) THEN
C...rho_tc0 -> W+ + W-.
C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
WDTP(I)=FAC*RTCM(3)**4*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
& RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
WID2=WIDS(24,1)
ELSEIF(I.EQ.2) THEN
C...rho_tc0 -> W+ + pi_tc-.
C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
& (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
ELSEIF(I.EQ.3) THEN
C...rho_tc0 -> pi_tc+ + W-.
WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
& (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
ELSEIF(I.EQ.4) THEN
C...rho_tc0 -> pi_tc+ + pi_tc-.
WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(PYCOMP(KTECHN+211),1)
ELSEIF(I.EQ.5) THEN
C...rho_tc0 -> gamma + pi_tc0
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
& SHR**3
WID2=WIDS(PYCOMP(KTECHN+111),2)
ELSEIF(I.EQ.6) THEN
C...rho_tc0 -> gamma + pi_tc0'
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
WID2=WIDS(PYCOMP(KTECHN+221),2)
ELSEIF(I.EQ.7) THEN
C...rho_tc0 -> Z0 + pi_tc0
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
& XW/XW1*SHR**3
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
ELSEIF(I.EQ.8) THEN
C...rho_tc0 -> Z0 + pi_tc0'
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
& XW/XW1*SHR**3
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
ELSEIF(I.EQ.9) THEN
C...rho_tc0 -> gamma + Z0
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
WID2=WIDS(23,2)
ELSEIF(I.EQ.10) THEN
C...rho_tc0 -> Z0 + Z0
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
& SHR**3
WID2=WIDS(23,1)
ELSE
C...rho_tc0 -> f + fbar.
WID2=1D0
IF(I.LE.18) THEN
IA=I-10
FCOF=3D0*RADC
IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
ELSE
IA=I-6
FCOF=1D0
IF(IA.GE.17) WID2=WIDS(IA,1)
ENDIF
EI=KCHG(IA,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
& ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
& (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
& (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
370 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+213) THEN
C...Techni-rho+/-:
ALPRHT=2.16D0*(3D0/ITCM(1))
FAC=(ALPRHT/12D0)*SHR
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
SHP=SH
CALL PYWIDX(24,SHP,WDTPP,WDTEP)
GMMW=SHR*WDTPP(0)
FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
& (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
DO 380 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 380
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
WID2=1D0
PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
c & /3D0*SHR**3
IF(I.EQ.1) THEN
C...rho_tc+ -> W+ + Z0.
C......Goldstone
WDTP(I)=FAC*RTCM(3)**4*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
C......W_L Z_T
WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
& /3D0*SHR**3
VA2=0D0
AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
C......W_T Z_L
WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
& /3D0*SHR**3
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)*WIDS(23,2)
ELSE
WID2=WIDS(24,3)*WIDS(23,2)
ENDIF
ELSEIF(I.EQ.2) THEN
C...rho_tc+ -> W+ + pi_tc0.
WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
& (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
ELSE
WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
ENDIF
ELSEIF(I.EQ.3) THEN
C...rho_tc+ -> pi_tc+ + Z0.
WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
& ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
& (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
& AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
& SHR**3*XW/XW1
IF(KFLR.GT.0) THEN
WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
ELSE
WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
ENDIF
ELSEIF(I.EQ.4) THEN
C...rho_tc+ -> pi_tc+ + pi_tc0.
WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
IF(KFLR.GT.0) THEN
WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
ELSE
WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
ENDIF
ELSEIF(I.EQ.5) THEN
C...rho_tc+ -> pi_tc+ + gamma
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
& SHR**3
IF(KFLR.GT.0) THEN
WID2=WIDS(PYCOMP(KTECHN+211),2)
ELSE
WID2=WIDS(PYCOMP(KTECHN+211),3)
ENDIF
ELSEIF(I.EQ.6) THEN
C...rho_tc+ -> W+ + pi_tc0'
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
ELSE
WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
ENDIF
ELSEIF(I.EQ.7) THEN
C...rho_tc+ -> W+ + gamma
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
IF(KFLR.GT.0) THEN
WID2=WIDS(24,2)
ELSE
WID2=WIDS(24,3)
ENDIF
ELSE
C...rho_tc+ -> f + fbar'.
IA=I-7
WID2=1D0
IF(IA.LE.16) THEN
FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
IF(KFLR.GT.0) THEN
IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
IF(IA.GE.13) WID2=WID2*WIDS(7,3)
ELSE
IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
IF(IA.GE.13) WID2=WID2*WIDS(7,2)
ENDIF
ELSE
FCOF=1D0
IF(KFLR.GT.0) THEN
IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
ELSE
IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
ENDIF
ENDIF
WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
380 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+223) THEN
C...Techni-omega:
ALPRHT=2.16D0*(3D0/ITCM(1))
FAC=(ALPRHT/12D0)*SHR
FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
SQMZ=PMAS(23,1)**2
SHP=SH
CALL PYWIDX(23,SHP,WDTPP,WDTEP)
GMMZ=SHR*WDTPP(0)
BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
DO 390 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 390
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
WID2=1D0
IF(I.EQ.1) THEN
C...omega_tc0 -> gamma + pi_tc0.
WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
WID2=WIDS(PYCOMP(KTECHN+111),2)
ELSEIF(I.EQ.2) THEN
C...omega_tc0 -> Z0 + pi_tc0
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
& XW/XW1*SHR**3
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
ELSEIF(I.EQ.3) THEN
C...omega_tc0 -> gamma + pi_tc0'
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
& SHR**3
WID2=WIDS(PYCOMP(KTECHN+221),2)
ELSEIF(I.EQ.4) THEN
C...omega_tc0 -> Z0 + pi_tc0'
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
& XW/XW1*SHR**3
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
ELSEIF(I.EQ.5) THEN
C...omega_tc0 -> W+ + pi_tc-
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
& FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
ELSEIF(I.EQ.6) THEN
C...omega_tc0 -> pi_tc+ + W-
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
& FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
ELSEIF(I.EQ.7) THEN
C...omega_tc0 -> W+ + W-.
C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
& 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
WID2=WIDS(24,1)
ELSEIF(I.EQ.8) THEN
C...omega_tc0 -> pi_tc+ + pi_tc-.
WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(PYCOMP(KTECHN+211),1)
C...omega_tc0 -> gamma + Z0
ELSEIF(I.EQ.9) THEN
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
WID2=WIDS(23,2)
C...omega_tc0 -> Z0 + Z0
ELSEIF(I.EQ.10) THEN
WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
& RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
& /24D0/RTCM(12)**2*SHR**3
WID2=WIDS(23,1)
ELSE
C...omega_tc0 -> f + fbar.
WID2=1D0
IF(I.LE.18) THEN
IA=I-10
FCOF=3D0*RADC
IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
ELSE
IA=I-8
FCOF=1D0
IF(IA.GE.17) WID2=WIDS(IA,1)
ENDIF
EI=KCHG(IA,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=-0.5D0*(VI+AI)
VARI=-0.5D0*(VI-AI)
WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
& ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
& (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
& (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
390 CONTINUE
C.....V8 -> quark anti-quark
ELSEIF(KFLA.EQ.KTECHN+100021) THEN
FAC=AS/6D0*SHR
TANT3=RTCM(21)
IF(ITCM(2).EQ.0) THEN
IMDL=1
ELSEIF(ITCM(2).EQ.1) THEN
IMDL=2
ENDIF
DO 400 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 400
PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
RM1=PM1**2/SH
IF(RM1.GT.0.25D0) GOTO 400
WID2=1D0
IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
FMIX=1D0/TANT3**2
ELSE
FMIX=TANT3**2
ENDIF
WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
IF(I.EQ.6) WID2=WIDS(6,1)
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
400 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
CLEBF=0D0
DO 410 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 410
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
WID2=1D0
C...pi_tc -> g + g
IF(I.EQ.7) THEN
IF(KFLA.EQ.KTECHN+100111) THEN
CLEBG=4D0/3D0
ELSE
CLEBG=5D0/3D0
ENDIF
FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
& /(2D0*PARU(1))*SH*SHR*CLEBG
WDTP(I)=FACP
ELSE
C...pi_tc -> f + fbar.
IF(I.EQ.6) WID2=WIDS(6,1)
FCOF=1D0
IKA=IABS(KFDP(IDC,1))
IF(IKA.LT.10) FCOF=3D0*RADC
HM1=PYMRUN(KFDP(IDC,1),SH)
WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
410 CONTINUE
ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
FAC=AS/6D0*SHR
ALPRHT=2.16D0*(3D0/ITCM(1))
TANT3=RTCM(21)
SIN2T=2D0*TANT3/(TANT3**2+1D0)
SINT3=TANT3/SQRT(TANT3**2+1D0)
CSXPP=RTCM(22)
RM82=RTCM(27)**2
X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
& RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
& RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
& SINT3**2)*2D0
X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
& SINT3**2)*2D0
CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
GMV8=SHR*WDTPP(0)
RMV8=PMAS(PYCOMP(KTECHN+100021),1)
FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
IF(ITCM(2).EQ.0) THEN
IMDL=1
ELSE
IMDL=2
ENDIF
DO 420 I=1,MDCY(KC,3)
IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
& KFLA.EQ.KTECHN+300113)) GOTO 420
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 420
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
WID2=1D0
IF(I.LE.6) THEN
IF(I.EQ.6) WID2=WIDS(6,1)
XIG=1D0
IF(KFLA.EQ.KTECHN+200113) THEN
XIG=0D0
XIJ=X12
ELSEIF(KFLA.EQ.KTECHN+300113) THEN
XIG=0D0
XIJ=X21
ELSEIF(KFLA.EQ.KTECHN+100113) THEN
XIJ=X11
ELSE
XIJ=X22
ENDIF
IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
FMIX=1D0/TANT3/SIN2T
ELSE
FMIX=-TANT3/SIN2T
ENDIF
XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
ELSEIF(I.EQ.7) THEN
WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
PSH=SHR*(1D0-RM1)/2D0
WDTP(I)=AS/9D0*PSH**3/RM82
IF(I.EQ.8) THEN
WDTP(I)=2D0*WDTP(I)*CSXPP**2
WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
ELSE
WDTP(I)=5D0*WDTP(I)
WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
ENDIF
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
420 CONTINUE
ELSEIF(KFLA.EQ.KEXCIT+1) THEN
C...d* excited quark.
FAC=(SH/RTCM(41)**2)*SHR
DO 430 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 430
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
WID2=1D0
IF(I.EQ.1) THEN
C...d* -> g + d.
WDTP(I)=FAC*AS*RTCM(45)**2/3D0
WID2=1D0
ELSEIF(I.EQ.2) THEN
C...d* -> gamma + d.
QF=-RTCM(43)/2D0+RTCM(44)/6D0
WDTP(I)=FAC*AEM*QF**2/4D0
WID2=1D0
ELSEIF(I.EQ.3) THEN
C...d* -> Z0 + d.
QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
& (1D0-RM1)**2*(2D0+RM1)
WID2=WIDS(23,2)
ELSEIF(I.EQ.4) THEN
C...d* -> W- + u.
WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
& (1D0-RM1)**2*(2D0+RM1)
IF(KFLR.GT.0) WID2=WIDS(24,3)
IF(KFLR.LT.0) WID2=WIDS(24,2)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
430 CONTINUE
ELSEIF(KFLA.EQ.KEXCIT+2) THEN
C...u* excited quark.
FAC=(SH/RTCM(41)**2)*SHR
DO 440 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 440
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
WID2=1D0
IF(I.EQ.1) THEN
C...u* -> g + u.
WDTP(I)=FAC*AS*RTCM(45)**2/3D0
WID2=1D0
ELSEIF(I.EQ.2) THEN
C...u* -> gamma + u.
QF=RTCM(43)/2D0+RTCM(44)/6D0
WDTP(I)=FAC*AEM*QF**2/4D0
WID2=1D0
ELSEIF(I.EQ.3) THEN
C...u* -> Z0 + u.
QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
& (1D0-RM1)**2*(2D0+RM1)
WID2=WIDS(23,2)
ELSEIF(I.EQ.4) THEN
C...u* -> W+ + d.
WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
& (1D0-RM1)**2*(2D0+RM1)
IF(KFLR.GT.0) WID2=WIDS(24,2)
IF(KFLR.LT.0) WID2=WIDS(24,3)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
440 CONTINUE
ELSEIF(KFLA.EQ.KEXCIT+11) THEN
C...e* excited lepton.
FAC=(SH/RTCM(41)**2)*SHR
DO 450 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 450
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
WID2=1D0
IF(I.EQ.1) THEN
C...e* -> gamma + e.
QF=-RTCM(43)/2D0-RTCM(44)/2D0
WDTP(I)=FAC*AEM*QF**2/4D0
WID2=1D0
ELSEIF(I.EQ.2) THEN
C...e* -> Z0 + e.
QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
& (1D0-RM1)**2*(2D0+RM1)
WID2=WIDS(23,2)
ELSEIF(I.EQ.3) THEN
C...e* -> W- + nu.
WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
& (1D0-RM1)**2*(2D0+RM1)
IF(KFLR.GT.0) WID2=WIDS(24,3)
IF(KFLR.LT.0) WID2=WIDS(24,2)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
450 CONTINUE
ELSEIF(KFLA.EQ.KEXCIT+12) THEN
C...nu*_e excited neutrino.
FAC=(SH/RTCM(41)**2)*SHR
DO 460 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 460
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
WID2=1D0
IF(I.EQ.1) THEN
C...nu*_e -> Z0 + nu*_e.
QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
& (1D0-RM1)**2*(2D0+RM1)
WID2=WIDS(23,2)
ELSEIF(I.EQ.2) THEN
C...nu*_e -> W+ + e.
WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
& (1D0-RM1)**2*(2D0+RM1)
IF(KFLR.GT.0) WID2=WIDS(24,2)
IF(KFLR.LT.0) WID2=WIDS(24,3)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
460 CONTINUE
ELSEIF(KFLA.EQ.KDIMEN+39) THEN
C...G* (graviton resonance):
FAC=(PARP(50)**2/PARU(1))*SHR
DO 470 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 470
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
WID2=1D0
IF(I.LE.8) THEN
C...G* -> q + qbar
FCOF=3D0*RADC
IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
& PYHFTH(SH,SH*RM1,1D0)
WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
& (1D0+8D0*RM1/3D0)/320D0
IF(I.EQ.6) WID2=WIDS(6,1)
IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
ELSEIF(I.LE.16) THEN
C...G* -> l+ + l-, nu + nubar
FCOF=1D0
WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
& (1D0+8D0*RM1/3D0)/320D0
IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
ELSEIF(I.EQ.17) THEN
C...G* -> g + g.
WDTP(I)=FAC/20D0
ELSEIF(I.EQ.18) THEN
C...G* -> gamma + gamma.
WDTP(I)=FAC/160D0
ELSEIF(I.EQ.19) THEN
C...G* -> Z0 + Z0.
WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
& 14D0*RM1/3D0+4D0*RM1**2)/160D0
WID2=WIDS(23,1)
ELSEIF(I.EQ.20) THEN
C...G* -> W+ + W-.
WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
& 14D0*RM1/3D0+4D0*RM1**2)/80D0
WID2=WIDS(24,1)
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
470 CONTINUE
ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
DO 480 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 480
PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
IF(PM1+PM2+PM3.GE.SHR) GOTO 480
WID2=1D0
IF(I.LE.9) THEN
C...nu_lR -> l- qbar q'
FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
ELSEIF(I.LE.18) THEN
C...nu_lR -> l+ q qbar'
FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
ELSE
C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
FCOF=1D0
WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
ENDIF
X=(PM1+PM2+PM3)/SHR
FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
Y=(SHR/PMWR)**2
FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
WDTP(I)=FAC*FCOF*FX*FY
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
480 CONTINUE
ELSEIF(KFLA.EQ.9900023) THEN
C...Z_R0:
FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
DO 490 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 490
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
WID2=1D0
SYMMET=1D0
IF(I.LE.6) THEN
C...Z_R0 -> q + qbar
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
FCOF=3D0*RADC
IF(I.EQ.6) WID2=WIDS(6,1)
ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
C...Z_R0 -> l+ + l-
AF=-(1D0-2D0*XW)
VF=-1D0+4D0*XW
FCOF=1D0
ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
AF=-2D0*XW
VF=0D0
FCOF=1D0
SYMMET=0.5D0
ELSEIF(I.LE.15) THEN
C...Z0 -> nu_R + nu_R, assumed Majorana.
AF=2D0*XW1
VF=0D0
FCOF=1D0
WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
SYMMET=0.5D0
ENDIF
WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
& SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
490 CONTINUE
ELSEIF(KFLA.EQ.9900024) THEN
C...W_R+/-:
FAC=(AEM/(24D0*XW))*SHR
DO 500 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 500
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
WID2=1D0
IF(I.LE.9) THEN
C...W_R+/- -> q + qbar'
FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
IF(KFLR.GT.0) THEN
IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
ELSE
IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
ENDIF
ELSEIF(I.LE.12) THEN
C...W_R+/- -> l+/- + nu_R
FCOF=1D0
ENDIF
WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
500 CONTINUE
ELSEIF(KFLA.EQ.9900041) THEN
C...H_L++/--:
FAC=(1D0/(8D0*PARU(1)))*SHR
DO 510 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 510
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
WID2=1D0
IF(I.LE.6) THEN
C...H_L++/-- -> l+/- + l'+/-
FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
& (IABS(KFDP(IDC,2))-9)/2)**2
IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
ELSEIF(I.EQ.7) THEN
C...H_L++/-- -> W_L+/- + W_L+/-
FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
& (3D0*RM1+0.25D0/RM1-1D0)
WID2=WIDS(24,4+(1-KFLS)/2)
ENDIF
WDTP(I)=FAC*FCOF*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
510 CONTINUE
ELSEIF(KFLA.EQ.9900042) THEN
C...H_R++/--:
FAC=(1D0/(8D0*PARU(1)))*SHR
DO 520 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 520
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
WID2=1D0
IF(I.LE.6) THEN
C...H_R++/-- -> l+/- + l'+/-
FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
& (IABS(KFDP(IDC,2))-9)/2)**2
IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
ELSEIF(I.EQ.7) THEN
C...H_R++/-- -> W_R+/- + W_R+/-
FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
ENDIF
WDTP(I)=FAC*FCOF*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
520 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+115) THEN
C...Techni-a2:
C...Need to update to alpha_rho
ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
FAC=(ALPRHT/12D0)*SHR
FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
SHP=SH
CALL PYWIDX(23,SHP,WDTPP,WDTEP)
GMMZ=SHR*WDTPP(0)
XWRHT=1D0/(4D0*XW*(1D0-XW))
BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
DO 530 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 530
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
WID2=1D0
PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
IF(I.LE.4) THEN
FACPV=PCM**2
FACPA=PCM**2+1.5D0*RM1
VA2=0D0
AA2=0D0
C...a2_tc0 -> W+ + W-
IF(I.EQ.1) THEN
AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
WID2=WIDS(24,1)
C...a2_tc0 -> W+ + pi_tc- + c.c.
ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
IF(I.EQ.6) THEN
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
ELSE
WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
ENDIF
ELSEIF(I.EQ.4) THEN
C...a2_tc0 -> Z0 + pi_tc0'
VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
ENDIF
WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
ELSEIF(I.GE.5.AND.I.LE.10) THEN
FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
FACPA=PCM**2*(1D0+RM1+RM2)
VA2=0D0
AA2=0D0
IF(I.EQ.5) THEN
C...a_T^0 -> gamma rho_T^0
VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
WID2=WIDS(PYCOMP(KTECHN+113),2)
ELSEIF(I.EQ.6) THEN
C...a_T^0 -> gamma omega_T
VA2=1D0/RTCM(50)**4
WID2=WIDS(PYCOMP(KTECHN+223),2)
ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
C...a_T^0 -> W^+- rho_T^-+
AA2=.25D0/XW/RTCM(51)**4
IF(I.EQ.7) THEN
WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
ELSE
WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
ENDIF
ELSEIF(I.EQ.9) THEN
C...a_T^0 -> Z^0 rho_T^0
VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
ELSEIF(I.EQ.10) THEN
C...a_T^0 -> Z^0 omega_T
VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
ENDIF
WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
ELSE
C...a2_tc0 -> f + fbar.
WID2=1D0
IF(I.LE.18) THEN
IA=I-10
FCOF=3D0*RADC
IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
ELSE
IA=I-8
FCOF=1D0
IF(IA.GE.17) WID2=WIDS(IA,1)
ENDIF
EI=KCHG(IA,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
& ((VALI*BWZR)**2+(VALI*BWZI)**2+
& (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
& (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
530 CONTINUE
ELSEIF(KFLA.EQ.KTECHN+215) THEN
C...Techni-a2+/-:
ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
FAC=(ALPRHT/12D0)*SHR
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
SHP=SH
CALL PYWIDX(24,SHP,WDTPP,WDTEP)
GMMW=SHR*WDTPP(0)
FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
& (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
DO 540 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 540
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
WID2=1D0
PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
IF(KFLR.GT.0) THEN
ICHANN=2
ELSE
ICHANN=3
ENDIF
IF(I.LE.7) THEN
AA2=0
VA2=0
C...a2_tc+ -> gamma + W+.
IF(I.EQ.1) THEN
AA2=RTCM(3)**2/RTCM(49)**2
WID2=WIDS(24,ICHANN)
C...a2_tc+ -> gamma + pi_tc+.
ELSEIF(I.EQ.2) THEN
AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
C...a2_tc+ -> W+ + Z
ELSEIF(I.EQ.3) THEN
AA2=RTCM(3)**2*(1D0/4D0/XW1 +
& (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
WID2=WIDS(24,ICHANN)*WIDS(23,2)
C...a2_tc+ -> W+ + pi_tc0.
ELSEIF(I.EQ.4) THEN
AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
C...a2_tc+ -> W+ + pi_tc'0.
ELSEIF(I.EQ.5) THEN
VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
C...a2_tc+ -> Z0 + pi_tc+.
ELSEIF(I.EQ.6) THEN
AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
& RTCM(49)**2
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
ENDIF
WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
& /3D0*SHR**3
ELSEIF(I.LE.10) THEN
FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
FACPA=PCM**2*(1D0+RM1+RM2)
VA2=0D0
AA2=0D0
C...a2_tc+ -> gamma + rho_tc+
IF(I.EQ.7) THEN
VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
C...a2_tc+ -> W+ + rho_T^0
ELSEIF(I.EQ.8) THEN
AA2=1D0/(4D0*XW)/RTCM(51)**4
WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
C...a2_tc+ -> W+ + omega_T
ELSEIF(I.EQ.9) THEN
VA2=.25D0/XW/RTCM(50)**4
WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
C...a2_tc+ -> Z^0 + rho_T^+
ELSEIF(I.EQ.10) THEN
VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
ENDIF
WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
ELSE
C...a2_tc+ -> f + fbar'.
IA=I-10
WID2=1D0
IF(IA.LE.16) THEN
FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
IF(KFLR.GT.0) THEN
IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
IF(IA.GE.13) WID2=WID2*WIDS(7,3)
ELSE
IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
IF(IA.GE.13) WID2=WID2*WIDS(7,2)
ENDIF
ELSE
FCOF=1D0
IF(KFLR.GT.0) THEN
IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
ELSE
IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
ENDIF
ENDIF
WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
ENDIF
WDTP(I)=FUDGE*WDTP(I)
WDTP(0)=WDTP(0)+WDTP(I)
IF(MDME(IDC,1).GT.0) THEN
WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
WDTE(I,0)=WDTE(I,MDME(IDC,1))
WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
ENDIF
540 CONTINUE
ENDIF
MINT(61)=0
MINT(62)=0
MINT(63)=0
RETURN
END
C***********************************************************************
C...PYOFSH
C...Calculates partial width and differential cross-section maxima
C...of channels/processes not allowed on mass-shell, and selects
C...masses in such channels/processes.
SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT5/
C...Local arrays.
DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
&PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
&FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
&WDTE(0:400,0:5)
C...Find if particles equal, maximum mass, matrix elements, etc.
MINT(51)=0
ISUB=MINT(1)
KFD(1)=IABS(KFD1)
KFD(2)=IABS(KFD2)
MEQL=0
IF(KFD(1).EQ.KFD(2)) MEQL=1
MLM=0
IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
NOFF=44
PMMX=PMMO
ELSE
NOFF=40
PMMX=VINT(1)
IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
ENDIF
MMED=0
IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
&(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
&KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
&KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
LOOP=1
C...Find where Breit-Wigners are required, else select discrete masses.
100 DO 110 I=1,2
KFCA=PYCOMP(KFD(I))
IF(KFCA.GT.0) THEN
PMD(I)=PMAS(KFCA,1)
PGD(I)=PMAS(KFCA,2)
ELSE
PMD(I)=0D0
PGD(I)=0D0
ENDIF
IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
MBW(I)=0
PMG(I)=PMD(I)
RMG(I)=(PMG(I)/PMMX)**2
ELSE
MBW(I)=1
ENDIF
110 CONTINUE
C...Find allowed mass range and Breit-Wigner parameters.
DO 120 I=1,2
IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
PML(I)=PARP(42)
PMU(I)=PMMX-PARP(42)
IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
ILM=I
IF(MLM.EQ.2) ILM=3-I
PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
IF(MBW(3-I).EQ.0) THEN
PMU(I)=PMMX-PMD(3-I)
ELSE
PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
ENDIF
IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
& MIN(PMU(I),CKIN(NOFF+2*ILM))
IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
IF(MBW(I).EQ.1) THEN
ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
& PGD(I)))
ENDIF
ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
ILM=I
IF(MLM.EQ.2) ILM=3-I
PML(I)=MAX(CKIN(48+I),PARP(42))
PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
IF(MBW(I).EQ.1) THEN
ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
& PGD(I)))
ENDIF
ENDIF
120 CONTINUE
IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
&THEN
CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
MINT(51)=1
RETURN
ENDIF
C...Calculation of partial width of resonance.
IF(MOFSH.EQ.1) THEN
C..If only one integration, pick that to be the inner.
IF(MBW(1).EQ.0) THEN
PM2=PMD(1)
PMD(1)=PMD(2)
PGD(1)=PGD(2)
PML(1)=PML(2)
PMU(1)=PMU(2)
ELSEIF(MBW(2).EQ.0) THEN
PM2=PMD(2)
ENDIF
C...Start outer loop of integration.
IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
NPT2=1
XPT2(1)=1D0
INX2(1)=0
FMAX2=0D0
ENDIF
130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
ENDIF
RM2=(PM2/PMMX)**2
C...Start inner loop of integration.
PML1=PML(1)
PMU1=MIN(PMU(1),PMMX-PM2)
IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
FUNC2=0D0
GOTO 180
ENDIF
NPT1=1
XPT1(1)=1D0
INX1(1)=0
FMAX1=0D0
140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
RM1=(PM1/PMMX)**2
C...Evaluate function value - inner loop.
FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
& RM2**2+10D0*RM1*RM2)
IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
FPT1(NPT1)=FUNC1
C...Go to next position in inner loop.
IF(NPT1.EQ.1) THEN
NPT1=NPT1+1
XPT1(NPT1)=0D0
INX1(NPT1)=1
GOTO 140
ELSEIF(NPT1.LE.8) THEN
NPT1=NPT1+1
IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
ISH1=ISH1+1
XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
INX1(NPT1)=INX1(ISH1)
INX1(ISH1)=NPT1
GOTO 140
ELSEIF(NPT1.LT.100) THEN
ISN1=ISH1
150 ISH1=ISH1+1
IF(ISH1.GT.NPT1) ISH1=2
IF(ISH1.EQ.ISN1) GOTO 160
DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
NPT1=NPT1+1
XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
INX1(NPT1)=INX1(ISH1)
INX1(ISH1)=NPT1
GOTO 140
ENDIF
C...Calculate integral over inner loop.
160 FSUM1=0D0
DO 170 IPT1=2,NPT1
FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
& (XPT1(INX1(IPT1))-XPT1(IPT1))
170 CONTINUE
FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
FPT2(NPT2)=FUNC2
C...Go to next position in outer loop.
IF(NPT2.EQ.1) THEN
NPT2=NPT2+1
XPT2(NPT2)=0D0
INX2(NPT2)=1
GOTO 130
ELSEIF(NPT2.LE.8) THEN
NPT2=NPT2+1
IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
ISH2=ISH2+1
XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
INX2(NPT2)=INX2(ISH2)
INX2(ISH2)=NPT2
GOTO 130
ELSEIF(NPT2.LT.100) THEN
ISN2=ISH2
190 ISH2=ISH2+1
IF(ISH2.GT.NPT2) ISH2=2
IF(ISH2.EQ.ISN2) GOTO 200
DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
NPT2=NPT2+1
XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
INX2(NPT2)=INX2(ISH2)
INX2(ISH2)=NPT2
GOTO 130
ENDIF
C...Calculate integral over outer loop.
200 FSUM2=0D0
DO 210 IPT2=2,NPT2
FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
& (XPT2(INX2(IPT2))-XPT2(IPT2))
210 CONTINUE
FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
ELSE
FSUM2=FUNC2
ENDIF
C...Save result; second integration for user-selected mass range.
IF(LOOP.EQ.1) WIDW=FSUM2
WID2=FSUM2
IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
& .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
LOOP=2
GOTO 100
ENDIF
RET1=WIDW
RET2=WID2/WIDW
C...Select two decay product masses of a resonance.
ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
220 DO 230 I=1,2
IF(MBW(I).EQ.0) GOTO 230
PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
& (ATU(I)-ATL(I)))
PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
RMG(I)=(PMG(I)/PMMX)**2
230 CONTINUE
IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
& PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
C...Weight with matrix element (if none known, use beta factor).
FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
IF(MMED.EQ.1) THEN
WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
ELSEIF(MMED.EQ.2) THEN
WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
& RMG(2)**2+10D0*RMG(1)*RMG(2))
ELSEIF(MMED.EQ.3) THEN
WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
ELSE
WTBE=FLAM
ENDIF
IF(WTBE.LT.PYR(0)) GOTO 220
RET1=PMG(1)
RET2=PMG(2)
C...Find suitable set of masses for initialization of 2 -> 2 processes.
ELSEIF(MOFSH.EQ.3) THEN
IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
PMG(2)=PMD(2)
ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
PMG(1)=PMD(1)
PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
ELSE
IDIV=-1
240 IDIV=IDIV+1
PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
ENDIF
RET1=PMG(1)
RET2=PMG(2)
C...Evaluate importance of excluded tails of Breit-Wigners.
IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
& .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
IF(MEQL.LE.1) THEN
VINT(80)=1D0
DO 250 I=1,2
IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
& PARU(1)
250 CONTINUE
ELSE
VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
& (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
ENDIF
IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
& MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
C...Pick one particle to be the lighter (if improves efficiency).
ELSEIF(MOFSH.EQ.4) THEN
IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
& .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
C...Select two masses according to Breit-Wigner + flat in s + 1/s.
DO 270 I=1,2
IF(MBW(I).EQ.0) GOTO 270
PMV=PMU(I)
IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
ATV=ATU(I)
IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
RBR=PYR(0)
IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
& ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
IF(RBR.LT.0.8D0) THEN
PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
ELSEIF(RBR.LT.0.9D0) THEN
PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
ELSEIF(RBR.LT.1.5D0) THEN
PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
ELSE
PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
& (PMV**2-PML(I)**2))))
ENDIF
270 CONTINUE
IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
& PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
NGEN(0,1)=NGEN(0,1)+1
NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
GOTO 260
ELSE
MINT(51)=1
RETURN
ENDIF
ENDIF
RET1=PMG(1)
RET2=PMG(2)
C...Give weight for selected mass distribution.
VINT(80)=1D0
DO 280 I=1,2
IF(MBW(I).EQ.0) GOTO 280
PMV=PMU(I)
IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
ATV=ATU(I)
IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
& (PMD(I)*PGD(I))**2)/PARU(1)
F1=1D0
F2=1D0/PMG(I)**2
F3=1D0/PMG(I)**4
FI0=(ATV-ATL(I))/PARU(1)
FI1=PMV**2-PML(I)**2
FI2=2D0*LOG(PMV/PML(I))
FI3=1D0/PML(I)**2-1D0/PMV**2
IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
& ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
& 5D0*F3/FI3))
ELSE
VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
ENDIF
VINT(80)=VINT(80)*FI0
280 CONTINUE
IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
ENDIF
RETURN
END
C***********************************************************************
C...PYRECO
C...Handles the possibility of colour reconnection in W+W- events,
C...Based on the main scenarios of the Sjostrand and Khoze study:
C...I, II, II', intermediate and instantaneous; plus one model
C...along the lines of the Gustafson and Hakkinen: GH.
C...Note: also handles Z0 Z0 and W-W+ events, but notation below
C...is as if first resonance is W+ and second W-.
SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter value; number of points in MC integration.
PARAMETER (NPT=100)
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
&V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
&XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
&V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
&TMC(20),IJOIN(100)
C...Functions to give four-product and to do determinants.
FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
&Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
&Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
C...Only allow fraction of recoupling for GH, intermediate and
C...instantaneous.
IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
IF(PYR(0).GT.PARP(120)) RETURN
ENDIF
ISUB=MINT(1)
C...Common part for scenarios I, II, II', and GH.
IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
&MSTP(115).EQ.5) THEN
C...Read out frequently-used parameters.
PI=PARU(1)
HBAR=PARU(3)
PMW=PMAS(24,1)
IF(ISUB.EQ.22) PMW=PMAS(23,1)
PGW=PMAS(24,2)
IF(ISUB.EQ.22) PGW=PMAS(23,2)
TFRAG=PARP(115)
RHAD=PARP(116)
FACT=PARP(117)
BLOWR=PARP(118)
BLOWT=PARP(119)
C...Find range of decay products of the W's.
C...Background: the W's are stored in IW1 and IW2.
C...Their direct decay products in NSD1+1 through NSD1+4.
C...Products after shower (if any) in NSD1+5 through NAFT1
C...for first W and in NAFT1+1 through N for the second.
IF(NAFT1.GT.NSD1+4) THEN
NBEG(1)=NSD1+5
NEND(1)=NAFT1
ELSE
NBEG(1)=NSD1+1
NEND(1)=NSD1+2
ENDIF
IF(N.GT.NAFT1) THEN
NBEG(2)=NAFT1+1
NEND(2)=N
ELSE
NBEG(2)=NSD1+3
NEND(2)=NSD1+4
ENDIF
C...Rearrange parton shower products along strings.
NOLD=N
CALL PYPREP(NSD1+1)
IF(MINT(51).NE.0) RETURN
C...Find partons pointing back to W+ and W-; store them with quark
C...end of string first.
NNP=0
NNM=0
ISGP=0
ISGM=0
DO 120 I=NOLD+1,N
IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
IF(IABS(K(I,2)).GE.22) GOTO 120
IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
NNP=NNP+1
IF(ISGP.EQ.1) THEN
INP(NNP)=I
ELSE
DO 100 I1=NNP,2,-1
INP(I1)=INP(I1-1)
100 CONTINUE
INP(1)=I
ENDIF
IF(K(I,1).EQ.1) ISGP=0
ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
NNM=NNM+1
IF(ISGM.EQ.1) THEN
INM(NNM)=I
ELSE
DO 110 I1=NNM,2,-1
INM(I1)=INM(I1-1)
110 CONTINUE
INM(1)=I
ENDIF
IF(K(I,1).EQ.1) ISGM=0
ENDIF
120 CONTINUE
C...Boost to W+W- rest frame (not strictly needed).
DO 130 J=1,3
BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
130 CONTINUE
CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
C...Select decay vertices of W+ and W-.
TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
& SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
& SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
GTMAX=MAX(TP,TM)
DO 140 J=1,3
XP(J)=TP*P(IW1,J)/P(IW1,4)
XM(J)=TM*P(IW2,J)/P(IW2,4)
140 CONTINUE
C...Begin scenario I specifics.
IF(MSTP(115).EQ.1) THEN
C...Reconstruct velocity and direction of W+ string pieces.
DO 170 IIP=1,NNP-1
IF(K(INP(IIP),2).LT.0) GOTO 170
I1=INP(IIP)
I2=INP(IIP+1)
P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
DO 150 J=1,3
V1(J)=P(I1,J)/P1A
V2(J)=P(I2,J)/P2A
BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
DIRP(IIP,J)=V1(J)-V2(J)
150 CONTINUE
BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
& BETP(IIP,3)**2)
DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
DO 160 J=1,3
DIRP(IIP,J)=DIRP(IIP,J)/DIRL
160 CONTINUE
170 CONTINUE
C...Reconstruct velocity and direction of W- string pieces.
DO 200 IIM=1,NNM-1
IF(K(INM(IIM),2).LT.0) GOTO 200
I1=INM(IIM)
I2=INM(IIM+1)
P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
DO 180 J=1,3
V1(J)=P(I1,J)/P1A
V2(J)=P(I2,J)/P2A
BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
DIRM(IIM,J)=V1(J)-V2(J)
180 CONTINUE
BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
& BETM(IIM,3)**2)
DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
DO 190 J=1,3
DIRM(IIM,J)=DIRM(IIM,J)/DIRL
190 CONTINUE
200 CONTINUE
C...Loop over number of space-time points.
NACC=0
SUM=0D0
DO 250 IPT=1,NPT
C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
R=SQRT(-LOG(PYR(0)))
PHI=2D0*PI*PYR(0)
X=BLOWR*RHAD*R*COS(PHI)
Y=BLOWR*RHAD*R*SIN(PHI)
R=SQRT(-LOG(PYR(0)))
PHI=2D0*PI*PYR(0)
Z=BLOWR*RHAD*R*COS(PHI)
T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
C...Reject impossible points. Weight for sample distribution.
IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
& EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
C...Loop over W+ string pieces and find one with largest weight.
IMAXP=0
WTMAXP=1D-10
XD(1)=X-XP(1)
XD(2)=Y-XP(2)
XD(3)=Z-XP(3)
XD(4)=T-TP
DO 220 IIP=1,NNP-1
IF(K(INP(IIP),2).LT.0) GOTO 220
BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
DO 210 J=1,3
XB(J)=XD(J)+BEDG*BETP(IIP,J)
210 CONTINUE
XB(4)=BETP(IIP,4)*(XD(4)-BED)
SR2=XB(1)**2+XB(2)**2+XB(3)**2
SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
& DIRP(IIP,3)*XB(3))**2
WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
& TFRAG**2)
IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
IF(WTP.GT.WTMAXP) THEN
IMAXP=IIP
WTMAXP=WTP
ENDIF
220 CONTINUE
C...Loop over W- string pieces and find one with largest weight.
IMAXM=0
WTMAXM=1D-10
XD(1)=X-XM(1)
XD(2)=Y-XM(2)
XD(3)=Z-XM(3)
XD(4)=T-TM
DO 240 IIM=1,NNM-1
IF(K(INM(IIM),2).LT.0) GOTO 240
BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
DO 230 J=1,3
XB(J)=XD(J)+BEDG*BETM(IIM,J)
230 CONTINUE
XB(4)=BETM(IIM,4)*(XD(4)-BED)
SR2=XB(1)**2+XB(2)**2+XB(3)**2
SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
& DIRM(IIM,3)*XB(3))**2
WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
& TFRAG**2)
IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
IF(WTM.GT.WTMAXM) THEN
IMAXM=IIM
WTMAXM=WTM
ENDIF
240 CONTINUE
C...Result of integration.
WT=0D0
IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
WT=WTMAXP*WTMAXM/WTSMP
SUM=SUM+WT
NACC=NACC+1
IAP(NACC)=IMAXP
IAM(NACC)=IMAXM
WTA(NACC)=WT
ENDIF
250 CONTINUE
RES=BLOWR**3*BLOWT*SUM/NPT
C...Decide whether to reconnect and, if so, where.
IACC=0
PREC=1D0-EXP(-FACT*RES)
IF(PREC.GT.PYR(0)) THEN
RSUM=PYR(0)*SUM
DO 260 IA=1,NACC
IACC=IA
RSUM=RSUM-WTA(IA)
IF(RSUM.LE.0D0) GOTO 270
260 CONTINUE
270 IIP=IAP(IACC)
IIM=IAM(IACC)
ENDIF
C...Begin scenario II and II' specifics.
ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
C...Loop through all string pieces, one from W+ and one from W-.
NCROSS=0
TC(0)=0D0
DO 340 IIP=1,NNP-1
IF(K(INP(IIP),2).LT.0) GOTO 340
I1P=INP(IIP)
I2P=INP(IIP+1)
DO 330 IIM=1,NNM-1
IF(K(INM(IIM),2).LT.0) GOTO 330
I1M=INM(IIM)
I2M=INM(IIM+1)
C...Find endpoint velocity vectors.
DO 280 J=1,3
V1P(J)=P(I1P,J)/P(I1P,4)
V2P(J)=P(I2P,J)/P(I2P,4)
V1M(J)=P(I1M,J)/P(I1M,4)
V2M(J)=P(I2M,J)/P(I2M,4)
280 CONTINUE
C...Define q matrix and find t.
DO 290 J=1,3
Q(1,J)=V2P(J)-V1P(J)
Q(2,J)=-(V2M(J)-V1M(J))
Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
Q(4,J)=V1P(J)-V1M(J)
290 CONTINUE
T=-DETER(1,2,3)/DETER(1,2,4)
C...Find alpha and beta; i.e. coordinates of crossing point.
S11=Q(1,1)*(T-TP)
S12=Q(2,1)*(T-TM)
S13=Q(3,1)+Q(4,1)*T
S21=Q(1,2)*(T-TP)
S22=Q(2,2)*(T-TM)
S23=Q(3,2)+Q(4,2)*T
DEN=S11*S22-S12*S21
ALP=(S12*S23-S22*S13)/DEN
BET=(S21*S13-S11*S23)/DEN
C...Check if solution acceptable.
IANSW=1
IF(T.LT.GTMAX) IANSW=0
IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
C...Find point of crossing and check that not inconsistent.
DO 300 J=1,3
XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
300 CONTINUE
D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
& (XPP(3)-XMM(3))**2
D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
C...Find string eigentimes at crossing.
IF(IANSW.EQ.1) THEN
TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
& (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
& (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
ELSE
TAUP=0D0
TAUM=0D0
ENDIF
C...Order crossings by time. End loop over crossings.
IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
NCROSS=NCROSS+1
DO 310 I1=NCROSS,1,-1
IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
IPC(I1)=IIP
IMC(I1)=IIM
TC(I1)=T
TPC(I1)=TAUP
TMC(I1)=TAUM
GOTO 320
ELSE
IPC(I1)=IPC(I1-1)
IMC(I1)=IMC(I1-1)
TC(I1)=TC(I1-1)
TPC(I1)=TPC(I1-1)
TMC(I1)=TMC(I1-1)
ENDIF
310 CONTINUE
320 CONTINUE
ENDIF
330 CONTINUE
340 CONTINUE
C...Loop over crossings; find first (if any) acceptable one.
IACC=0
IF(NCROSS.GE.1) THEN
DO 350 IC=1,NCROSS
PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
IF(PNFRAG.GT.PYR(0)) THEN
C...Scenario II: only compare with fragmentation time.
IF(MSTP(115).EQ.2) THEN
IACC=IC
IIP=IPC(IACC)
IIM=IMC(IACC)
GOTO 360
C...Scenario II': also require that string length decreases.
ELSE
IIP=IPC(IC)
IIM=IMC(IC)
I1P=INP(IIP)
I2P=INP(IIP+1)
I1M=INM(IIM)
I2M=INM(IIM+1)
ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
IF(ELNEW.LT.ELOLD) THEN
IACC=IC
IIP=IPC(IACC)
IIM=IMC(IACC)
GOTO 360
ENDIF
ENDIF
ENDIF
350 CONTINUE
360 CONTINUE
ENDIF
C...Begin scenario GH specifics.
ELSEIF(MSTP(115).EQ.5) THEN
C...Loop through all string pieces, one from W+ and one from W-.
IACC=0
ELMIN=1D0
DO 380 IIP=1,NNP-1
IF(K(INP(IIP),2).LT.0) GOTO 380
I1P=INP(IIP)
I2P=INP(IIP+1)
DO 370 IIM=1,NNM-1
IF(K(INM(IIM),2).LT.0) GOTO 370
I1M=INM(IIM)
I2M=INM(IIM+1)
C...Look for largest decrease of (exponent of) Lambda measure.
ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
ELDIF=ELNEW/MAX(1D-10,ELOLD)
IF(ELDIF.LT.ELMIN) THEN
IACC=IIP+IIM
ELMIN=ELDIF
IPC(1)=IIP
IMC(1)=IIM
ENDIF
370 CONTINUE
380 CONTINUE
IIP=IPC(1)
IIM=IMC(1)
ENDIF
C...Common for scenarios I, II, II' and GH: reconnect strings.
IF(IACC.NE.0) THEN
MINT(32)=1
NJOIN=0
DO 390 IS=1,NNP+NNM
NJOIN=NJOIN+1
IF(IS.LE.IIP) THEN
I=INP(IS)
ELSEIF(IS.LE.IIP+NNM-IIM) THEN
I=INM(IS-IIP+IIM)
ELSEIF(IS.LE.IIP+NNM) THEN
I=INM(IS-IIP-NNM+IIM)
ELSE
I=INP(IS-NNM)
ENDIF
IJOIN(NJOIN)=I
IF(K(I,2).LT.0) THEN
CALL PYJOIN(NJOIN,IJOIN)
NJOIN=0
ENDIF
390 CONTINUE
C...Restore original event record if no reconnection.
ELSE
DO 400 I=NSD1+1,NOLD
IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
ENDIF
400 CONTINUE
DO 410 I=NOLD+1,N
K(K(I,3),1)=3
410 CONTINUE
N=NOLD
ENDIF
C...Boost back system.
CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
& BEWW(1),BEWW(2),BEWW(3))
C...Common part for intermediate and instantaneous scenarios.
ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
MINT(32)=1
C...Remove old shower products and reset showering ones.
N=NSD1+4
DO 420 I=NSD1+1,NSD1+4
K(I,1)=3
K(I,4)=MOD(K(I,4),MSTU(5)**2)
K(I,5)=MOD(K(I,5),MSTU(5)**2)
420 CONTINUE
C...Identify quark-antiquark pairs.
IQ1=NSD1+1
IQ2=NSD1+2
IQ3=NSD1+3
IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
IQ4=2*NSD1+7-IQ3
C...Reconnect strings.
IJOIN(1)=IQ1
IJOIN(2)=IQ4
CALL PYJOIN(2,IJOIN)
IJOIN(1)=IQ3
IJOIN(2)=IQ2
CALL PYJOIN(2,IJOIN)
C...Do new parton showers in intermediate scenario.
IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
MSTJ50=MSTJ(50)
MSTJ(50)=0
CALL PYSHOW(IQ1,IQ2,P(IW1,5))
CALL PYSHOW(IQ3,IQ4,P(IW2,5))
MSTJ(50)=MSTJ50
C...Do new parton showers in instantaneous scenario.
ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
& (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
PPM=SQRT(MAX(0D0,PPM2))
CALL PYSHOW(IQ1,IQ4,PPM)
PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
& (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
PPM=SQRT(MAX(0D0,PPM2))
CALL PYSHOW(IQ3,IQ2,PPM)
ENDIF
ENDIF
RETURN
END
C***********************************************************************
C...PYKLIM
C...Checks generated variables against pre-set kinematical limits;
C...also calculates limits on variables used in generation.
SUBROUTINE PYKLIM(ILIM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/
C...Common kinematical expressions.
MINT(51)=0
ISUB=MINT(1)
ISTSB=ISET(ISUB)
IF(ISUB.EQ.96) GOTO 100
SQM3=VINT(63)
SQM4=VINT(64)
IF(ILIM.NE.0) THEN
IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
CKIN09=MAX(CKIN(9),CKIN(13))
CKIN10=MIN(CKIN(10),CKIN(14))
CKIN11=MAX(CKIN(11),CKIN(15))
CKIN12=MIN(CKIN(12),CKIN(16))
ELSE
CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
ENDIF
ENDIF
IF(ILIM.NE.1) THEN
TAU=VINT(21)
RM3=SQM3/(TAU*VINT(2))
RM4=SQM4/(TAU*VINT(2))
BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
ENDIF
PTHMIN=CKIN(3)
IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
&PTHMIN=MAX(CKIN(3),CKIN(5))
IF(ILIM.EQ.0) THEN
C...Check generated values of tau, y*, cos(theta-hat), and tau' against
C...pre-set kinematical limits.
YST=VINT(22)
CTH=VINT(23)
TAUP=VINT(26)
TAUE=TAU
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
X1=SQRT(TAUE)*EXP(YST)
X2=SQRT(TAUE)*EXP(-YST)
XF=X1-X2
IF(MINT(47).NE.1) THEN
IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
ENDIF
IF(MINT(45).NE.1) THEN
IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
ENDIF
IF(MINT(46).NE.1) THEN
IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
ENDIF
IF(MINT(45).EQ.2) THEN
IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
ENDIF
IF(MINT(46).EQ.2) THEN
IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
ENDIF
IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
& MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
& MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
Y3=YST+0.5D0*LOG(EXPY3)
Y4=YST+0.5D0*LOG(EXPY4)
YLARGE=MAX(Y3,Y4)
YSMALL=MIN(Y3,Y4)
ETALAR=20D0
ETASMA=-20D0
STH=SQRT(MAX(0D0,1D0-CTH**2))
EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
& CTH)**2-4D0*RM3))
EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
& CTH)**2-4D0*RM4))
IF(STH.GE.1D-10) THEN
EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
& (BE34*STH)
EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
& (BE34*STH)
ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
ETALAR=MAX(ETA3,ETA4)
ETASMA=MIN(ETA3,ETA4)
ENDIF
CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
SH=TAU*VINT(2)
RPTS=4D0*VINT(71)**2/SH
BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
RM34=MAX(1D-20,2D0*RM3*RM4)
IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
& RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
IF(PTH.LT.PTHMIN) MINT(51)=1
IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
IF(THA.LT.CKIN(35)) MINT(51)=1
IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
IF(UHA.LT.CKIN(37)) MINT(51)=1
IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
ENDIF
IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
ENDIF
C...Additional cuts on W2 (approximately) in DIS.
IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
XBJ=X2
IF(IABS(MINT(12)).LT.20) XBJ=X1
Q2BJ=THA
W2BJ=Q2BJ*(1D0-XBJ)/XBJ
IF(W2BJ.LT.CKIN(39)) MINT(51)=1
IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
ENDIF
ELSEIF(ILIM.EQ.1) THEN
C...Calculate limits on tau
C...0) due to definition
TAUMN0=0D0
TAUMX0=1D0
C...1) due to limits on subsystem mass
TAUMN1=CKIN(1)**2/VINT(2)
TAUMX1=1D0
IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
TM3=SQRT(SQM3+PTHMIN**2)
TM4=SQRT(SQM4+PTHMIN**2)
YDCOSH=1D0
IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
TAUMX2=1D0
C...3) due to limits on pT-hat and cos(theta-hat)
CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
TAUMN3=0D0
IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
& (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
& SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
TAUMX3=1D0
IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
& (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
& SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
C...4) due to limits on x1 and x2
TAUMN4=CKIN(21)*CKIN(23)
TAUMX4=CKIN(22)*CKIN(24)
C...5) due to limits on xF
TAUMN5=0D0
TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
C...6) due to limits on that and uhat
TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
TAUMX6=1D0
IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
& (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
C...Net effect of all separate limits.
VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
VINT(11)=1D0-1D-9
VINT(31)=1D0+1D-9
ELSEIF(MINT(47).EQ.5) THEN
VINT(31)=MIN(VINT(31),1D0-2D-10)
ELSEIF(MINT(47).GE.6) THEN
VINT(31)=MIN(VINT(31),1D0-1D-10)
ENDIF
IF(VINT(31).LE.VINT(11)) MINT(51)=1
ELSEIF(ILIM.EQ.2) THEN
C...Calculate limits on y*
TAUE=TAU
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
TAURT=SQRT(TAUE)
C...0) due to kinematics
YSTMN0=LOG(TAURT)
YSTMX0=-YSTMN0
C...1) due to explicit limits
YSTMN1=CKIN(7)
YSTMX1=CKIN(8)
C...2) due to limits on x1
YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
C...3) due to limits on x2
YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
C...4) due to limits on xF
YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
C...5) due to simultaneous limits on y-large and y-small
YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
C...6) due to simultaneous limits on cos(theta-hat) and y-large or
C... y-small
CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
RZMN=BE34*MAX(CKIN(27),-CTHLIM)
RZMX=BE34*MIN(CKIN(28),CTHLIM)
YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
C...Net effect of all separate limits.
VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
IF(MINT(47).EQ.1) THEN
VINT(12)=-1D-9
VINT(32)=1D-9
ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
VINT(12)=(1D0-1D-9)*YSTMX0
VINT(32)=(1D0+1D-9)*YSTMX0
ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
VINT(12)=-(1D0+1D-9)*YSTMX0
VINT(32)=-(1D0-1D-9)*YSTMX0
ELSEIF(MINT(47).EQ.5) THEN
YSTEE=LOG((1D0-1D-10)/TAURT)
VINT(12)=MAX(VINT(12),-YSTEE)
VINT(32)=MIN(VINT(32),YSTEE)
ENDIF
IF(VINT(32).LE.VINT(12)) MINT(51)=1
ELSEIF(ILIM.EQ.3) THEN
C...Calculate limits on cos(theta-hat)
YST=VINT(22)
C...0) due to definition
CTNMN0=-1D0
CTNMX0=0D0
CTPMN0=0D0
CTPMX0=1D0
C...1) due to explicit limits
CTNMN1=MIN(0D0,CKIN(27))
CTNMX1=MIN(0D0,CKIN(28))
CTPMN1=MAX(0D0,CKIN(27))
CTPMX1=MAX(0D0,CKIN(28))
C...2) due to limits on pT-hat
CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
CTPMX2=-CTNMN2
CTNMX2=0D0
CTPMN2=0D0
IF(CKIN(4).GE.0D0) THEN
CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
& (BE34**2*TAU*VINT(2))))
CTPMN2=-CTNMX2
ENDIF
C...3) due to limits on y-large and y-small
CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
& -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
& -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
& -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
& -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
C...4) due to limits on that
CTNMN4=-1D0
CTNMX4=0D0
CTPMN4=0D0
CTPMX4=1D0
SH=TAU*VINT(2)
IF(CKIN(35).GT.0D0) THEN
CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
IF(CTLIM.GT.0D0) THEN
CTPMX4=CTLIM
ELSE
CTPMX4=0D0
CTNMX4=CTLIM
ENDIF
ENDIF
IF(CKIN(36).GT.0D0) THEN
CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
IF(CTLIM.LT.0D0) THEN
CTNMN4=CTLIM
ELSE
CTNMN4=0D0
CTPMN4=CTLIM
ENDIF
ENDIF
C...5) due to limits on uhat
CTNMN5=-1D0
CTNMX5=0D0
CTPMN5=0D0
CTPMX5=1D0
IF(CKIN(37).GT.0D0) THEN
CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
IF(CTLIM.LT.0D0) THEN
CTNMN5=CTLIM
ELSE
CTNMN5=0D0
CTPMN5=CTLIM
ENDIF
ENDIF
IF(CKIN(38).GT.0D0) THEN
CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
IF(CTLIM.GT.0D0) THEN
CTPMX5=CTLIM
ELSE
CTPMX5=0D0
CTNMX5=CTLIM
ENDIF
ENDIF
C...Net effect of all separate limits.
VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
ELSEIF(ILIM.EQ.4) THEN
C...Calculate limits on tau'
C...0) due to kinematics
TAPMN0=TAU
IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
PQRAT=(VINT(201)+VINT(206))/VINT(1)
TAPMN0=(SQRT(TAU)+PQRAT)**2
ENDIF
TAPMX0=1D0
C...1) due to explicit limits
TAPMN1=CKIN(31)**2/VINT(2)
TAPMX1=1D0
IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
C...Net effect of all separate limits.
VINT(16)=MAX(TAPMN0,TAPMN1)
VINT(36)=MIN(TAPMX0,TAPMX1)
IF(MINT(47).EQ.1) THEN
VINT(16)=1D0-1D-9
VINT(36)=1D0+1D-9
ELSEIF(MINT(47).EQ.5) THEN
VINT(36)=MIN(VINT(36),1D0-2D-10)
ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
VINT(36)=MIN(VINT(36),1D0-1D-10)
ENDIF
IF(VINT(36).LE.VINT(16)) MINT(51)=1
ENDIF
RETURN
C...Special case for low-pT and multiple interactions:
C...effective kinematical limits for tau, y*, cos(theta-hat).
100 IF(ILIM.EQ.0) THEN
ELSEIF(ILIM.EQ.1) THEN
IF(MSTP(82).LE.1) THEN
VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
& VINT(2)
ELSE
VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
ENDIF
VINT(31)=1D0
ELSEIF(ILIM.EQ.2) THEN
VINT(12)=0.5D0*LOG(VINT(21))
VINT(32)=-VINT(12)
ELSEIF(ILIM.EQ.3) THEN
IF(MSTP(82).LE.1) THEN
ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
& (VINT(21)*VINT(2))
ELSE
ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
& (VINT(21)*VINT(2))
ENDIF
VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
VINT(33)=0D0
VINT(14)=0D0
VINT(34)=-VINT(13)
ENDIF
RETURN
END
C*********************************************************************
C...PYKMAP
C...Maps a uniform distribution into a distribution of a kinematical
C...variable according to one of the possibilities allowed. It is
C...assumed that kinematical limits have been set by a PYKLIM call.
SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
C...Convert VVAR to tau variable.
ISUB=MINT(1)
ISTSB=ISET(ISUB)
IF(IVAR.EQ.1) THEN
TAUMIN=VINT(11)
TAUMAX=VINT(31)
IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
TAURE=VINT(73)
GAMRE=VINT(74)
ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
TAURE=VINT(75)
GAMRE=VINT(76)
ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
TAURE=VINT(77)
GAMRE=VINT(78)
ENDIF
IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
TAU=1D0
ELSEIF(MVAR.EQ.1) THEN
TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
ELSEIF(MVAR.EQ.2) THEN
TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
ELSEIF(MINT(47).EQ.5) THEN
AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
ELSE
AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
ENDIF
VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
C...Convert VVAR to y* variable.
ELSEIF(IVAR.EQ.2) THEN
YSTMIN=VINT(12)
YSTMAX=VINT(32)
TAUE=VINT(21)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
IF(MINT(47).EQ.1) THEN
YST=0D0
ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
YST=-0.5D0*LOG(TAUE)
ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
YST=0.5D0*LOG(TAUE)
ELSEIF(MVAR.EQ.1) THEN
YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
ELSEIF(MVAR.EQ.2) THEN
YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
ELSEIF(MVAR.EQ.3) THEN
AUPP=ATAN(EXP(YSTMAX))
ALOW=ATAN(EXP(YSTMIN))
YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
ELSEIF(MVAR.EQ.4) THEN
YST0=-0.5D0*LOG(TAUE)
AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
ELSE
YST0=-0.5D0*LOG(TAUE)
AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
ENDIF
VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
C...Convert VVAR to cos(theta-hat) variable.
ELSEIF(IVAR.EQ.3) THEN
RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
RSQM=1D0+RM34
IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
& RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
CTNMIN=VINT(13)
CTNMAX=VINT(33)
CTPMIN=VINT(14)
CTPMAX=VINT(34)
IF(MVAR.EQ.1) THEN
ANEG=CTNMAX-CTNMIN
APOS=CTPMAX-CTPMIN
IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
VCTN=VVAR*(ANEG+APOS)/ANEG
CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
ELSE
VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
ENDIF
ELSEIF(MVAR.EQ.2) THEN
RMNMIN=MAX(RM34,RSQM-CTNMIN)
RMNMAX=MAX(RM34,RSQM-CTNMAX)
RMPMIN=MAX(RM34,RSQM-CTPMIN)
RMPMAX=MAX(RM34,RSQM-CTPMAX)
ANEG=LOG(RMNMIN/RMNMAX)
APOS=LOG(RMPMIN/RMPMAX)
IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
VCTN=VVAR*(ANEG+APOS)/ANEG
CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
ELSE
VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
ENDIF
ELSEIF(MVAR.EQ.3) THEN
RMNMIN=MAX(RM34,RSQM+CTNMIN)
RMNMAX=MAX(RM34,RSQM+CTNMAX)
RMPMIN=MAX(RM34,RSQM+CTPMIN)
RMPMAX=MAX(RM34,RSQM+CTPMAX)
ANEG=LOG(RMNMAX/RMNMIN)
APOS=LOG(RMPMAX/RMPMIN)
IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
VCTN=VVAR*(ANEG+APOS)/ANEG
CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
ELSE
VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
ENDIF
ELSEIF(MVAR.EQ.4) THEN
RMNMIN=MAX(RM34,RSQM-CTNMIN)
RMNMAX=MAX(RM34,RSQM-CTNMAX)
RMPMIN=MAX(RM34,RSQM-CTPMIN)
RMPMAX=MAX(RM34,RSQM-CTPMAX)
ANEG=1D0/RMNMAX-1D0/RMNMIN
APOS=1D0/RMPMAX-1D0/RMPMIN
IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
VCTN=VVAR*(ANEG+APOS)/ANEG
CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
ELSE
VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
ENDIF
ELSEIF(MVAR.EQ.5) THEN
RMNMIN=MAX(RM34,RSQM+CTNMIN)
RMNMAX=MAX(RM34,RSQM+CTNMAX)
RMPMIN=MAX(RM34,RSQM+CTPMIN)
RMPMAX=MAX(RM34,RSQM+CTPMAX)
ANEG=1D0/RMNMIN-1D0/RMNMAX
APOS=1D0/RMPMIN-1D0/RMPMAX
IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
VCTN=VVAR*(ANEG+APOS)/ANEG
CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
ELSE
VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
ENDIF
ENDIF
IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
VINT(23)=CTH
C...Convert VVAR to tau' variable.
ELSEIF(IVAR.EQ.4) THEN
TAU=VINT(21)
TAUPMN=VINT(16)
TAUPMX=VINT(36)
IF(MINT(47).EQ.1) THEN
TAUP=1D0
ELSEIF(MVAR.EQ.1) THEN
TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
ELSEIF(MVAR.EQ.2) THEN
AUPP=(1D0-TAU/TAUPMX)**4
ALOW=(1D0-TAU/TAUPMN)**4
TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
ELSEIF(MINT(47).EQ.5) THEN
AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
ELSE
AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
ENDIF
VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
C...Selection of extra variables needed in 2 -> 3 process:
C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
C...Since no options are available, the functions of PYKLIM
C...and PYKMAP are joint for these choices.
ELSEIF(IVAR.EQ.5) THEN
C...Read out total energy and particle masses.
MINT(51)=0
MPTPK=1
IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
& .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
& MPTPK=2
SHP=VINT(26)*VINT(2)
SHPR=SQRT(SHP)
PM1=VINT(201)
PM2=VINT(206)
PM3=SQRT(VINT(21))*VINT(1)
IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
MINT(51)=1
RETURN
ENDIF
PMRS1=VINT(204)**2
PMRS2=VINT(209)**2
C...Specify coefficients of pT choice; upper and lower limits.
IF(MPTPK.EQ.1) THEN
HWT1=0.4D0
HWT2=0.4D0
ELSE
HWT1=0.05D0
HWT2=0.05D0
ENDIF
HWT3=1D0-HWT1-HWT2
PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
& (4D0*SHP)
IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
PTSMN1=CKIN(51)**2
PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
& (4D0*SHP)
IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
PTSMN2=CKIN(53)**2
C...Select transverse momenta according to
C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
HMX=PMRS1+PTSMX1
HMN=PMRS1+PTSMN1
IF(HMX.LT.1.0001D0*HMN) THEN
MINT(51)=1
RETURN
ENDIF
HDE=PTSMX1-PTSMN1
RPT=PYR(0)
IF(RPT.LT.HWT1) THEN
PTS1=PTSMN1+PYR(0)*HDE
ELSEIF(RPT.LT.HWT1+HWT2) THEN
PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
ELSE
PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
ENDIF
WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
& HWT3*HMN*HMX/(PMRS1+PTS1)**2)
HMX=PMRS2+PTSMX2
HMN=PMRS2+PTSMN2
IF(HMX.LT.1.0001D0*HMN) THEN
MINT(51)=1
RETURN
ENDIF
HDE=PTSMX2-PTSMN2
RPT=PYR(0)
IF(RPT.LT.HWT1) THEN
PTS2=PTSMN2+PYR(0)*HDE
ELSEIF(RPT.LT.HWT1+HWT2) THEN
PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
ELSE
PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
ENDIF
WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
& HWT3*HMN*HMX/(PMRS2+PTS2)**2)
C...Select azimuthal angles and check pT choice.
PHI1=PARU(2)*PYR(0)
PHI2=PARU(2)*PYR(0)
PHIR=PHI2-PHI1
PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
& CKIN(56)**2)) THEN
MINT(51)=1
RETURN
ENDIF
C...Calculate transverse masses and check phase space not closed.
PMS1=PM1**2+PTS1
PMS2=PM2**2+PTS2
PMS3=PM3**2+PTS3
PMT1=SQRT(PMS1)
PMT2=SQRT(PMS2)
PMT3=SQRT(PMS3)
PM12=(PMT1+PMT2)**2
IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
MINT(51)=1
RETURN
ENDIF
C...Select rapidity for particle 3 and check phase space not closed.
Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
& 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
IF(Y3MAX.LT.1D-6) THEN
MINT(51)=1
RETURN
ENDIF
Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
PZ3=PMT3*SINH(Y3)
PE3=PMT3*COSH(Y3)
C...Find momentum transfers in two mirror solutions (in 1-2 frame).
PZ12=-PZ3
PE12=SHPR-PE3
PMS12=PE12**2-PZ12**2
SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
IF(SQL12.LT.1D-6*SHP) THEN
MINT(51)=1
RETURN
ENDIF
PMM1=PMS12+PMS1-PMS2
PMM2=PMS12+PMS2-PMS1
TFAC=-SHPR/(2D0*PMS12)
T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
C...Construct relative mirror weights and make choice.
IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
WTPU=1D0
WTNU=1D0
ELSE
WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
ENDIF
WTP=WTPU/(WTPU+WTNU)
WTN=WTNU/(WTPU+WTNU)
EPS=1D0
IF(WTN.GT.PYR(0)) EPS=-1D0
C...Store result of variable choice and associated weights.
VINT(202)=PTS1
VINT(207)=PTS2
VINT(203)=PHI1
VINT(208)=PHI2
VINT(205)=WTPTS1
VINT(210)=WTPTS2
VINT(211)=Y3
VINT(212)=Y3MAX
VINT(213)=EPS
IF(EPS.GT.0D0) THEN
VINT(214)=1D0/WTP
VINT(215)=T1P
VINT(216)=T2P
ELSE
VINT(214)=1D0/WTN
VINT(215)=T1N
VINT(216)=T2N
ENDIF
VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
VINT(219)=0.5D0*(PMS12-PTS3)
VINT(220)=SQL12
ENDIF
RETURN
END
C***********************************************************************
C...PYSIGH
C...Differential matrix elements for all included subprocesses
C...Note that what is coded is (disregarding the COMFAC factor)
C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
C...when d(sigma-hat) is given in the zero-width limit, the delta
C...function in tau is replaced by a (modified) Breit-Wigner:
C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
C...where H_res = s-hat/m_res*Gamma_res(s-hat);
C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
C...i.e., dimensionless quantities
C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
C...(2pi)^4 delta^4(P - sum p_i)
C...COMFAC contains the factor pi/s (or equivalent) and
C...the conversion factor from GeV^-2 to mb
SUBROUTINE PYSIGH(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
COMMON/PYTCCO/COEFX(194:380,2)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
&/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
C...Local arrays and complex variables
DIMENSION XPQ(-25:25)
C...Map of processes onto which routine to call
C...in order to evaluate cross section:
C...0 = not implemented;
C...1 = standard QCD (including photons);
C...2 = heavy flavours;
C...3 = W/Z;
C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
C...5 = SUSY;
C...6 = Technicolor;
C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
C...8 = Universal Extra Dimensions
DIMENSION MAPPR(500)
DATA (MAPPR(I),I=1,180)/
& 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
& 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
DATA (MAPPR(I),I=181,500)/
8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
& 100*5,
& 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
& 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
1 20*0,
4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
& 4, 4, 18*0,
2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
4 20*0,
6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
8 7, 7, 18*0/
C...Reset number of channels and cross-section
NCHN=0
SIGS=0D0
C...Read process to consider.
ISUB=MINT(1)
ISUBSV=ISUB
MAP=MAPPR(ISUB)
C...Read kinematical variables and limits
ISTSB=ISET(ISUBSV)
TAUMIN=VINT(11)
YSTMIN=VINT(12)
CTNMIN=VINT(13)
CTPMIN=VINT(14)
TAUPMN=VINT(16)
TAU=VINT(21)
YST=VINT(22)
CTH=VINT(23)
XT2=VINT(25)
TAUP=VINT(26)
TAUMAX=VINT(31)
YSTMAX=VINT(32)
CTNMAX=VINT(33)
CTPMAX=VINT(34)
TAUPMX=VINT(36)
C...Derive kinematical quantities
TAUE=TAU
IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
X(1)=SQRT(TAUE)*EXP(YST)
X(2)=SQRT(TAUE)*EXP(-YST)
IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
IF(X(1).GT.1D0-1D-7) RETURN
ELSEIF(MINT(45).EQ.3) THEN
X(1)=MIN(1D0-1.1D-10,X(1))
ENDIF
IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
IF(X(2).GT.1D0-1D-7) RETURN
ELSEIF(MINT(46).EQ.3) THEN
X(2)=MIN(1D0-1.1D-10,X(2))
ENDIF
SH=MAX(1D0,TAU*VINT(2))
SQM3=VINT(63)
SQM4=VINT(64)
RM3=SQM3/SH
RM4=SQM4/SH
BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
RPTS=4D0*VINT(71)**2/SH
BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
RM34=MAX(1D-20,2D0*RM3*RM4)
RSQM=1D0+RM34
IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
&RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
IF(ISTSB.EQ.0) THEN
TH=VINT(45)
UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
ELSE
C...Kinematics with incoming masses tricky: now depends on how
C...subprocess has been set up w.r.t. order of incoming partons.
RM1=0D0
IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
RM2=0D0
IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
IF(ISUB.EQ.35) THEN
RM2=MIN(RM1,RM2)
RM1=0D0
ENDIF
BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
& BE12*BE34*CTH)
UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
& BE12*BE34*CTH)
SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
ENDIF
SHR=SQRT(SH)
SH2=SH**2
TH2=TH**2
UH2=UH**2
C...Choice of Q2 scale for hard process (e.g. alpha_s).
IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
Q2=SH
ELSEIF(ISTSB.EQ.8) THEN
IF(MINT(107).EQ.4) Q2=VINT(307)
IF(MINT(108).EQ.4) Q2=VINT(308)
ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
Q2IN1=0D0
IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
Q2IN2=0D0
IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
IF(MSTP(32).EQ.1) THEN
Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
ELSEIF(MSTP(32).EQ.2) THEN
Q2=SQPTH+0.5D0*(SQM3+SQM4)
ELSEIF(MSTP(32).EQ.3) THEN
Q2=MIN(-TH,-UH)
ELSEIF(MSTP(32).EQ.4) THEN
Q2=SH
ELSEIF(MSTP(32).EQ.5) THEN
Q2=-TH
ELSEIF(MSTP(32).EQ.6) THEN
XSF1=X(1)
IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
XSF2=X(2)
IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
& (SQPTH+0.5D0*(SQM3+SQM4))
ELSEIF(MSTP(32).EQ.7) THEN
Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
ELSEIF(MSTP(32).EQ.8) THEN
Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
ELSEIF(MSTP(32).EQ.9) THEN
Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
ELSEIF(MSTP(32).EQ.10) THEN
Q2=VINT(2)
C..Begin JA 040914
ELSEIF(MSTP(32).EQ.11) THEN
Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
ELSEIF(MSTP(32).EQ.12) THEN
Q2=PARP(193)
C..End JA
ELSEIF(MSTP(32).EQ.13) THEN
Q2=SQPTH
ENDIF
IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
& (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
ENDIF
C...Choice of Q2 scale for parton densities.
Q2SF=Q2
C..Begin JA 040914
IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
& .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
& Q2=PARP(194)
C..End JA
IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
Q2SF=PMAS(23,1)**2
IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
& ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
& ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
IF(MSTP(39).EQ.2) Q2SF=
& MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
IF(MSTP(39).EQ.3) Q2SF=SH
IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
C..Begin JA 040914
IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
IF(MSTP(39).EQ.7) Q2SF=
& (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
IF(MSTP(39).EQ.8) Q2SF=PARP(193)
C..End JA
ENDIF
ENDIF
IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
Q2PS=Q2SF
Q2SF=Q2SF*PARP(34)
IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
IF(MSTP(69).GE.2) Q2SF=VINT(2)
C...Identify to which class(es) subprocess belongs
ISMECR=0
ISQCD=0
ISJETS=0
IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
& ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
& ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
& ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
& ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
IF (ISTSB.EQ.9) ISQCD=1
IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
& (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
& ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
& ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
& (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
& ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
& ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
& (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
C...WBF is special case of ISJETS
IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
& (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
& ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
& (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
& ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
& ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
& ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
& ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
& ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
C...Some processes with photons also belong here.
IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
& (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
& ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
& ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
& (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
& (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
C...Choice of Q2 scale for parton-shower activity.
IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
&(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
XBJ=X(2)
IF(MINT(43).EQ.3) XBJ=X(1)
IF(MSTP(22).EQ.1) THEN
Q2PS=-TH
ELSEIF(MSTP(22).EQ.2) THEN
Q2PS=((1D0-XBJ)/XBJ)*(-TH)
ELSEIF(MSTP(22).EQ.3) THEN
Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
ELSE
Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
ENDIF
ENDIF
C...For multiple interactions, start from scale defined above
C...For all other QCD or "+jets"-type events, start shower from pThard.
IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
C...Max shower scale = s for ME corrected processes.
C...(pT-ordering: max pT2 is s/4)
Q2PS=VINT(2)
IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
C...(pT-ordering: max pT2 is s/4)
Q2PS=VINT(2)
IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
ENDIF
IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
C...Elastic and diffractive events not associated with scales so set 0.
IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
Q2SF=0D0
Q2PS=0D0
ENDIF
C...Store derived kinematical quantities
VINT(41)=X(1)
VINT(42)=X(2)
VINT(44)=SH
VINT(43)=SQRT(SH)
VINT(45)=TH
VINT(46)=UH
IF(ISTSB.NE.8) VINT(48)=SQPTH
IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
VINT(50)=TAUP*VINT(2)
VINT(49)=SQRT(MAX(0D0,VINT(50)))
VINT(52)=Q2
VINT(51)=SQRT(Q2)
VINT(54)=Q2SF
VINT(53)=SQRT(Q2SF)
VINT(56)=Q2PS
VINT(55)=SQRT(Q2PS)
C...Set starting scale for multiple interactions
IF (ISUBSV.EQ.95) THEN
XT2GMX=0D0
ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
& ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
& ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
& ISUBSV.NE.96)) THEN
C...All accessible phase space allowed.
XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
ELSE
C...Scale of hard process sets limit.
C...2 -> 1. Limit is tau = x1*x2.
C...2 -> 2. Limit is XT2 for hard process + FS masses.
C...2 -> n > 2. Limit is tau' = tau of outer process.
XT2GMX=VINT(25)
IF(ISTSB.EQ.1) XT2GMX=VINT(21)
IF(ISTSB.EQ.2)
& XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
ENDIF
VINT(62)=0.25D0*XT2GMX*VINT(2)
VINT(61)=SQRT(MAX(0D0,VINT(62)))
C...Calculate parton distributions
IF(ISTSB.LE.0) GOTO 160
IF(MINT(47).GE.2) THEN
DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
XSF=X(I)
IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
IF(ISUB.EQ.99) THEN
IF(MINT(140+I).EQ.0) THEN
XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
ELSE
XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
ENDIF
VINT(40+I)=XSF
Q2SF=VINT(309-I)
ENDIF
MINT(105)=MINT(102+I)
MINT(109)=MINT(106+I)
VINT(120)=VINT(2+I)
C...Default is to use standard PDFs, but for interactions after the first
C...in the new multiple-parton-interactions framework, set which side to
C...evaluate the MPI-modified PDFs on.
MINT(30)=0
IF (MINT(31).GE.1) MINT(30)=I
IF(MSTP(57).LE.1) THEN
CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
ELSE
CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
ENDIF
C...Safety margin against heavy flavour very close to threshold,
C...e.g. caused by mismatch in c and b masses.
IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
XPQ(4)=0D0
XPQ(-4)=0D0
ENDIF
IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
XPQ(5)=0D0
XPQ(-5)=0D0
ENDIF
DO 100 KFL=-25,25
XSFX(I,KFL)=XPQ(KFL)
100 CONTINUE
110 CONTINUE
ENDIF
C...Calculate alpha_em, alpha_strong and K-factor
XW=PARU(102)
XWV=XW
IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
&1D0-(PMAS(24,1)/PMAS(23,1))**2
XW1=1D0-XW
XWC=1D0/(16D0*XW*XW1)
AEM=PYALEM(Q2)
IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
FACK=1D0
FACA=1D0
IF(MSTP(33).EQ.1) THEN
FACK=PARP(31)
ELSEIF(MSTP(33).EQ.2) THEN
FACK=PARP(31)
FACA=PARP(32)/PARP(31)
ELSEIF(MSTP(33).EQ.3) THEN
Q2AS=PARP(33)*Q2
IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
& PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
AS=PYALPS(Q2AS)
C...PS (12 Feb 2010)
C...New options MSTP(33) = 10 and 11
C... 10: use K-factor = PARP(32) only for process 96 (MPI)
C... 11: as for 10, but also use K-factor = PARP(31) for other procs
ELSEIF(MSTP(33).GE.10) THEN
IF (ISUB.EQ.96) THEN
FACK = PARP(32)
ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
FACK = PARP(31)
ENDIF
ENDIF
VINT(138)=1D0
VINT(57)=AEM
VINT(58)=AS
C...Set flags for allowed reacting partons/leptons
DO 140 I=1,2
DO 120 J=-25,25
KFAC(I,J)=0
120 CONTINUE
IF(MINT(44+I).EQ.1) THEN
KFAC(I,MINT(10+I))=1
ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
KFAC(I,MINT(10+I))=1
KFAC(I,22)=1
KFAC(I,24)=1
KFAC(I,-24)=1
ELSE
DO 130 J=-25,25
KFAC(I,J)=KFIN(I,J)
IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
130 CONTINUE
ENDIF
140 CONTINUE
C...Lower and upper limit for fermion flavour loops
MMIN1=0
MMAX1=0
MMIN2=0
MMAX2=0
DO 150 J=-20,20
IF(KFAC(1,-J).EQ.1) MMIN1=-J
IF(KFAC(1,J).EQ.1) MMAX1=J
IF(KFAC(2,-J).EQ.1) MMIN2=-J
IF(KFAC(2,J).EQ.1) MMAX2=J
150 CONTINUE
MMINA=MIN(MMIN1,MMIN2)
MMAXA=MAX(MMAX1,MMAX2)
C...Common resonance mass and width combinations
SQMZ=PMAS(23,1)**2
SQMW=PMAS(24,1)**2
GMMZ=PMAS(23,1)*PMAS(23,2)
GMMW=PMAS(24,1)*PMAS(24,2)
C...Polarization factors...implemented so far for W+W-(25)
POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
C...Phase space integral in tau
COMFAC=PARU(1)*PARU(5)/VINT(2)
IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
&ISTSB.NE.8.AND.ISTSB.NE.9) THEN
ATAU1=LOG(TAUMAX/TAUMIN)
ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
IF(MINT(72).GE.1) THEN
TAUR1=VINT(73)
GAMR1=VINT(74)
ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
ATAU3=ATAUD/TAUR1
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
ATAU4=ATAUD/GAMR1
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
ENDIF
IF(MINT(72).GE.2) THEN
TAUR2=VINT(75)
GAMR2=VINT(76)
ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
ATAU5=ATAUD/TAUR2
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
ATAU6=ATAUD/GAMR2
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
ENDIF
IF(MINT(72).EQ.3) THEN
TAUR3=VINT(77)
GAMR3=VINT(78)
ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
ATAU50=ATAUD/TAUR3
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
ATAU60=ATAUD/GAMR3
IF(ATAUD.GT.1D-10) H1=H1+
& (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
ENDIF
IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
& MAX(2D-10,1D0-TAU)
ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
& MAX(1D-10,1D0-TAU)
ENDIF
COMFAC=COMFAC*ATAU1/(TAU*H1)
ENDIF
C...Phase space integral in y*
IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
&THEN
AYST0=YSTMAX-YSTMIN
IF(AYST0.LT.1D-10) THEN
COMFAC=0D0
ELSE
AYST1=0.5D0*(YSTMAX-YSTMIN)**2
AYST2=AYST1
AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
& (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
& (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
IF(MINT(45).EQ.3) THEN
YST0=-0.5D0*LOG(TAUE)
AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
& MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
& MAX(1D-10,1D0-EXP(YST-YST0))
ENDIF
IF(MINT(46).EQ.3) THEN
YST0=-0.5D0*LOG(TAUE)
AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
& MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
& MAX(1D-10,1D0-EXP(-YST-YST0))
ENDIF
COMFAC=COMFAC*AYST0/H2
ENDIF
ENDIF
C...2 -> 1 processes: reduction in angular part of phase space integral
C...for case of decaying resonance
ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
& KFPR(ISUB,1).EQ.39) THEN
COMFAC=COMFAC*0.5D0*ACTH0
ELSE
COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
& CTPMAX**3-CTPMIN**3)
ENDIF
ENDIF
C...2 -> 2 processes: angular part of phase space integral
ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
& (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
& (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
& 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
& 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
H3=COEF(ISUBSV,13)+
& (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
& (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
& (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
& (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
C...2 -> 2 processes: take into account final state Breit-Wigners
COMFAC=COMFAC*VINT(80)
ENDIF
C...2 -> 3, 4 processes: phace space integral in tau'
IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
ATAUP1=LOG(TAUPMX/TAUPMN)
ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
H4=COEF(ISUBSV,18)+
& (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
IF(MINT(47).EQ.5) THEN
ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
ELSEIF(MINT(47).GE.6) THEN
ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
ENDIF
COMFAC=COMFAC*ATAUP1/H4
ENDIF
C...2 -> 3, 4 processes: effective W/Z parton distributions
IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
IF(1D0-TAU/TAUP.GT.1D-4) THEN
FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
ELSE
FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
ENDIF
COMFAC=COMFAC*FZW
ENDIF
C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
IF(ISTSB.EQ.5) THEN
COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
& (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
ENDIF
C...Phase space integral for low-pT and multiple interactions
IF(ISTSB.EQ.9) THEN
COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
COMFAC=COMFAC*ATAU1/H1
AYST0=YSTMAX-YSTMIN
AYST1=0.5D0*(YSTMAX-YSTMIN)**2
AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
& (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
& (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
COMFAC=COMFAC*AYST0/H2
IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
C...introduced to make cross-section finite for xT2 -> 0
IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
& (1D0+VINT(149)))
ENDIF
C...Real gamma + gamma: include factor 2 when different nature
160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
&MSTP(14).LE.10) COMFAC=2D0*COMFAC
C...Extra factors to include the effects of
C...longitudinal resolved photons (but not direct or DIS ones).
DO 170 ISDE=1,2
IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
& MINT(106+ISDE).LE.3) THEN
VINT(314+ISDE)=1D0
XY=PARP(166+ISDE)
IF(MSTP(16).EQ.0) THEN
IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
& XY=VINT(304+ISDE)
ELSE
IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
& XY=VINT(308+ISDE)
ENDIF
Q2GA=VINT(306+ISDE)
IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
& Q2GA.GT.0D0) THEN
REDUCE=0D0
IF(MSTP(17).EQ.1) THEN
REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
ELSEIF(MSTP(17).EQ.2) THEN
REDUCE=4D0*Q2GA/(Q2+Q2GA)
ELSEIF(MSTP(17).EQ.3) THEN
PMVIRT=PMAS(PYCOMP(113),1)
REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
PMVIRT=PMAS(PYCOMP(113),1)
REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
PMVIRT=PMAS(PYCOMP(113),1)
REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
PMVSMN=4D0*PARP(15)**2
PMVSMX=4D0*VINT(154)**2
REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
& (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
PMVIRT=PMAS(PYCOMP(113),1)
REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
PMVIRT=PMAS(PYCOMP(113),1)
REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
PMVSMN=4D0*PARP(15)**2
PMVSMX=4D0*VINT(154)**2
REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
ENDIF
BEAMAS=PYMASS(11)
IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
& (1D0-2D0*BEAMAS**2/Q2GA))
VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
ENDIF
ELSE
VINT(314+ISDE)=1D0
ENDIF
COMFAC=COMFAC*VINT(314+ISDE)
170 CONTINUE
C...Evaluate cross sections - done in separate routines by kind
C...of physics, to keep PYSIGH of sensible size.
IF(MAP.EQ.1) THEN
C...Standard QCD (including photons).
CALL PYSGQC(NCHN,SIGS)
ELSEIF(MAP.EQ.2) THEN
C...Heavy flavours.
CALL PYSGHF(NCHN,SIGS)
ELSEIF(MAP.EQ.3) THEN
C...W/Z.
CALL PYSGWZ(NCHN,SIGS)
ELSEIF(MAP.EQ.4) THEN
C...Higgs (2 doublets; including longitudinal W/Z scattering).
CALL PYSGHG(NCHN,SIGS)
ELSEIF(MAP.EQ.5) THEN
C...SUSY.
CALL PYSGSU(NCHN,SIGS)
ELSEIF(MAP.EQ.6) THEN
C...Technicolor.
CALL PYSGTC(NCHN,SIGS)
ELSEIF(MAP.EQ.7) THEN
C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
CALL PYSGEX(NCHN,SIGS)
ELSEIF(MAP.EQ.8) THEN
C... Universal Extra Dimensions
CALL PYXUED(NCHN,SIGS)
ENDIF
C...Multiply with parton distributions
IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
DO 180 ICHN=1,NCHN
IF(MINT(45).GE.2) THEN
KFL1=ISIG(ICHN,1)
SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
ENDIF
IF(MINT(46).GE.2) THEN
KFL2=ISIG(ICHN,2)
SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
ENDIF
SIGS=SIGS+SIGH(ICHN)
180 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYSGQC
C...Subprocess cross sections for QCD processes,
C...including photons.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGQC(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
&/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
C...Local arrays
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
C...Differential cross section expressions.
IF(ISUB.LE.20) THEN
IF(ISUB.EQ.10) THEN
C...f + f' -> f + f' (gamma/Z/W exchange)
FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
DO 110 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
IA=IABS(I)
DO 100 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
JA=IABS(J)
C...Electroweak couplings
EI=KCHG(IA,1)*ISIGN(1,I)/3D0
AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
VI=AI-4D0*EI*XWV
EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
VJ=AJ-4D0*EJ*XWV
EPSIJ=ISIGN(1,I*J)
C...gamma/Z exchange, only gamma exchange, or only Z exchange
IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
& (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
& FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
& 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
ELSEIF(MSTP(21).EQ.2) THEN
FACNCF=FACGGF*EI**2*EJ**2
ELSE
FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
& (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
ENDIF
C...Extrafactor 2 for only one incoming neutrino spin state.
IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACNCF
ENDIF
C...W exchange
IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
SIGH(NCHN)=FACCCF
ENDIF
100 CONTINUE
110 CONTINUE
ELSEIF(ISUB.EQ.11) THEN
C...f + f' -> f + f' (g exchange)
FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
& MSTP(34)*2D0/3D0*UH2/(SH*TH))
FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
& MSTP(34)*2D0/3D0*SH2/(TH*UH))
DO 130 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
DO 120 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
IF(I.EQ.-J) SIGH(NCHN)=FACQQB
IF(I.EQ.J) THEN
SIGH(NCHN)=0.5D0*SIGH(NCHN)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
SIGH(NCHN)=0.5D0*FACQQ2
ENDIF
120 CONTINUE
130 CONTINUE
ELSEIF(ISUB.EQ.12) THEN
C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
CALL PYWIDT(21,SH,WDTP,WDTE)
FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
& (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
DO 140 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQB
140 CONTINUE
ELSEIF(ISUB.EQ.13) THEN
C...f + fbar -> g + g (q + qbar -> g + g only)
FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2)
FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2)
DO 150 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACGG1
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=0.5D0*FACGG2
150 CONTINUE
ELSEIF(ISUB.EQ.14) THEN
C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
DO 160 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
EI=KCHG(IABS(I),1)/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGG*EI**2
160 CONTINUE
ELSEIF(ISUB.EQ.18) THEN
C...f + fbar -> gamma + gamma
FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
DO 170 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
EI=KCHG(IABS(I),1)/3D0
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
170 CONTINUE
ENDIF
ELSEIF(ISUB.LE.40) THEN
IF(ISUB.EQ.28) THEN
C...f + g -> f + g (q + g -> q + g only)
FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
& UH/SH)*FACA
FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
& SH/UH)
DO 190 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
DO 180 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQG1
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQG2
180 CONTINUE
190 CONTINUE
ELSEIF(ISUB.EQ.29) THEN
C...f + g -> f + gamma (q + g -> q + gamma only)
FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
DO 210 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
EI=KCHG(IABS(I),1)/3D0
FACGQ=FGQ*EI**2
DO 200 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGQ
200 CONTINUE
210 CONTINUE
ELSEIF(ISUB.EQ.33) THEN
C...f + gamma -> f + g (q + gamma -> q + g only)
FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
DO 230 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
EI=KCHG(IABS(I),1)/3D0
FACGQ=FGQ*EI**2
DO 220 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGQ
220 CONTINUE
230 CONTINUE
ELSEIF(ISUB.EQ.34) THEN
C...f + gamma -> f + gamma
FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
DO 250 I=MMINA,MMAXA
IF(I.EQ.0) GOTO 250
EI=KCHG(IABS(I),1)/3D0
FACGQ=FGQ*EI**4
DO 240 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGQ
240 CONTINUE
250 CONTINUE
ENDIF
ELSEIF(ISUB.LE.80) THEN
IF(ISUB.EQ.53) THEN
C...g + g -> f + fbar (g + g -> q + qbar only)
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
IDC0=MDCY(21,2)-1
C...Begin by d, u, s flavours.
FLAVWT=0D0
IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2)*FLAVWT*FACA
FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2)*FLAVWT*FACA
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2
C...Next c and b flavours: modified that and uhat for fixed
C...cos(theta-hat).
DO 260 IFL=4,5
SQMAVG=PMAS(IFL,1)**2
IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
BE34=SQRT(1D0-4D0*SQMAVG/SH)
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
THUHQ=THQ*UHQ-SQMAVG*SH
IF(MSTP(34).EQ.0) THEN
FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
ELSE
FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
ENDIF
FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1+2*(IFL-3)
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2+2*(IFL-3)
SIGH(NCHN)=FACQQ2
ENDIF
260 CONTINUE
270 CONTINUE
ELSEIF(ISUB.EQ.54) THEN
C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
CALL PYWIDT(21,SH,WDTP,WDTE)
WDTESU=0D0
DO 280 I=1,MIN(8,MDCY(21,3))
EF=KCHG(I,1)/3D0
WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
& WDTE(I,4))
280 CONTINUE
FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
ELSEIF(ISUB.EQ.58) THEN
C...gamma + gamma -> f + fbar
CALL PYWIDT(22,SH,WDTP,WDTE)
WDTESU=0D0
DO 290 I=1,MIN(12,MDCY(22,3))
IF(I.LE.8) EF= KCHG(I,1)/3D0
IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
& WDTE(I,4))
290 CONTINUE
FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACFF
ENDIF
ELSEIF(ISUB.EQ.68) THEN
C...g + g -> g + g
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
& TH2/SH2)*FACA
FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
& SH2/UH2)*FACA
FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
& UH2/TH2)
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACGG1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=0.5D0*FACGG2
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=0.5D0*FACGG3
300 CONTINUE
ELSEIF(ISUB.EQ.80) THEN
C...q + gamma -> q' + pi+/-
FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
DELSH=UH*SQRT(ASSH*Q2FPSH)
ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
DELUH=SH*SQRT(ASUH*Q2FPUH)
DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
IF(I.EQ.0) GOTO 320
EI=KCHG(IABS(I),1)/3D0
EJ=SIGN(1D0-ABS(EI),EI)
DO 310 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
310 CONTINUE
320 CONTINUE
ENDIF
ELSEIF(ISUB.LE.100) THEN
IF(ISUB.EQ.91) THEN
C...Elastic scattering
SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
ELSEIF(ISUB.EQ.92) THEN
C...Single diffractive scattering (first side, i.e. XB)
SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
ELSEIF(ISUB.EQ.93) THEN
C...Single diffractive scattering (second side, i.e. AX)
SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
ELSEIF(ISUB.EQ.94) THEN
C...Double diffractive scattering
SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
ELSEIF(ISUB.EQ.95) THEN
C...Low-pT scattering
SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
ELSEIF(ISUB.EQ.96) THEN
C...Multiple interactions: sum of QCD processes
CALL PYWIDT(21,SH,WDTP,WDTE)
C...q + q' -> q + q'
FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
& MSTP(34)*2D0/3D0*UH2/(SH*TH))
FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
DO 340 I=-5,5
IF(I.EQ.0) GOTO 340
DO 330 J=-5,5
IF(J.EQ.0) GOTO 330
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=111
SIGH(NCHN)=FACQQ1
IF(I.EQ.-J) SIGH(NCHN)=FACQQB
IF(I.EQ.J) THEN
SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=112
SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
ENDIF
330 CONTINUE
340 CONTINUE
C...q + qbar -> q' + qbar' or g + g
FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
& (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2)
FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2)
DO 350 I=-5,5
IF(I.EQ.0) GOTO 350
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=121
SIGH(NCHN)=FACQQB
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=131
SIGH(NCHN)=0.5D0*FACGG1
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=132
SIGH(NCHN)=0.5D0*FACGG2
350 CONTINUE
C...q + g -> q + g
FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
& UH/SH)*FACA
FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
& SH/UH)
DO 370 I=-5,5
IF(I.EQ.0) GOTO 370
DO 360 ISDE=1,2
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=281
SIGH(NCHN)=FACQG1
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=282
SIGH(NCHN)=FACQG2
360 CONTINUE
370 CONTINUE
C...g + g -> q + qbar (only d, u, s)
IDC0=MDCY(21,2)-1
FLAVWT=0D0
IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2)*FLAVWT*FACA
FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2)*FLAVWT*FACA
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=531
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=532
SIGH(NCHN)=FACQQ2
C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
C...cos(theta-hat)
DO 380 IFL=4,5
SQMAVG=PMAS(IFL,1)**2
IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
BE34=SQRT(1D0-4D0*SQMAVG/SH)
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
THUHQ=THQ*UHQ-SQMAVG*SH
IF(MSTP(34).EQ.0) THEN
FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
ELSE
FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
ENDIF
FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=531+2*(IFL-3)
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=532+2*(IFL-3)
SIGH(NCHN)=FACQQ2
ENDIF
380 CONTINUE
C...g + g -> g + g
FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
& 2D0*TH/SH+TH2/SH2)*FACA
FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
& 2D0*SH/UH+SH2/UH2)*FACA
FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
& 2D0*UH/TH+UH2/TH2)
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=681
SIGH(NCHN)=0.5D0*FACGG1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=682
SIGH(NCHN)=0.5D0*FACGG2
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=683
SIGH(NCHN)=0.5D0*FACGG3
ELSEIF(ISUB.EQ.99) THEN
C...f + gamma* -> f.
IF(MINT(107).EQ.4) THEN
Q2GA=VINT(307)
P2GA=VINT(308)
ISDE=2
ELSE
Q2GA=VINT(308)
P2GA=VINT(307)
ISDE=1
ENDIF
COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
PM2RHO=PMAS(PYCOMP(113),1)**2
IF(MSTP(19).EQ.0) THEN
COMFAC=COMFAC/Q2GA
ELSEIF(MSTP(19).EQ.1) THEN
COMFAC=COMFAC/(Q2GA+PM2RHO)
ELSEIF(MSTP(19).EQ.2) THEN
COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
ELSE
COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
W2GA=VINT(2)
IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
& Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
ELSE
RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
& Q2GA**0.57D0)
XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
ENDIF
COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
ENDIF
DO 390 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
EI=KCHG(IABS(I),1)/3D0
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=COMFAC*EI**2
390 CONTINUE
ENDIF
ELSE
IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
C...g + g -> gamma + gamma or g + g -> g + gamma
A0STUR=0D0
A0STUI=0D0
A0TSUR=0D0
A0TSUI=0D0
A0UTSR=0D0
A0UTSI=0D0
A1STUR=0D0
A1STUI=0D0
A2STUR=0D0
A2STUI=0D0
ALST=LOG(-SH/TH)
ALSU=LOG(-SH/UH)
ALTU=LOG(TH/UH)
IMAX=2*MSTP(1)
IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
DO 400 I=1,IMAX
EI=KCHG(IABS(I),1)/3D0
EIWT=EI**2
IF(ISUB.EQ.115) EIWT=EI
SQMQ=PMAS(I,1)**2
EPSS=4D0*SQMQ/SH
EPST=4D0*SQMQ/TH
EPSU=4D0*SQMQ/UH
IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
& PARU(1)**2)
B0STUI=0D0
B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
B1STUR=-1D0
B1STUI=0D0
B2STUR=-1D0
B2STUI=0D0
ELSE
CALL PYWAUX(1,EPSS,W1SR,W1SI)
CALL PYWAUX(1,EPST,W1TR,W1TI)
CALL PYWAUX(1,EPSU,W1UR,W1UI)
CALL PYWAUX(2,EPSS,W2SR,W2SI)
CALL PYWAUX(2,EPST,W2TR,W2TI)
CALL PYWAUX(2,EPSU,W2UR,W2UI)
CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
& 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
& 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
& 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
& 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
& 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
& 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
& 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
& 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
& 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
& 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
& 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
& 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
& 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
& 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
& 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
& 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
& 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
& 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
& 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
& 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
& 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
& 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
& 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
& 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
& 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
& 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
& 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
& 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
& 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
& 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
& 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
& 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
& 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
& 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
& 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
& 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
& 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
& 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
& 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
& 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
ENDIF
A0STUR=A0STUR+EIWT*B0STUR
A0STUI=A0STUI+EIWT*B0STUI
A0TSUR=A0TSUR+EIWT*B0TSUR
A0TSUI=A0TSUI+EIWT*B0TSUI
A0UTSR=A0UTSR+EIWT*B0UTSR
A0UTSI=A0UTSI+EIWT*B0UTSI
A1STUR=A1STUR+EIWT*B1STUR
A1STUI=A1STUI+EIWT*B1STUI
A2STUR=A2STUR+EIWT*B2STUR
A2STUI=A2STUI+EIWT*B2STUI
400 CONTINUE
ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
& A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
410 CONTINUE
ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
PH=0D0
IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
& PH=VINT(3)**2
IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
& PH=VINT(4)**2
IF(ISUB.EQ.131) THEN
FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
& ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
ELSE
FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
ENDIF
DO 430 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
EI=KCHG(IABS(I),1)/3D0
FACGQ=FGQ*EI**2
DO 420 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGQ
420 CONTINUE
430 CONTINUE
ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
C...f + gamma*_(T,L) -> f + gamma
PH=0D0
IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
& PH=VINT(3)**2
IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
& PH=VINT(4)**2
IF(ISUB.EQ.133) THEN
FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
& ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
ELSE
FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
ENDIF
DO 450 I=MMINA,MMAXA
IF(I.EQ.0) GOTO 450
EI=KCHG(IABS(I),1)/3D0
FACGQ=FGQ*EI**4
DO 440 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGQ
440 CONTINUE
450 CONTINUE
ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
PH=0D0
IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
& PH=VINT(3)**2
IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
& PH=VINT(4)**2
CALL PYWIDT(21,SH,WDTP,WDTE)
WDTESU=0D0
DO 460 I=1,MIN(8,MDCY(21,3))
EF=KCHG(I,1)/3D0
WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
& WDTE(I,4))
460 CONTINUE
IF(ISUB.EQ.135) THEN
FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
& ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
ELSE
FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
ENDIF
IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
PH1=0D0
IF(VINT(3).LT.0D0) PH1=VINT(3)**2
PH2=0D0
IF(VINT(4).LT.0D0) PH2=VINT(4)**2
CALL PYWIDT(22,SH,WDTP,WDTE)
WDTESU=0D0
DO 470 I=1,MIN(12,MDCY(22,3))
IF(I.LE.8) EF= KCHG(I,1)/3D0
IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
& WDTE(I,4))
470 CONTINUE
DLAMB2=(TH+UH)**2-4D0*PH1*PH2
IF(ISUB.EQ.137) THEN
FPARAM=-SH*(TH+UH)/DLAMB2
FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
& (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
& 2D0*PH1*PH2*FPARAM**2)
ELSEIF(ISUB.EQ.138) THEN
FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
& PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
& 2D0*PH1**2*(TH-UH)**2)
ELSEIF(ISUB.EQ.139) THEN
FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
& PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
& 2D0*PH2**2*(TH-UH)**2)
ELSE
FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
& PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
ENDIF
IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACFF
ENDIF
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYSGHF
C...Subprocess cross sections for heavy flavour production,
C...open and closed.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGHF(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
&/PYINT4/,/PYSGCM/
C...Local arrays
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
C...Determine where are charmonium/bottomonium wave function parameters.
IONIUM=140
IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
C...Convert bottomonium process into equivalent charmonium ones.
IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
C...Differential cross section expressions.
IF(ISUB.LE.100) THEN
IF(ISUB.EQ.81) THEN
C...q + qbar -> Q + Qbar
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
& 2D0*SQMAVG/SH)
IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
WID2=1D0
IF(MINT(55).EQ.6) WID2=WIDS(6,1)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
FACQQB=FACQQB*WID2
DO 100 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQB
100 CONTINUE
ELSEIF(ISUB.EQ.82) THEN
C...g + g -> Q + Qbar
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
THUHQ=THQ*UHQ-SQMAVG*SH
IF(MSTP(34).EQ.0) THEN
FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
ELSE
FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
ENDIF
FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
IF(MSTP(35).GE.1) THEN
FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
FACQQ1=FACQQ1*FATRE
FACQQ2=FACQQ2*FATRE
ENDIF
WID2=1D0
IF(MINT(55).EQ.6) WID2=WIDS(6,1)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
FACQQ1=FACQQ1*WID2
FACQQ2=FACQQ2*WID2
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2
110 CONTINUE
ELSEIF(ISUB.EQ.83) THEN
C...f + q -> f' + Q
FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
DO 130 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
DO 120 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
& THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
& (IABS(I)+1)/2)*VINT(180+J)
IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
& (MINT(55)+1)/2)*VINT(180+J)
WID2=1D0
IF(I.GT.0) THEN
IF(MINT(55).EQ.6) WID2=WIDS(6,2)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
& WIDS(MINT(55),2)
ELSE
IF(MINT(55).EQ.6) WID2=WIDS(6,3)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
& WIDS(MINT(55),3)
ENDIF
IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
ENDIF
IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
& THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
& (IABS(J)+1)/2)*VINT(180+I)
IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
& (MINT(55)+1)/2)*VINT(180+I)
WID2=1D0
IF(J.GT.0) THEN
IF(MINT(55).EQ.6) WID2=WIDS(6,2)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
& WIDS(MINT(55),2)
ELSE
IF(MINT(55).EQ.6) WID2=WIDS(6,3)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
& WIDS(MINT(55),3)
ENDIF
IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
ENDIF
120 CONTINUE
130 CONTINUE
ELSEIF(ISUB.EQ.84) THEN
C...g + gamma -> Q + Qbar
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
& (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
& (THQ*UHQ)
IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
WID2=1D0
IF(MINT(55).EQ.6) WID2=WIDS(6,1)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
FACQQ=FACQQ*WID2
IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ
ENDIF
ELSEIF(ISUB.EQ.85) THEN
C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
& ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
& (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
& SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
& FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
WID2=1D0
IF(MINT(56).EQ.6) WID2=WIDS(6,1)
IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
IF(MINT(56).EQ.17) WID2=WIDS(17,1)
FACFF=FACFF*WID2
IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACFF
ENDIF
ELSEIF(ISUB.EQ.86) THEN
C...g + g -> J/Psi + g
FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
& (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
& ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ELSEIF(ISUB.EQ.87) THEN
C...g + g -> chi_0c + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQM3/SH
FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
& (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
& 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
& PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
& 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
& (QGTW*(QGTW-RGTW*PGTW)**4)
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ELSEIF(ISUB.EQ.88) THEN
C...g + g -> chi_1c + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQM3/SH
FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
& PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
& 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
& (QGTW-RGTW*PGTW)**4
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ELSEIF(ISUB.EQ.89) THEN
C...g + g -> chi_2c + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQM3/SH
FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
& (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
& 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
& 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
& RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
& QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ENDIF
ELSEIF(ISUB.LE.200) THEN
IF(ISUB.EQ.104) THEN
C...g + g -> chi_c0.
KC=PYCOMP(10441)
FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
& ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACBW
ENDIF
ELSEIF(ISUB.EQ.105) THEN
C...g + g -> chi_c2.
KC=PYCOMP(445)
FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
& ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACBW
ENDIF
ELSEIF(ISUB.EQ.106) THEN
C...g + g -> J/Psi + gamma.
EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
& (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
& ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ELSEIF(ISUB.EQ.107) THEN
C...g + gamma -> J/Psi + g.
EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
& (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
& ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ELSEIF(ISUB.EQ.108) THEN
C...gamma + gamma -> J/Psi + gamma.
EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
& (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
& ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG
ENDIF
ENDIF
C...QUARKONIA+++
C...Additional code by Stefan Wolf
ELSE
C...Common code for quarkonium production.
SHTH=SH+TH
THUH=TH+UH
UHSH=UH+SH
SHTH2=SHTH**2
THUH2=THUH**2
UHSH2=UHSH**2
IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
& (ISUB.GE.431.AND.ISUB.LE.433)) THEN
SQMQQ=SQM3
ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
& (ISUB.GE.434.AND.ISUB.LE.439)) THEN
SQMQQ=SQM4
ENDIF
SQMQQR=SQRT(SQMQQ)
IF(MSTP(145).EQ.1) THEN
IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
& (ISUB.GE.431.AND.ISUB.LE.436)) THEN
AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
& ISUB.GE.437) THEN
AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
ENDIF
AQ2=AQ**2
BQ2=BQ**2
SMQQ2=SQMQQ*VINT(2)
C...Polarisation frames
IF(MSTP(146).EQ.1) THEN
C...Recoil frame
POLH1=SQRT(AQ2-SMQQ2)
POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
AZ=-SQMQQR/POLH1
BZ=0D0
AX=AQ*BQ/(POLH1*POLH2)
BX=-POLH1/POLH2
ELSEIF(MSTP(146).EQ.2) THEN
C...Gottfried Jackson frame
POLH1=AQ+BQ
POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
AZ=SQMQQR/POLH1
BZ=AZ
AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
ELSEIF(MSTP(146).EQ.3) THEN
C...Target frame
POLH1=AQ-BQ
POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
AZ=-SQMQQR/POLH1
BZ=-AZ
AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
ELSEIF(MSTP(146).EQ.4) THEN
C...Collins Soper frame
POLH1=AQ2-BQ2
POLH2=SQRT(VINT(2)*POLH1)
AZ=-BQ/POLH2
BZ=AQ/POLH2
AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
ENDIF
C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
EL1K10=AZ*ATILK1+BZ*BTILK1
EL1K20=AZ*ATILK2+BZ*BTILK2
EL2K10=EL1K10
EL2K20=EL1K20
EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
EL2K11=EL1K11
EL2K21=EL1K21
ENDIF
IF(ISUB.EQ.421) THEN
C...g + g -> QQ~[3S11] + g
IF(MSTP(145).EQ.0) THEN
* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
& (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
ELSE
FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
BB=2D0*(SH2+TH2)
CC=2D0*(SH2+UH2)
DD=2D0*SH2
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
ENDIF
ELSEIF(ISUB.EQ.422) THEN
C...g + g -> QQ~[3S18] + g
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
& (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
& (SQMQQ*SQMQQR)*
& ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
ELSE
FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
& (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
BB=2D0*(SH2+TH2)
CC=2D0*(SH2+UH2)
DD=2D0*SH2
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
FACGGS=FACGG1+FACGG2+FACGG3
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
ENDIF
ELSEIF(ISUB.EQ.423) THEN
C...g + g -> QQ~[1S08] + g
IF(MSTP(145).EQ.0) THEN
* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
* & (SHTH2*THUH2*UHSH2)
FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
& (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
& TH2/(SHTH2*THUH2))*
& (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
ELSE
FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
& (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
& TH2/(SHTH2*THUH2))*
& (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FA
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
FACGGS=FACGG1+FACGG2+FACGG3
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
ENDIF
ELSEIF(ISUB.EQ.424) THEN
C...g + g -> QQ~[3PJ8] + g
POLY=SH2+SH*TH+TH2
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
& -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
& +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
& +7D0*TH**6)
& +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
& +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
& +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
& +35D0*TH**8)
& -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
& +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
& +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
& +84D0*TH**8)
& +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
& +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
& +451D0*SH*TH**5+126D0*TH**6)
& -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
& +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
& +171D0*SH*TH**5+42D0*TH**6)
& +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
& +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
& -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
& +99D0*SH*TH**3+35D0*TH**4)
& +7D0*SQMQQ**8*SHTH*POLY)/
& (SH*TH*UH*SQMQQR*SQMQQ*
& SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
ELSE
FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
& *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
& -SQMQQ*SHTH2*POLY**2*
& (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
& +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
& +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
& +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
& -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
& +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
& +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
& +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
& +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
& +145D0*SH*TH**5+34D0*TH**6)
& -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
& +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
& +44D0*TH**6)
& +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
& +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
& -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
& *(5D0*SH2+11D0*SH*TH+5D0*TH2)
& +3D0*SQMQQ**8*SHTH*POLY)
BB=4D0*SHTH2*POLY**3
& *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
& -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
& +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
& +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
& +84D0*SH*TH**9+20D0*TH**10)
& +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
& +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
& +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
& +40D0*TH**8)
& -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
& -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
& -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
& +40D0*TH**8)
& +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
& -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
& -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
& -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
& -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
& +4D0*TH**6)
& -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
& +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
& +8D0*SQMQQ**7*SH*TH*SHTH*POLY
CC=4D0*TH2*POLY**3
& *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
& -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
& +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
& +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
& +28D0*TH**9)
& +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
& -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
& +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
& +394D0*SH*TH**9+84D0*TH**10)
& -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
& +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
& +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
& +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
& +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
& +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
& -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
& +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
& +266D0*SH*TH**6+84D0*TH**7)
& +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
& -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
& +28D0*TH**6)
& -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
& +7D0*SH*TH**3+4*TH**4)
& +SQMQQ**8*SH*(SH-TH)**2*TH
DD=2D0*TH2*SHTH2*POLY**3
& *(-SH2+2*SH*TH+2*TH2)
& +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
& +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
& -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
& -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
& -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
& +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
& -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
& -210D0*SH*TH**8-60D0*TH**9)
& +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
& +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
& -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
& -80D0*TH**8)
& -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
& +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
& -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
& +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
& +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
& -30D0*SH*TH**6-24D0*TH**7)
& -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
& +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
& -4D0*TH**6)
& +4D0*SQMQQ**7*SH*TH*SHTH*POLY
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
FACGGS=FACGG1+FACGG2+FACGG3
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
ENDIF
ELSEIF(ISUB.EQ.425) THEN
C...q + g -> q + QQ~[3S18]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
& (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
& (SQMQQ*SQMQQR*SH*UH*UHSH2)
ELSE
FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
& (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
AA=SHTH2+THUH2
BB=4D0
CC=8D0
DD=4D0
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
FACQGS=FACQG1+FACQG2
DO 2442 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
DO 2441 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
2441 CONTINUE
2442 CONTINUE
ELSEIF(ISUB.EQ.426) THEN
C...q + g -> q + QQ~[1S08]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
& (SH2+UH2)/(SQMQQR*TH*UHSH2)
ELSE
FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FA
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
FACQGS=FACQG1+FACQG2
DO 2444 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
DO 2443 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
2443 CONTINUE
2444 CONTINUE
ELSEIF(ISUB.EQ.427) THEN
C...q + g -> q + QQ~[3PJ8]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
& ((7D0*UHSH+8D0*TH)*(SH2+UH2)
& +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
& (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
ELSE
FF=10D0*PARU(1)*AS**3/
& (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
BB=8D0*(SHTH2+TH*UH)
CC=8D0*UHSH*(SHTH+THUH)
DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
FACQGS=FACQG1+FACQG2
DO 2446 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
DO 2445 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
2445 CONTINUE
2446 CONTINUE
ELSEIF(ISUB.EQ.428) THEN
C...q + q~ -> g + QQ~[3S18]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
& (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
& (SQMQQ*SQMQQR*TH*UH*THUH2)
ELSE
FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
& (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
AA=SHTH2+UHSH2
BB=4D0
CC=4D0
DD=0D0
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=UH/TH-9D0/4D0*UH2/SH2
FACGG2=TH/UH-9D0/4D0*TH2/SH2
FACGGS=FACGG1+FACGG2
DO 2447 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
2447 CONTINUE
ELSEIF(ISUB.EQ.429) THEN
C...q + q~ -> g + QQ~[1S08]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
& (TH2+UH2)/(SQMQQR*SH*THUH2)
ELSE
FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FA
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=UH/TH-9D0/4D0*UH2/SH2
FACGG2=TH/UH-9D0/4D0*TH2/SH2
FACGGS=FACGG1+FACGG2
DO 2448 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
2448 CONTINUE
ELSEIF(ISUB.EQ.430) THEN
C...q + q~ -> g + QQ~[3PJ8]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
& ((7D0*THUH+8D0*SH)*(TH2+UH2)
& +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
& (SQMQQ*SQMQQR*SH*THUH2*THUH)
ELSE
FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
BB=8D0*(UHSH2+SH*TH)
CC=8D0*(SHTH2+SH*UH)
DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
IF(MSTP(147).EQ.0) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
& +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
& +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
& +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
THP=-0.5D0*SH*(1D0-CTH)
UHP=-0.5D0*SH*(1D0+CTH)
FACGG1=UH/TH-9D0/4D0*UH2/SH2
FACGG2=TH/UH-9D0/4D0*TH2/SH2
FACGGS=FACGG1+FACGG2
DO 2449 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
2449 CONTINUE
ELSEIF(ISUB.EQ.431) THEN
C...g + g -> QQ~[3P01] + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQMQQ/SH
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
& (9D0*RGTW**2*PGTW**4*
& (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
& -6D0*RGTW*PGTW**3*QGTW*
& (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
& -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
& +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
& +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
ELSE
FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
& (9D0*RGTW**2*PGTW**4*
& (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
& -6D0*RGTW*PGTW**3*QGTW*
& (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
& -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
& +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
& +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FC1
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FC1
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FC1
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FC1
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
ENDIF
ELSEIF(ISUB.EQ.432) THEN
C...g + g -> QQ~[3P11] + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQMQQ/SH
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
& PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
& +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
& -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
ELSE
FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
& +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
& -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
& +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
& -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
& *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
& -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
& *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
C4=-4D0*THUH*(TH-UH)**2*
& (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
& -SH2*TH*UH*(TH2+UH2))
& +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
& -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
& +SH2*(5D0*THUH2-17D0*TH*UH)))
IF(MSTP(147).EQ.0) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
& +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
ENDIF
ELSEIF(ISUB.EQ.433) THEN
C...g + g -> QQ~[3P21] + g
PGTW=(SH*TH+TH*UH+UH*SH)/SH2
QGTW=(SH*TH*UH)/SH**3
RGTW=SQMQQ/SH
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
& (12D0*RGTW**2*PGTW**4*
& (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
& -3D0*RGTW*PGTW**3*QGTW*
& (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
& +2D0*PGTW**2*QGTW**2*
& (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
& +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
& +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
ELSE
FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
& (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
& *SH*SH2**7
C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
& +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
& +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
& +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
& +10D0*(SH2**2+TH2**2))
& +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
& -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
& -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
& +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
& +4D0*SH*TH*UH2**4*SHTH2)
C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
& +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
& +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
& +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
& +10D0*(SH2**2+UH2**2))
& +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
& -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
& -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
& +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
& +4D0*SH*UH*TH2**4*UHSH2)
C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
& -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
& +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
& -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
& -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
& -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
& +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
& -SH2**2*TH*UH*(114D0*TH**3*UH**3
& +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
& +3D0*(TH2**3+UH2**3)))
C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
& *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
& *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
& +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
& +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
& 82D0*TH**3)
& +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
& +45D0*TH**3)
& +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
& 8D0*TH**3)
& +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
& +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
& +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
& +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
& +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
& 82D0*UH**3)
& +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
& +45D0*UH**3)
& +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
& 8D0*UH**3)
& +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
& +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
& +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
& +4D0*SH*TH2**2*UH2**2*THUH2
& -SH2*TH**3*UH**3*THUH*(TH2+UH2)
& -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
& +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
& +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
& +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
& -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
& -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
& -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
& +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
& +SH**5*TH*UH*(-428D0*TH**3*UH**3
& -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
& +2D0*(TH2**3+UH2**3))
& +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
& +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
& +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
& +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
IF(MSTP(147).EQ.0) THEN
FACQQG=1D0/3D0*(C1*3D0
& -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
& +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
& +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K20*EL2K20-EL1K21*EL2K21)
& +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=C1*2D0
& -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
& +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
& +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K11*EL2K11)
& +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K21*EL2K21)
& +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
& +C0*(EL1K10*EL2K10*EL1K21*EL2K21
& +2D0*EL1K10*EL2K20*EL1K11*EL2K21
& +EL1K20*EL2K20*EL1K11*EL2K11)
ELSEIF(MSTP(147).EQ.2) THEN
FACQQG=2D0*(C1
& -C2*EL1K11*EL2K11
& -C3*EL1K21*EL2K21
& -C4*EL1K11*EL2K21
& +C5*(EL1K11*EL2K11)**2
& +C6*(EL1K21*EL2K21)**2
& +C7*EL1K11*EL2K11*EL1K11*EL2K21
& +C8*EL1K21*EL2K21*EL1K11*EL2K21
& +(C9+C0)*(EL1K11*EL2K21)**2)
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
ENDIF
ELSEIF(ISUB.EQ.434) THEN
C...q + g -> q + QQ~[3P01]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
& (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
ELSE
FA=-PARU(1)*AS**3*(16D0/243D0)*
& (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FA
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
DO 2452 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
DO 2451 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2451 CONTINUE
2452 CONTINUE
ELSEIF(ISUB.EQ.435) THEN
C...q + g -> q + QQ~[3P11]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
& (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
ELSE
FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
C1=SH*UH
C2=2D0*SH
C3=0D0
C4=2D0*(SH-UH)
IF(MSTP(147).EQ.0) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
& +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
DO 2454 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
DO 2453 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2453 CONTINUE
2454 CONTINUE
ELSEIF(ISUB.EQ.436) THEN
C...q + g -> q + QQ~[3P21]
IF(MSTP(145).EQ.0) THEN
FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
& ((6D0*SQMQQ**2+TH2)*UHSH2
& -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
& (SQMQQR*TH*UHSH2**2)
ELSE
FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
C1=TH*UHSH2
C2=4D0*(SH2+TH2+2D0*TH*UHSH)
C3=4D0*UHSH2
C4=8D0*SH*UHSH
C5=8D0*TH
C6=0D0
C7=16D0*TH
C8=0D0
C9=-16D0*UHSH
C0=16D0*SQMQQ
IF(MSTP(147).EQ.0) THEN
FACQQG=1D0/3D0*(C1*3D0
& -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
& +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
& +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K20*EL2K20-EL1K21*EL2K21)
& +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=C1*2D0
& -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
& +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
& +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K11*EL2K11)
& +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K21*EL2K21)
& +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
& +C0*(EL1K10*EL2K10*EL1K21*EL2K21
& +2D0*EL1K10*EL2K20*EL1K11*EL2K21
& +EL1K20*EL2K20*EL1K11*EL2K11)
ELSEIF(MSTP(147).EQ.2) THEN
FACQQG=2D0*(C1
& -C2*EL1K11*EL2K11
& -C3*EL1K21*EL2K21
& -C4*EL1K11*EL2K21
& +C5*(EL1K11*EL2K11)**2
& +C6*(EL1K21*EL2K21)**2
& +C7*EL1K11*EL2K11*EL1K11*EL2K21
& +C8*EL1K21*EL2K21*EL1K11*EL2K21
& +(C9+C0)*(EL1K11*EL2K21)**2)
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
DO 2456 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
DO 2455 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2455 CONTINUE
2456 CONTINUE
ELSEIF(ISUB.EQ.437) THEN
C...q + q~ -> g + QQ~[3P01]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
& (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
ELSE
FA=PARU(1)*AS**3*(128D0/729D0)*
& (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
IF(MSTP(147).EQ.0) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=COMFAC*2D0*FA
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=COMFAC*FA
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=0D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=0D0
ENDIF
ENDIF
DO 2457 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2457 CONTINUE
ELSEIF(ISUB.EQ.438) THEN
C...q + q~ -> g + QQ~[3P11]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
& (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
ELSE
FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
C1=TH*UH
C2=2D0*UH
C3=2D0*TH
C4=2D0*THUH
IF(MSTP(147).EQ.0) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
ELSEIF(MSTP(147).EQ.3) THEN
FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
& +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.4) THEN
FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ELSEIF(MSTP(147).EQ.5) THEN
FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
& +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
ELSEIF(MSTP(147).EQ.6) THEN
FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
& +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
DO 2458 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2458 CONTINUE
ELSEIF(ISUB.EQ.439) THEN
C...q + q~ -> g + QQ~[3P21]
IF(MSTP(145).EQ.0) THEN
FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
& ((6D0*SQMQQ**2+SH2)*THUH2
& -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
& (SQMQQR*SH*THUH2**2)
ELSE
FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
C1=SH*THUH2
C2=4D0*(SH2+UH2+2D0*SH*THUH)
C3=4D0*(SH2+TH2+2D0*SH*THUH)
C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
C5=8D0*SH
C6=C5
C7=16D0*SH
C8=C7
C9=-16D0*THUH
C0=16D0*SQMQQ
IF(MSTP(147).EQ.0) THEN
FACQQG=1D0/3D0*(C1*3D0
& -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
& +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
& +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
& *(EL1K10*EL2K20-EL1K11*EL2K21)
& +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
& *(EL1K20*EL2K20-EL1K21*EL2K21)
& +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
ELSEIF(MSTP(147).EQ.1) THEN
FACQQG=C1*2D0
& -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
& -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
& -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
& +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
& +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
& +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K11*EL2K11)
& +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
& +EL1K10*EL2K20*EL1K21*EL2K21)
& +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
& +C0*(EL1K10*EL2K10*EL1K21*EL2K21
& +2D0*EL1K10*EL2K20*EL1K11*EL2K21
& +EL1K20*EL2K20*EL1K11*EL2K11)
ELSEIF(MSTP(147).EQ.2) THEN
FACQQG=2D0*(C1
& -C2*EL1K11*EL2K11
& -C3*EL1K21*EL2K21
& -C4*EL1K11*EL2K21
& +C5*(EL1K11*EL2K11)**2
& +C6*(EL1K21*EL2K21)**2
& +C7*EL1K11*EL2K11*EL1K11*EL2K21
& +C8*EL1K21*EL2K21*EL1K11*EL2K21
& +(C9+C0)*(EL1K11*EL2K21)**2)
ENDIF
FACQQG=COMFAC*FF*FACQQG
ENDIF
DO 2459 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
2459 CONTINUE
ENDIF
C...QUARKONIA---
ENDIF
RETURN
END
C*********************************************************************
C...PYSGWZ
C...Subprocess cross sections for W/Z processes,
C...except that longitudinal WW scattering is in Higgs sector.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGWZ(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays and complex numbers
DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
&HL4(3),HR4(3)
COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
C...Differential cross section expressions.
IF(ISUB.LE.20) THEN
IF(ISUB.EQ.1) THEN
C...f + fbar -> gamma*/Z0
MINT(61)=2
CALL PYWIDT(23,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACZ=4D0*COMFAC*3D0
HP0=AEM/3D0*SH
HP1=AEM/3D0*XWC*SH
DO 100 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
HI0=HP0
IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
HI1=HP1
IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
& EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
& (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
& ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
100 CONTINUE
ELSEIF(ISUB.EQ.2) THEN
C...f + fbar' -> W+/-
CALL PYWIDT(24,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
HP=AEM/(24D0*XW)*SH
DO 120 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
IA=IABS(I)
DO 110 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 110
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HI=HP*2D0
IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
SIGH(NCHN)=HI*FACBW*HF
110 CONTINUE
120 CONTINUE
ELSEIF(ISUB.EQ.15) THEN
C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
HFGG=0D0
HFGZ=0D0
HFZZ=0D0
RADC4=1D0+PYALPS(SQM4)/PARU(1)
DO 130 I=1,MIN(16,MDCY(23,3))
IDC=I+MDCY(23,2)-1
IF(MDME(IDC,1).LT.0) GOTO 130
IMDM=0
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
& IMDM=1
IF(I.LE.8) THEN
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ELSEIF(I.LE.16) THEN
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC4
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.EQ.1) THEN
HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
130 CONTINUE
C...Propagators: as simulated in PYOFSH and as desired
HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM4,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
HFGG=HFGG*HFAEM*VINT(111)/SQM4
HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
DO 140 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
& (VI**2+AI**2)*HFZZ)/HBW4
140 CONTINUE
ELSEIF(ISUB.EQ.16) THEN
C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM4,WDTP,WDTE)
GMMWC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
FACWG=FACWG*HBW4C/HBW4
DO 160 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
DO 150 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
FCKM=VCKM((IA+1)/2,(JA+1)/2)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWG*FCKM*WIDSC
150 CONTINUE
160 CONTINUE
ELSEIF(ISUB.EQ.19) THEN
C...f + fbar -> gamma + (gamma*/Z0)
FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
HFGG=0D0
HFGZ=0D0
HFZZ=0D0
RADC4=1D0+PYALPS(SQM4)/PARU(1)
DO 170 I=1,MIN(16,MDCY(23,3))
IDC=I+MDCY(23,2)-1
IF(MDME(IDC,1).LT.0) GOTO 170
IMDM=0
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
& IMDM=1
IF(I.LE.8) THEN
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ELSEIF(I.LE.16) THEN
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC4
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.EQ.1) THEN
HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
170 CONTINUE
C...Propagators: as simulated in PYOFSH and as desired
HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM4,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
HFGG=HFGG*HFAEM*VINT(111)/SQM4
HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
DO 180 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
& (VI**2+AI**2)*HFZZ)/HBW4
180 CONTINUE
ELSEIF(ISUB.EQ.20) THEN
C...f + fbar' -> gamma + W+/-
FACGW=COMFAC*0.5D0*AEM**2/XW
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM4,WDTP,WDTE)
GMMWC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
FACGW=FACGW*HBW4C/HBW4
C...Anomalous couplings
TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
TERM2=0D0
TERM3=0D0
IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
TERM2=RTCM(46)*(TH-UH)/(TH+UH)
TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
& (4D0*SQMW))/(TH+UH)**2
ENDIF
DO 200 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
DO 190 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 190
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
IF(IA.LE.10) THEN
FACWR=UH/(TH+UH)-1D0/3D0
FCKM=VCKM((IA+1)/2,(JA+1)/2)
FCOI=FACA/3D0
ELSE
FACWR=-TH/(TH+UH)
FCKM=1D0
FCOI=1D0
ENDIF
FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
190 CONTINUE
200 CONTINUE
ENDIF
ELSEIF(ISUB.LE.40) THEN
IF(ISUB.EQ.22) THEN
C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
C...Kinematics dependence
FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
& SQM3*SQM4*(1D0/TH2+1D0/UH2))
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
DO 220 I=1,6
DO 210 J=1,3
HGZ(I,J)=0D0
210 CONTINUE
220 CONTINUE
RADC3=1D0+PYALPS(SQM3)/PARU(1)
RADC4=1D0+PYALPS(SQM4)/PARU(1)
DO 230 I=1,MIN(16,MDCY(23,3))
IDC=I+MDCY(23,2)-1
IF(MDME(IDC,1).LT.0) GOTO 230
IMDM=0
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
IF(I.LE.8) THEN
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ELSEIF(I.LE.16) THEN
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC3
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.GE.1) THEN
HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC4
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.GE.1) THEN
HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
230 CONTINUE
C...Propagators: as simulated in PYOFSH and as desired
HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM3,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
DO 240 J=1,3
HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
240 CONTINUE
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM4,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
DO 250 J=1,3
HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
250 CONTINUE
C...Loop over flavours; separate left- and right-handed couplings
DO 270 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
VALI=VI-AI
VARI=VI+AI
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
DO 260 J=1,3
HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
260 CONTINUE
FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
& HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
& HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
& HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
270 CONTINUE
ELSEIF(ISUB.EQ.23) THEN
C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
FACZW=COMFAC*0.5D0*(AEM/XW)**2
FACZW=FACZW*WIDS(23,2)
THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
FACBW=1D0/((SH-SQMW)**2+GMMW**2)
DO 290 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
DO 280 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 280
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
EI=KCHG(IA,1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
EJ=KCHG(JA,1)/3D0
AJ=SIGN(1D0,EJ+0.1D0)
VJ=AJ-4D0*EJ*XWV
IF(VI+AI.GT.0) THEN
VISAV=VI
AISAV=AI
VI=VJ
AI=AJ
VJ=VISAV
AJ=AISAV
ENDIF
FCKM=1D0
IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
FCOI=1D0
IF(IA.LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
& (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
& (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
& THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
& SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
& WIDS(24,(5-KCHW)/2)
C***Protect against slightly negative cross sections. (Reason yet to be
C***sorted out. One possibility: addition of width to the W propagator.)
SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
280 CONTINUE
290 CONTINUE
ELSEIF(ISUB.EQ.25) THEN
C...f + fbar -> W+ + W-
C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
GMMZC=GMMZ
HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM3,WDTP,WDTE)
GMMW3=SQRT(SQM3)*WDTP(0)
HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM4,WDTP,WDTE)
GMMW4=SQRT(SQM4)*WDTP(0)
HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
C...Kinematical functions
THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
GT=THUH34+4D0*THUH/TH2
GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
GU=THUH34+4D0*THUH/UH2
GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
C...Common factors and couplings
FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
FACWW=FACWW*WIDS(24,1)
CGG=AEM**2/2D0
CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
CZZ=AEM**2/(32D0*XW**2)*HBWZC
CNG=AEM**2/(4D0*XW)
CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
CNN=AEM**2/(16D0*XW**2)
C...Coulomb factor for W+W- pair
IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
IF(COULE.LT.100D0*PMAS(24,2)) THEN
COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
& PMAS(24,2)**2)-COULE))
ELSE
COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
ENDIF
IF(COULE.GT.-100D0*PMAS(24,2)) THEN
COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
& PMAS(24,2)**2)+COULE))
ELSE
COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
& ABS(COULE)))
ENDIF
IF(MSTP(40).EQ.1) THEN
COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
& MAX(1D-10,2D0*COULP*COULP1))
FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
ELSEIF(MSTP(40).EQ.2) THEN
COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
COULCP=DCMPLX(0D0,DBLE(COULP))
COULCD=(COULCK+COULCP)/(COULCK-COULCP)
COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
& (4D0*COULCP)*LOG(COULCD)
COULCS=DCMPLX(0D0,0D0)
NSTP=100
DO 300 ISTP=1,NSTP
COULXX=(ISTP-0.5)/NSTP
COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
& (1D0+COULXX/COULCD))
300 CONTINUE
COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
& (COULCS/NSTP)
FACCOU=ABS(COULCR)**2
ELSEIF(MSTP(40).EQ.3) THEN
COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
& COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
ENDIF
ELSEIF(MSTP(40).EQ.4) THEN
FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
ELSE
FACCOU=1D0
ENDIF
VINT(95)=FACCOU
FACWW=FACWW*FACCOU
C...Loop over allowed flavours
DO 310 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
IF(AI.LT.0D0) THEN
DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
& (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
ELSE
DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
& (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
ENDIF
ELSE
XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
BET=SQRT(1D0-4D0*XMW02/SH)
GAT=1D0/SQRT(1D0-BET**2)
STHE2=1D0-CTH**2
AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
& 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
& 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
& (1D0-2D0*BET*CTH+BET**2))
PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
ATOT=ATOT*CNN/SQMW*SH/BET*2D0
DSIGWW=ATOT
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWW*FCOI*DSIGWW
310 CONTINUE
ELSEIF(ISUB.EQ.30) THEN
C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
& (-SH*UH)
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
HFGG=0D0
HFGZ=0D0
HFZZ=0D0
RADC4=1D0+PYALPS(SQM4)/PARU(1)
DO 320 I=1,MIN(16,MDCY(23,3))
IDC=I+MDCY(23,2)-1
IF(MDME(IDC,1).LT.0) GOTO 320
IMDM=0
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
& IMDM=1
IF(I.LE.8) THEN
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ELSEIF(I.LE.16) THEN
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC4
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.EQ.1) THEN
HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
320 CONTINUE
C...Propagators: as simulated in PYOFSH and as desired
HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM4,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
HFGG=HFGG*HFAEM*VINT(111)/SQM4
HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
DO 340 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
& (VI**2+AI**2)*HFZZ)/HBW4
DO 330 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZQ
330 CONTINUE
340 CONTINUE
ELSEIF(ISUB.EQ.31) THEN
C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
& (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM4,WDTP,WDTE)
GMMWC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
FACWQ=FACWQ*HBW4C/HBW4
DO 360 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
IA=IABS(I)
KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
DO 350 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
350 CONTINUE
360 CONTINUE
ELSEIF(ISUB.EQ.35) THEN
C...f + gamma -> f + (gamma*/Z0)
IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
ELSE
FZQN=SH2+UH2+2D0*SQM4*TH
FZQDTM=-SH*UH
ENDIF
FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
HFGG=0D0
HFGZ=0D0
HFZZ=0D0
RADC4=1D0+PYALPS(SQM4)/PARU(1)
DO 370 I=1,MIN(16,MDCY(23,3))
IDC=I+MDCY(23,2)-1
IF(MDME(IDC,1).LT.0) GOTO 370
IMDM=0
IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
& IMDM=1
IF(I.LE.8) THEN
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ELSEIF(I.LE.16) THEN
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
ENDIF
RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
IF(4D0*RM1.LT.1D0) THEN
FCOF=1D0
IF(I.LE.8) FCOF=3D0*RADC4
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
IF(IMDM.EQ.1) THEN
HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
& AF**2*(1D0-4D0*RM1))*BE34
ENDIF
ENDIF
370 CONTINUE
C...Propagators: as simulated in PYOFSH and as desired
HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
MINT15=MINT(15)
MINT(15)=1
MINT(61)=1
CALL PYWIDT(23,SQM4,WDTP,WDTE)
MINT(15)=MINT15
HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
HFGG=HFGG*HFAEM*VINT(111)/SQM4
HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
DO 390 I=MMINA,MMAXA
IF(I.EQ.0) GOTO 390
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
& (VI**2+AI**2)*HFZZ)/HBW4
FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
DO 380 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZQ*FZQN/FZQD
380 CONTINUE
390 CONTINUE
ELSEIF(ISUB.EQ.36) THEN
C...f + gamma -> f' + W+/-
FWQ=COMFAC*AEM**2/(2D0*XW)*
& (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM4,WDTP,WDTE)
GMMWC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
FWQ=FWQ*HBW4C/HBW4
DO 410 I=MMINA,MMAXA
IF(I.EQ.0) GOTO 410
IA=IABS(I)
EIA=ABS(KCHG(IABS(I),1)/3D0)
FACWQ=FWQ*(EIA-SH/(SH+UH))**2
KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
DO 400 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
400 CONTINUE
410 CONTINUE
ENDIF
ELSEIF(ISUB.LE.100) THEN
IF(ISUB.EQ.69) THEN
C...gamma + gamma -> W+ + W-
SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
& FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWW
420 CONTINUE
ELSEIF(ISUB.EQ.70) THEN
C...gamma + W+/- -> Z0 + W+/-
SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
& (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
& FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
DO 440 KCHW=1,-1,-2
DO 430 ISDE=1,2
IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
NCHN=NCHN+1
ISIG(NCHN,ISDE)=22
ISIG(NCHN,3-ISDE)=24*KCHW
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
430 CONTINUE
440 CONTINUE
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYSGHG
C...Subprocess cross sections for Higgs processes,
C...except Higgs pairs in PYSGSU, but including WW scattering.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGHG(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
&/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
C...Local arrays and complex variables
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
C...Convert H or A process into equivalent h one
IHIGG=1
KFHIGG=25
IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
KFHIGG=KFPR(ISUB,1)
END IF
IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
&ISUB.LE.190)) THEN
IHIGG=2
IF(MOD(ISUB-1,10).GE.5) IHIGG=3
KFHIGG=33+IHIGG
IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
ENDIF
SQMH=PMAS(KFHIGG,1)**2
GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
&72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
IF(MSTP(46).LE.4) THEN
HDTLH=LOG(PMAS(25,1)/PARP(44))
HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
HDTNR=-1D0/18D0+HDTLH/6D0
ELSE
HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
HDTLQ=LOG(PARP(45)/PARP(44))
HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
ENDIF
C...Calculate lowest and next-to-lowest order partial wave amplitudes
HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
A00L=DBLE(HDTV*SH)
A20L=-0.5D0*A00L
A11L=A00L/6D0
HDTLS=LOG(SH/PARP(44)**2)
A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
& CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
& (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
& CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
& (20D0/9D0)*HDTLS),DBLE(PARU(1)))
A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
& CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
C...Unitarize partial wave amplitudes with Pade or K-matrix method
IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
A00U=A00L/(1D0-A004/A00L)
A20U=A20L/(1D0-A204/A20L)
A11U=A11L/(1D0-A114/A11L)
ELSE
A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
ENDIF
ENDIF
C...Differential cross section expressions.
IF(ISUB.LE.60) THEN
IF(ISUB.EQ.3) THEN
C...f + fbar -> h0 (or H0, or A0)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
HP=AEM/(8D0*XW)*SH/SQMW*SH
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
DO 100 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
IA=IABS(I)
RMQ=PYMRUN(IA,SH)**2/SH
HI=HP*RMQ
IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
IKFI=1
IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
IF(IA.GT.10) IKFI=3
HI=HI*PARU(150+10*IHIGG+IKFI)**2
IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
HI=HI/(1D0+RMSS(41))**2
IF(IHIGG.NE.3) THEN
HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
& PARU(151+10*IHIGG))**2
ENDIF
ENDIF
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
100 CONTINUE
ELSEIF(ISUB.EQ.5) THEN
C...Z0 + Z0 -> h0
CALL PYWIDT(25,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
HP=AEM/(8D0*XW)*SH/SQMW*SH
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HI=HP/4D0
FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
DO 120 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
DO 110 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
EJ=KCHG(IABS(J),1)/3D0
AJ=SIGN(1D0,EJ)
VJ=AJ-4D0*EJ*XWV
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
110 CONTINUE
120 CONTINUE
ELSEIF(ISUB.EQ.8) THEN
C...W+ + W- -> h0
CALL PYWIDT(25,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
HP=AEM/(8D0*XW)*SH/SQMW*SH
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HI=HP/2D0
FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
DO 140 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
DO 130 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
IF(EI*EJ.GT.0D0) GOTO 130
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
130 CONTINUE
140 CONTINUE
ELSEIF(ISUB.EQ.24) THEN
C...f + fbar -> Z0 + h0 (or H0, or A0)
C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
CALL PYWIDT(23,SQM3,WDTP,WDTE)
GMMZ3=SQRT(SQM3)*WDTP(0)
HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
GMMH4=SQRT(SQM4)*WDTP(0)
HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
& (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
& PARU(154+10*IHIGG)**2
DO 150 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
150 CONTINUE
ELSEIF(ISUB.EQ.26) THEN
C...f + fbar' -> W+/- + h0 (or H0, or A0)
C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
CALL PYWIDT(24,SQM3,WDTP,WDTE)
GMMW3=SQRT(SQM3)*WDTP(0)
HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
GMMH4=SQRT(SQM4)*WDTP(0)
HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
& ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
FACHW=FACHW*WIDS(KFHIGG,2)
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
& PARU(155+10*IHIGG)**2
DO 170 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
DO 160 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 160
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
FCKM=1D0
IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
FCOI=1D0
IF(IA.LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
160 CONTINUE
170 CONTINUE
ELSEIF(ISUB.EQ.32) THEN
C...f + g -> f + h0 (q + g -> q + h0 only)
FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
C...H propagator: as simulated in PYOFSH and as desired
SQMHC=PMAS(25,1)**2
GMMHC=PMAS(25,1)*PMAS(25,2)
HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
CALL PYWIDT(25,SQM4,WDTP,WDTE)
GMMHCC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
FHCQ=FHCQ*HBW4C/HBW4
DO 190 I=MMINA,MMAXA
IA=IABS(I)
IF(IA.NE.5) GOTO 190
SQML=PYMRUN(IA,SH)**2
SQMQ=PMAS(IA,1)**2
FACHCQ=FHCQ*SQML/SQMW*
& (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
& 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
& (SQM4-SQMQ-SH)/SH)
DO 180 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHCQ*WIDS(25,2)
180 CONTINUE
190 CONTINUE
ENDIF
ELSEIF(ISUB.LE.80) THEN
IF(ISUB.EQ.71) THEN
C...Z0 + Z0 -> Z0 + Z0
IF(SH.LE.4.01D0*SQMZ) GOTO 220
IF(MSTP(46).LE.2) THEN
C...Exact scattering ME:s for on-mass-shell gauge bosons
BE2=1D0-4D0*SQMZ/SH
TH=-0.5D0*SH*BE2*(1D0-CTH)
UH=-0.5D0*SH*BE2*(1D0+CTH)
IF(MAX(TH,UH).GT.-1D0) GOTO 220
SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
& (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
& (ASHIM+ATHIM+AUHIM)**2)
IF(MSTP(46).EQ.2) FACZZ=0D0
ELSE
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
& ABS(A00U+2D0*A20U)**2
ENDIF
FACZZ=FACZZ*WIDS(23,1)
DO 210 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
AVI=AI**2+VI**2
DO 200 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
EJ=KCHG(IABS(J),1)/3D0
AJ=SIGN(1D0,EJ)
VJ=AJ-4D0*EJ*XWV
AVJ=AJ**2+VJ**2
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSEIF(ISUB.EQ.72) THEN
C...Z0 + Z0 -> W+ + W-
IF(SH.LE.4.01D0*SQMZ) GOTO 250
IF(MSTP(46).LE.2) THEN
C...Exact scattering ME:s for on-mass-shell gauge bosons
BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
CTH2=CTH**2
TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
IF(MAX(TH,UH).GT.-1D0) GOTO 250
SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
& (1D0-2D0*SQMZ/SH)
ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
& CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
& ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
& (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
& 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
ATWIM=0D0
AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
& CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
& ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
& (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
& 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
AUWIM=0D0
A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
A4IM=0D0
FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
& (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
& (ASHIM+ATWIM+AUWIM+A4IM)**2)
IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
& (ATWIM+AUWIM+A4IM)**2)
ELSE
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
& ABS(A00U-A20U)**2
ENDIF
FACWW=FACWW*WIDS(24,1)
DO 240 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
AVI=AI**2+VI**2
DO 230 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
EJ=KCHG(IABS(J),1)/3D0
AJ=SIGN(1D0,EJ)
VJ=AJ-4D0*EJ*XWV
AVJ=AJ**2+VJ**2
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWW*AVI*AVJ
230 CONTINUE
240 CONTINUE
250 CONTINUE
ELSEIF(ISUB.EQ.73) THEN
C...Z0 + W+/- -> Z0 + W+/-
IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
IF(MSTP(46).LE.2) THEN
C...Exact scattering ME:s for on-mass-shell gauge bosons
BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
EP1=1D0-(SQMZ-SQMW)/SH
EP2=1D0+(SQMZ-SQMW)/SH
TH=-0.5D0*SH*BE2*(1D0-CTH)
UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
IF(MAX(TH,UH).GT.-1D0) GOTO 280
THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
& 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
& 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
& 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
ASWIM=0D0
AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
& (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
& (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
& BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
& (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
& 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
& (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
& (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
& (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
& (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
& ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
& (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
AUWIM=0D0
A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
& 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
A4IM=0D0
FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
& (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
IF(MSTP(46).LE.0) FACZW=0D0
IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
& (ATHIM+ASWIM+AUWIM+A4IM)**2)
IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
& (ASWIM+AUWIM+A4IM)**2)
ELSE
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
& ABS(A20U+3D0*A11U*DBLE(CTH))**2
ENDIF
FACZW=FACZW*WIDS(23,2)
DO 270 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
AVI=AI**2+VI**2
KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
DO 260 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
EJ=KCHG(IABS(J),1)/3D0
AJ=SIGN(1D0,EJ)
VJ=AI-4D0*EJ*XWV
AVJ=AJ**2+VJ**2
KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
260 CONTINUE
270 CONTINUE
280 CONTINUE
ELSEIF(ISUB.EQ.75) THEN
C...W+ + W- -> gamma + gamma
ELSEIF(ISUB.EQ.76) THEN
C...W+ + W- -> Z0 + Z0
IF(SH.LE.4.01D0*SQMZ) GOTO 310
IF(MSTP(46).LE.2) THEN
C...Exact scattering ME:s for on-mass-shell gauge bosons
BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
CTH2=CTH**2
TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
IF(MAX(TH,UH).GT.-1D0) GOTO 310
SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
& (1D0-2D0*SQMZ/SH)
ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
& CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
& ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
& (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
& 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
ATWIM=0D0
AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
& CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
& ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
& (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
& 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
AUWIM=0D0
A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
A4IM=0D0
FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
& (SH/SQMW)**2*SH2
IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
& (ASHIM+ATWIM+AUWIM+A4IM)**2)
IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
& (ATWIM+AUWIM+A4IM)**2)
ELSE
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
& ABS(A00U-A20U)**2
ENDIF
FACZZ=FACZZ*WIDS(23,1)
DO 300 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
DO 290 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
IF(EI*EJ.GT.0D0) GOTO 290
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
290 CONTINUE
300 CONTINUE
310 CONTINUE
ELSEIF(ISUB.EQ.77) THEN
C...W+/- + W+/- -> W+/- + W+/-
IF(SH.LE.4.01D0*SQMW) GOTO 340
IF(MSTP(46).LE.2) THEN
C...Exact scattering ME:s for on-mass-shell gauge bosons
BE2=1D0-4D0*SQMW/SH
BE4=BE2**2
CTH2=CTH**2
CTH3=CTH**3
TH=-0.5D0*SH*BE2*(1D0-CTH)
UH=-0.5D0*SH*BE2*(1D0+CTH)
IF(MAX(TH,UH).GT.-1D0) GOTO 340
SHANG=(1D0+BE2)**2
ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
THANG=(BE2-CTH)**2
ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
UHANG=(BE2+CTH)**2
AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
ASGRE=XW*SGZANG
ASGIM=0D0
ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
ASZIM=0D0
TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
& BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
ATGRE=0.5D0*XW*SH/TH*TGZANG
ATGIM=0D0
ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
ATZIM=0D0
UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
& BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
AUGRE=0.5D0*XW*SH/UH*UGZANG
AUGIM=0D0
AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
AUZIM=0D0
A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
A4AIM=0D0
A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
A4SIM=0D0
FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
& (SH/SQMW)**2*SH2
IF(MSTP(46).LE.0) THEN
AWWARE=ASHRE
AWWAIM=ASHIM
AWWSRE=0D0
AWWSIM=0D0
ELSEIF(MSTP(46).EQ.1) THEN
AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
ELSE
AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
ENDIF
AWWA2=AWWARE**2+AWWAIM**2
AWWS2=AWWSRE**2+AWWSIM**2
ELSE
C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
& ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
ENDIF
DO 330 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
DO 320 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
IF(EI*EJ.LT.0D0) THEN
C...W+W-
IF(MSTP(45).EQ.1) GOTO 320
IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
ELSE
C...W+W+/W-W-
IF(MSTP(45).EQ.2) GOTO 320
IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
IF(MSTP(46).GE.3) FACWW=FWWS
IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
320 CONTINUE
330 CONTINUE
340 CONTINUE
ENDIF
ELSEIF(ISUB.LE.120) THEN
IF(ISUB.EQ.102) THEN
C...g + g -> h0 (or H0, or A0)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
WDTP13=0D0
DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
& KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
345 CONTINUE
IF(WDTP13.EQ.0D0) CALL PYERRM(26,
& '(PYSGHG:) did not find Higgs -> g g channel')
HI=SHR*WDTP13/32D0
ELSE
HI=SHR*WDTP(13)/32D0
ENDIF
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
350 CONTINUE
ELSEIF(ISUB.EQ.103) THEN
C...gamma + gamma -> h0 (or H0, or A0)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
WDTP14=0D0
DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
& KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
355 CONTINUE
IF(WDTP14.EQ.0D0) CALL PYERRM(26,
& '(PYSGHG:) did not find Higgs -> gamma gamma channel')
HI=SHR*WDTP14*2D0
ELSE
HI=SHR*WDTP(14)*2D0
ENDIF
IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
NCHN=NCHN+1
ISIG(NCHN,1)=22
ISIG(NCHN,2)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
360 CONTINUE
ELSEIF(ISUB.EQ.110) THEN
C...f + fbar -> gamma + h0
THUH=MAX(TH*UH,SH*CKIN(3)**2)
FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
FACHG=FACHG*WIDS(KFHIGG,2)
C...Calculate loop contributions for intermediate gamma* and Z0
CIGTOT=DCMPLX(0D0,0D0)
CIZTOT=DCMPLX(0D0,0D0)
JMAX=3*MSTP(1)+1
DO 370 J=1,JMAX
IF(J.LE.2*MSTP(1)) THEN
FNC=1D0
EJ=KCHG(J,1)/3D0
AJ=SIGN(1D0,EJ+0.1D0)
VJ=AJ-4D0*EJ*XWV
BALP=SQM4/(2D0*PMAS(J,1))**2
BBET=SH/(2D0*PMAS(J,1))**2
ELSEIF(J.LE.3*MSTP(1)) THEN
FNC=3D0
JL=2*(J-2*MSTP(1))-1
EJ=KCHG(10+JL,1)/3D0
AJ=SIGN(1D0,EJ+0.1D0)
VJ=AJ-4D0*EJ*XWV
BALP=SQM4/(2D0*PMAS(10+JL,1))**2
BBET=SH/(2D0*PMAS(10+JL,1))**2
ELSE
BALP=SQM4/(2D0*PMAS(24,1))**2
BBET=SH/(2D0*PMAS(24,1))**2
ENDIF
BABI=1D0/(BALP-BBET)
IF(BALP.LT.1D0) THEN
F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
F1ALP=F0ALP**2
ELSE
F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
& -DBLE(0.5D0*PARU(1)))
F1ALP=-F0ALP**2
ENDIF
F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
IF(BBET.LT.1D0) THEN
F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
F1BET=F0BET**2
ELSE
F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
& -DBLE(0.5D0*PARU(1)))
F1BET=-F0BET**2
ENDIF
F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
IF(J.LE.3*MSTP(1)) THEN
FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
& BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
ELSE
TXW=XW/XW1
CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
& (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
& DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
& (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
& DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
& (F1BET-F1ALP))
ENDIF
370 CONTINUE
CIGTOT=CIGTOT/DBLE(SH)
CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
C...Loop over initial flavours
DO 380 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
& CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
380 CONTINUE
ELSEIF(ISUB.EQ.111) THEN
C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
WDTP13=0D0
DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
& KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
385 CONTINUE
IF(WDTP13.EQ.0D0) CALL PYERRM(26,
& '(PYSGHG:) did not find Higgs -> g g channel')
FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
& (TH**2+UH**2)/(SH*SQM4)
ELSE
FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
& (TH**2+UH**2)/(SH*SQM4)
ENDIF
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
GMMHC=SQRT(SQM4)*WDTP(0)
HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
& ((SQM4-SQMH)**2+GMMHC**2)
FACGH=FACGH*HBW4C/HBW4
ELSE
C...Messy case: do full loop integrals
A5STUR=0D0
A5STUI=0D0
DO 390 I=1,2*MSTP(1)
SQMQ=PMAS(I,1)**2
EPSS=4D0*SQMQ/SH
EPSH=4D0*SQMQ/SQMH
CALL PYWAUX(1,EPSS,W1SR,W1SI)
CALL PYWAUX(1,EPSH,W1HR,W1HI)
CALL PYWAUX(2,EPSS,W2SR,W2SI)
CALL PYWAUX(2,EPSH,W2HR,W2HI)
A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
& (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
& (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
390 CONTINUE
FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
& SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
FACGH=FACGH*WIDS(25,2)
ENDIF
DO 400 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGH
400 CONTINUE
ELSEIF(ISUB.EQ.112) THEN
C...f + g -> f + h0 (q + g -> q + h0 only)
IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
WDTP13=0D0
DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
& KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
405 CONTINUE
IF(WDTP13.EQ.0D0) CALL PYERRM(26,
& '(PYSGHG:) did not find Higgs -> g g channel')
FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
& (SH**2+UH**2)/(-TH*SQM4)
ELSE
FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
& (SH**2+UH**2)/(-TH*SQM4)
ENDIF
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
GMMHC=SQRT(SQM4)*WDTP(0)
HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
& ((SQM4-SQMH)**2+GMMHC**2)
FACQH=FACQH*HBW4C/HBW4
ELSE
C...Messy case: do full loop integrals
A5TSUR=0D0
A5TSUI=0D0
DO 410 I=1,2*MSTP(1)
SQMQ=PMAS(I,1)**2
EPST=4D0*SQMQ/TH
EPSH=4D0*SQMQ/SQMH
CALL PYWAUX(1,EPST,W1TR,W1TI)
CALL PYWAUX(1,EPSH,W1HR,W1HI)
CALL PYWAUX(2,EPST,W2TR,W2TI)
CALL PYWAUX(2,EPSH,W2HR,W2HI)
A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
& (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
& (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
410 CONTINUE
FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
& SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
FACQH=FACQH*WIDS(25,2)
ENDIF
DO 430 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
DO 420 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQH
420 CONTINUE
430 CONTINUE
ELSEIF(ISUB.EQ.113) THEN
C...g + g -> g + h0
IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
WDTP13=0D0
DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
& KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
435 CONTINUE
IF(WDTP13.EQ.0D0) CALL PYERRM(26,
& '(PYSGHG:) did not find Higgs -> g g channel')
FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
& (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
ELSE
FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
& (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
ENDIF
C...Propagators: as simulated in PYOFSH and as desired
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
GMMHC=SQRT(SQM4)*WDTP(0)
HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
& ((SQM4-SQMH)**2+GMMHC**2)
FACGH=FACGH*HBW4C/HBW4
ELSE
C...Messy case: do full loop integrals
A2STUR=0D0
A2STUI=0D0
A2USTR=0D0
A2USTI=0D0
A2TUSR=0D0
A2TUSI=0D0
A4STUR=0D0
A4STUI=0D0
DO 440 I=1,2*MSTP(1)
SQMQ=PMAS(I,1)**2
EPSS=4D0*SQMQ/SH
EPST=4D0*SQMQ/TH
EPSU=4D0*SQMQ/UH
EPSH=4D0*SQMQ/SQMH
IF(EPSH.LT.1D-6) GOTO 440
CALL PYWAUX(1,EPSS,W1SR,W1SI)
CALL PYWAUX(1,EPST,W1TR,W1TI)
CALL PYWAUX(1,EPSU,W1UR,W1UI)
CALL PYWAUX(1,EPSH,W1HR,W1HI)
CALL PYWAUX(2,EPSS,W2SR,W2SI)
CALL PYWAUX(2,EPST,W2TR,W2TI)
CALL PYWAUX(2,EPSU,W2UR,W2UI)
CALL PYWAUX(2,EPSH,W2HR,W2HI)
CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
W3STUR=YHSTUR-Y3STUR-Y3UTSR
W3STUI=YHSTUI-Y3STUI-Y3UTSI
W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
W3TSUR=YHTSUR-Y3TSUR-Y3USTR
W3TSUI=YHTSUI-Y3TSUI-Y3USTI
W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
W3USTR=YHUSTR-Y3USTR-Y3TSUR
W3USTI=YHUSTI-Y3USTI-Y3TSUI
W3UTSR=YHUTSR-Y3UTSR-Y3STUR
W3UTSI=YHUTSI-Y3UTSI-Y3STUI
B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
& (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
& (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
& (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
& (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
& (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
& W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
& (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
& (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
& (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
& (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
& (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
& (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
& (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
& W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
& (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
& (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
& (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
& (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
& (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
& (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
& (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
& W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
& (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
& (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
& (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
& (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
& (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
& (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
& (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
& W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
& (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
& (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
& (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
& (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
& (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
& (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
& (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
& W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
& (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
& (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
& (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
& (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
& (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
& (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
& (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
& W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
& (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
& (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
& (W2SR-W2HR+W3STUR))
B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
& (W2TR-W2HR+W3TUSR))
B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
& (W2UR-W2HR+W3USTR))
B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
A2STUR=A2STUR+B2STUR+B2SUTR
A2STUI=A2STUI+B2STUI+B2SUTI
A2USTR=A2USTR+B2USTR+B2UTSR
A2USTI=A2USTI+B2USTI+B2UTSI
A2TUSR=A2TUSR+B2TUSR+B2TSUR
A2TUSI=A2TUSI+B2TUSI+B2TSUI
A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
440 CONTINUE
FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
& SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
& A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
FACGH=FACGH*WIDS(25,2)
ENDIF
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGH
450 CONTINUE
ENDIF
ELSEIF(ISUB.LE.170) THEN
IF(ISUB.EQ.121) THEN
C...g + g -> Q + Qbar + h0
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
IA=KFPR(ISUBSV,2)
PMF=PYMRUN(IA,SH)
FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
& (0.5D0*PMF/PMAS(24,1))**2
WID2=1D0
IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
FACQQH=FACQQH*WID2
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
IKFI=1
IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
IF(IA.GT.10) IKFI=3
FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
FACQQH=FACQQH/(1D0+RMSS(41))**2
IF(IHIGG.NE.3) THEN
FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
& PARU(151+10*IHIGG))**2
ENDIF
ENDIF
ENDIF
CALL PYQQBH(WTQQBH)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQH*WTQQBH*FACBW
460 CONTINUE
ELSEIF(ISUB.EQ.122) THEN
C...q + qbar -> Q + Qbar + h0
IA=KFPR(ISUBSV,2)
PMF=PYMRUN(IA,SH)
FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
& (0.5D0*PMF/PMAS(24,1))**2
WID2=1D0
IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
FACQQH=FACQQH*WID2
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
IKFI=1
IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
IF(IA.GT.10) IKFI=3
FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
FACQQH=FACQQH/(1D0+RMSS(41))**2
IF(IHIGG.NE.3) THEN
FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
& PARU(151+10*IHIGG))**2
ENDIF
ENDIF
ENDIF
CALL PYQQBH(WTQQBH)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
DO 470 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQH*WTQQBH*FACBW
470 CONTINUE
ELSEIF(ISUB.EQ.123) THEN
C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
C...inner process)
FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
& PARU(154+10*IHIGG)**2
FACPRP=1D0/((VINT(215)-VINT(204)**2)*
& (VINT(216)-VINT(209)**2))**2
FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
DO 490 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
IA=IABS(I)
DO 480 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
JA=IABS(J)
EI=KCHG(IA,1)*ISIGN(1,I)/3D0
AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
VI=AI-4D0*EI*XWV
EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
VJ=AJ-4D0*EJ*XWV
FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
480 CONTINUE
490 CONTINUE
ELSEIF(ISUB.EQ.124) THEN
C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
C...inner process)
FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
& PARU(155+10*IHIGG)**2
FACPRP=1D0/((VINT(215)-VINT(204)**2)*
& (VINT(216)-VINT(209)**2))**2
FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
DO 510 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
DO 500 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
IF(EI*EJ.GT.0D0) GOTO 500
FACLR=VINT(180+I)*VINT(180+J)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACLR*FACWW*FACBW
500 CONTINUE
510 CONTINUE
ELSEIF(ISUB.EQ.143) THEN
C...f + fbar' -> H+/-
SQMHC=PMAS(37,1)**2
CALL PYWIDT(37,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
HP=AEM/(8D0*XW)*SH/SQMW*SH
DO 530 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
IA=IABS(I)
IM=(MOD(IA,10)+1)/2
DO 520 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
JA=IABS(J)
JM=(MOD(JA,10)+1)/2
IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 520
IF(MOD(IA,2).EQ.0) THEN
IU=IA
IL=JA
ELSE
IU=JA
IL=IA
ENDIF
RML=PYMRUN(IL,SH)**2/SH
RMU=PYMRUN(IU,SH)**2/SH
HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
IF(IA.LE.10) HI=HI*FACA/3D0
KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
520 CONTINUE
530 CONTINUE
ELSEIF(ISUB.EQ.161) THEN
C...f + g -> f' + H+/- (b + g -> t + H+/- only)
C...(choice of only b and t to avoid kinematics problems)
FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
C...H propagator: as simulated in PYOFSH and as desired
SQMHC=PMAS(37,1)**2
GMMHC=PMAS(37,1)*PMAS(37,2)
HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
CALL PYWIDT(37,SQM4,WDTP,WDTE)
GMMHCC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
FHCQ=FHCQ*HBW4C/HBW4
Q2RM=SH
IF(MSTP(32).EQ.12) Q2RM=PARP(194)
DO 550 I=MMINA,MMAXA
IA=IABS(I)
IF(IA.NE.5) GOTO 550
SQML=PYMRUN(IA,Q2RM)**2
IUA=IA+MOD(IA,2)
SQMQ=PYMRUN(IUA,Q2RM)**2
FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
& (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
& 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
& (SQMHC-SQMQ-SH)/SH)
KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
DO 540 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
540 CONTINUE
550 CONTINUE
ENDIF
ELSEIF(ISUB.LE.402) THEN
IF(ISUB.EQ.401) THEN
C... g + g -> t + bbar + H-
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
IA=KFPR(ISUBSV,2)
CALL PYSTBH(WTTBH)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
c Since we don't know yet if H+ or H-, assume H+
c when calculating suppression due to closed channels.
SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
IF(ABS(WIDS(37,2)-WIDS(37,3))
& .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
& ABS(WIDS(6,2)-WIDS(6,3))
& .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
WRITE(*,*)'Error: Process 401 cannot handle different'
WRITE(*,*)'decays for H+ and H- or t and tbar.'
WRITE(*,*)'Execution stopped.'
CALL PYSTOP(108)
END IF
560 CONTINUE
ELSEIF(ISUB.EQ.402) THEN
C... q + qbar -> t + bbar + H-
IA=KFPR(ISUBSV,2)
CALL PYSTBH(WTTBH)
CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
& FACBW=0D0
DO 570 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
c Since we don't know yet if H+ or H-, assume H+
c when calculating suppression due to closed channels.
SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
& .GE.1D-6.OR.
& ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
& .GE.1D-6) THEN
WRITE(*,*)'Error: Process 402 cannot handle different'
WRITE(*,*)'decays for H+ and H- or t and tbar.'
WRITE(*,*)'Execution stopped.'
CALL PYSTOP(108)
END IF
570 CONTINUE
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYSGSU
C...Subprocess cross sections for SUSY processes,
C...including Higgs pair production.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGSU(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
&/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
C...Local arrays and complex variables
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
CMRENNA++
C...Z and W width, combinations of weak mixing angle
ZWID=PMAS(23,2)
WWID=PMAS(24,2)
TANW=SQRT(XW/XW1)
CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
C...Convert almost equivalent SUSY processes into each other
C...Extract differences in flavours and couplings
C...Sleptons and sneutrinos
IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
KFID=MOD(KFPR(ISUB,1),KSUSY1)
ISUB=201
ILR=0
ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
KFID=MOD(KFPR(ISUB,1),KSUSY1)
ISUB=201
ILR=1
ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
KFID=MOD(KFPR(ISUB,1),KSUSY1)
ISUB=203
ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
IF(ISUB.EQ.210) THEN
RKF=2.0D0
ELSEIF(ISUB.EQ.211) THEN
RKF=SFMIX(15,1)**2
ELSEIF(ISUB.EQ.212) THEN
RKF=SFMIX(15,2)**2
ENDIF
ISUB=210
ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
IF(ISUB.EQ.213) THEN
KFID=MOD(KFPR(ISUB,1),KSUSY1)
RKF=2.0D0
ELSEIF(ISUB.EQ.214) THEN
KFID=16
RKF=1.0D0
ENDIF
ISUB=213
C...Neutralinos
ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
IF(ISUB.EQ.216) THEN
IZID1=1
IZID2=1
ELSEIF(ISUB.EQ.217) THEN
IZID1=2
IZID2=2
ELSEIF(ISUB.EQ.218) THEN
IZID1=3
IZID2=3
ELSEIF(ISUB.EQ.219) THEN
IZID1=4
IZID2=4
ELSEIF(ISUB.EQ.220) THEN
IZID1=1
IZID2=2
ELSEIF(ISUB.EQ.221) THEN
IZID1=1
IZID2=3
ELSEIF(ISUB.EQ.222) THEN
IZID1=1
IZID2=4
ELSEIF(ISUB.EQ.223) THEN
IZID1=2
IZID2=3
ELSEIF(ISUB.EQ.224) THEN
IZID1=2
IZID2=4
ELSEIF(ISUB.EQ.225) THEN
IZID1=3
IZID2=4
ENDIF
ISUB=216
C...Charginos
ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
IF(ISUB.EQ.226) THEN
IZID1=1
IZID2=1
ELSEIF(ISUB.EQ.227) THEN
IZID1=2
IZID2=2
ELSEIF(ISUB.EQ.228) THEN
IZID1=1
IZID2=2
ENDIF
ISUB=226
C...Neutralino + chargino
ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
IF(ISUB.EQ.229) THEN
IZID1=1
IZID2=1
ELSEIF(ISUB.EQ.230) THEN
IZID1=1
IZID2=2
ELSEIF(ISUB.EQ.231) THEN
IZID1=1
IZID2=3
ELSEIF(ISUB.EQ.232) THEN
IZID1=1
IZID2=4
ELSEIF(ISUB.EQ.233) THEN
IZID1=2
IZID2=1
ELSEIF(ISUB.EQ.234) THEN
IZID1=2
IZID2=2
ELSEIF(ISUB.EQ.235) THEN
IZID1=2
IZID2=3
ELSEIF(ISUB.EQ.236) THEN
IZID1=2
IZID2=4
ENDIF
ISUB=229
C...Gluino + neutralino
ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
IF(ISUB.EQ.237) THEN
IZID=1
ELSEIF(ISUB.EQ.238) THEN
IZID=2
ELSEIF(ISUB.EQ.239) THEN
IZID=3
ELSEIF(ISUB.EQ.240) THEN
IZID=4
ENDIF
ISUB=237
C...Gluino + chargino
ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
IF(ISUB.EQ.241) THEN
IZID=1
ELSEIF(ISUB.EQ.242) THEN
IZID=2
ENDIF
ISUB=241
C...Squark + neutralino
ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
ILR=0
IF(MOD(ISUB,2).NE.0) ILR=1
IF(ISUB.LE.247) THEN
IZID=1
ELSEIF(ISUB.LE.249) THEN
IZID=2
ELSEIF(ISUB.LE.251) THEN
IZID=3
ELSEIF(ISUB.LE.253) THEN
IZID=4
ENDIF
ISUB=246
RKF=5D0
C...Squark + chargino
ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
IF(ISUB.LE.255) THEN
IZID=1
ELSEIF(ISUB.LE.257) THEN
IZID=2
ENDIF
IF(MOD(ISUB,2).EQ.0) THEN
ILR=0
ELSE
ILR=1
ENDIF
ISUB=254
RKF=5D0
C...Squark + gluino
ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
ISUB=258
RKF=4D0
C...Stops
ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
ILR=0
IF(ISUB.EQ.262) ILR=1
ISUB=261
ELSEIF(ISUB.EQ.265) THEN
ISUB=264
C...Squarks
ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
ILR=0
IF(ISUB.LE.273) THEN
IF(ISUB.EQ.273) ILR=1
ISUB=271
RKF=16D0
ELSEIF(ISUB.LE.276) THEN
IF(ISUB.EQ.276) ILR=1
ISUB=274
RKF=16D0
ELSEIF(ISUB.LE.278) THEN
IF(ISUB.EQ.278) ILR=1
ISUB=277
RKF=4D0
ELSE
IF(ISUB.EQ.280) ILR=1
ISUB=279
RKF=4D0
ENDIF
C...Sbottoms
ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
ILR=0
IF(ISUB.LE.283) THEN
IF(ISUB.EQ.283) ILR=1
ISUB=271
RKF=4D0
ELSEIF(ISUB.LE.286) THEN
IF(ISUB.EQ.286) ILR=1
ISUB=274
RKF=4D0
ELSEIF(ISUB.LE.288) THEN
IF(ISUB.EQ.288) ILR=1
ISUB=277
RKF=1D0
ELSEIF(ISUB.LE.290) THEN
IF(ISUB.EQ.290) ILR=1
ISUB=279
RKF=1D0
ELSEIF(ISUB.LE.293) THEN
IF(ISUB.EQ.293) ILR=1
ISUB=271
RKF=1D0
ELSEIF(ISUB.EQ.296) THEN
ILR=1
ISUB=274
RKF=1D0
C...Squark + gluino
ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
ISUB=258
RKF=1D0
ENDIF
C...H+/- + H0
ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
IF(ISUB.EQ.297) THEN
RKF=.5D0*PARU(195)**2
ELSEIF(ISUB.EQ.298) THEN
RKF=.5D0*(1D0-PARU(195)**2)
ENDIF
ISUB=210
C...A0 + H0
ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
IF(ISUB.EQ.299) THEN
RKF=PARU(186)**2
KFID=25
ELSEIF(ISUB.EQ.300) THEN
RKF=PARU(187)**2
KFID=35
ENDIF
ISUB=213
C...H+ + H-
ELSEIF(ISUB.EQ.301) THEN
KFID=37
RKF=1D0
ISUB=201
ENDIF
C...Supersymmetric processes - all of type 2 -> 2 :
C...correct final-state Breit-Wigners from fixed to running width.
IF(MSTP(42).GT.0) THEN
DO 100 I=1,2
KFLW=KFPR(ISUBSV,I)
KCW=PYCOMP(KFLW)
IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
IF(I.EQ.1) SQMI=SQM3
IF(I.EQ.2) SQMI=SQM4
SQMS=PMAS(KCW,1)**2
GMMS=PMAS(KCW,1)*PMAS(KCW,2)
HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
GMMI=SQRT(SQMI)*WDTP(0)
HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
COMFAC=COMFAC*(HBWI/HBWS)
100 CONTINUE
ENDIF
C...Differential cross section expressions.
IF(ISUB.LE.210) THEN
IF(ISUB.EQ.201) THEN
C...f + fbar -> e_L + e_Lbar
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
DO 130 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
EI=KCHG(IA,1)/3D0
TT3I=SIGN(1D0,EI+1D-6)/2D0
EJ=-1D0
TT3J=-1D0/2D0
FCOL=1D0
C...Color factor for e+ e-
IF(IA.GE.11) FCOL=3D0
IF(ISUBSV.EQ.301) THEN
A1=1D0
A2=0D0
ELSEIF(ILR.EQ.1) THEN
A1=SFMIX(KFID,3)**2
A2=SFMIX(KFID,4)**2
ELSEIF(ILR.EQ.0) THEN
A1=SFMIX(KFID,1)**2
A2=SFMIX(KFID,2)**2
ENDIF
XLQ=(TT3J-EJ*XW)*A1
XRQ=(-EJ*XW)*A2
XLF=(TT3I-EI*XW)
XRF=(-EI*XW)
TAA=(EI*EJ)**2*(POLL+POLR)
TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
TNN=0.0D0
TAN=0.0D0
TZN=0.0D0
IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
FAC2=SQRT(2D0)
TNN1=0D0
TNN2=0D0
TNN3=0D0
DO 120 II=1,4
DK=1D0/(TH-SMZ(II)**2)
FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
& ZMIX(II,1))
FREK=FAC2*TANW*EI*ZMIX(II,1)
TNN1=TNN1+FLEK**2*DK
TNN2=TNN2+FREK**2*DK
DO 110 JJ=1,4
DL=1D0/(TH-SMZ(JJ)**2)
FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
& ZMIX(JJ,1))
FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
110 CONTINUE
120 CONTINUE
TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
& A2**2*TNN2**2*POLR)
TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
& (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
& (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
& (1D0-SQMZ/SH)/SH
TZN=TZN/XW**2/XW1
TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
& A2*TNN2*POLR)/XW
ENDIF
FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1+FACQQ2
130 CONTINUE
ELSEIF(ISUB.EQ.203) THEN
C...f + fbar -> e_L + e_Rbar
DO 160 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
EI=KCHG(IABS(I),1)/3D0
TT3I=SIGN(1D0,EI)/2D0
EJ=-1
TT3J=-1D0/2D0
FCOL=1D0
C...Color factor for e+ e-
IF(IA.GE.11) FCOL=3D0
A1=SFMIX(KFID,1)**2
A2=SFMIX(KFID,2)**2
XLQ=(TT3J-EJ*XW)
XRQ=(-EJ*XW)
XLF=(TT3I-EI*XW)
XRF=(-EI*XW)
TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
& /XW**2/XW1**2*A1*A2
TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
TNN=0.0D0
TZN=0.0D0
TNNA=0D0
TNNB=0D0
IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
FAC2=SQRT(2D0)
TNN1=0D0
TNN2=0D0
TNN3=0D0
DO 150 II=1,4
DK=1D0/(TH-SMZ(II)**2)
FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
& ZMIX(II,1))
FREK=FAC2*TANW*EI*ZMIX(II,1)
TNN1=TNN1+FLEK**2*DK
TNN2=TNN2+FREK**2*DK
DO 140 JJ=1,4
DL=1D0/(TH-SMZ(JJ)**2)
FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
& ZMIX(JJ,1))
FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
140 CONTINUE
150 CONTINUE
TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
TZN=(UH*TH-SQM3*SQM4)*A1*A2
TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
& (1D0-SQMZ/SH)/SH
ENDIF
FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
C%%%%%%%%%%%
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
160 CONTINUE
ELSEIF(ISUB.EQ.210) THEN
C...q + qbar' -> W*- > ~l_L + ~nu_L
FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
DO 180 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
DO 170 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
FCKM=3D0
IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
KCHW=2
IF(KCHSUM.LT.0) KCHW=3
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
ELSE
FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
ENDIF
SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
170 CONTINUE
180 CONTINUE
ENDIF
ELSEIF(ISUB.LE.220) THEN
IF(ISUB.EQ.213) THEN
C...f + fbar -> ~nu_L + ~nu_Lbar
IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
ELSE
FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
ENDIF
COMFAC=COMFAC*FACR
PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
XLL=0.5D0
XLR=0.0D0
DO 190 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
EI=KCHG(IA,1)/3D0
FCOL=1D0
C...Color factor for e+ e-
IF(IA.GE.11) FCOL=3D0
XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
XRQ=-EI*XW
TZC=0.0D0
TCC=0.0D0
IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
& (TH-SMW(2)**2)
TCC=TZC**2
TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
ENDIF
FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
FACQQ2=TZC+TCC/4D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
& *AEM**2*FCOL/3D0/XW**2
190 CONTINUE
ELSEIF(ISUB.EQ.216) THEN
C...q + qbar -> ~chi0_1 + ~chi0_1
IF(IZID1.EQ.IZID2) THEN
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
ELSE
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
ENDIF
FACXX=COMFAC*AEM**2/3D0/XW**2
IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
ZM12=SQM3
ZM22=SQM4
WU2 = (UH-ZM12)*(UH-ZM22)
WT2 = (TH-ZM12)*(TH-ZM22)
WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
DO 200 I=1,4
ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
IF(IZID2.NE.IZID1) THEN
ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
ENDIF
200 CONTINUE
OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
& ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
ORPP=DCONJG(OLPP)
DO 210 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
EI=KCHG(IABS(I),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
& DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
& /DCMPLX(TH-XML2)
QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
& -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
FCOL=1D0
IF(IABS(I).GE.11) FCOL=3D0
FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
& (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
& 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
& QRL*DCONJG(QRR)*POLR)*WS2
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACXX*FACGG1*FCOL
210 CONTINUE
ENDIF
ELSEIF(ISUB.LE.230) THEN
IF(ISUB.EQ.226) THEN
C...f + fbar -> ~chi+_1 + ~chi-_1
FACXX=COMFAC*AEM**2/3D0
ZM12=SQM3
ZM22=SQM4
WU2 = (UH-ZM12)*(UH-ZM22)
WT2 = (TH-ZM12)*(TH-ZM22)
WS2 = SMW(IZID1)*SMW(IZID2)*SH
PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
DIFF=0D0
IF(IZID1.EQ.IZID2) DIFF=1D0
DO 220 I=1,2
VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
IF(IZID2.NE.IZID1) THEN
VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
ENDIF
220 CONTINUE
OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
& VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
& UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
DO 230 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
EI=KCHG(IABS(I),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
IF(MOD(I,2).EQ.0) THEN
XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
& PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
& DCMPLX(T3I/XW/(TH-XML2))
ELSE
XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
& PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
& DCMPLX(T3I/XW/(TH-XML2))
ENDIF
FCOL=1D0
IF(IABS(I).GE.11) FCOL=3D0
FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
& (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
& 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
& QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
IF(IZID1.EQ.IZID2) THEN
SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
ELSE
SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
ENDIF
230 CONTINUE
ELSEIF(ISUB.EQ.229) THEN
C...q + qbar' -> ~chi0_1 + ~chi+-_1
FACXX=COMFAC*AEM**2/6D0/XW**2
ZM12=SQM3
ZM22=SQM4
WU2 = (UH-ZM12)*(UH-ZM22)
WT2 = (TH-ZM12)*(TH-ZM22)
WS2 = SMW(IZID1)*SMZ(IZID2)*SH
RT2I = 1D0/SQRT(2D0)
PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
& DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
DO 240 I=1,2
VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
240 CONTINUE
DO 250 I=1,4
ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
250 CONTINUE
OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
& DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
& ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
DO 270 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
DO 260 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
EJ=KCHG(JA,1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
FCKM=3D0
IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
KCHW=2
IF(KCHSUM.LT.0) KCHW=3
IF(MOD(IA,2).EQ.0) THEN
ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
& TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
QLR=OR-DCONJG(UMIXC(IZID1,1))*(
& ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
& /DCMPLX(TH-ZMJ2)
ELSE
ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
& TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
QLR=OR-DCONJG(UMIXC(IZID1,1))*(
& ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
& /DCMPLX(TH-ZMI2)
ENDIF
ZINTR=DBLE(QLR*DCONJG(QLL))
FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
& 2D0*ZINTR*WS2)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
260 CONTINUE
270 CONTINUE
ENDIF
ELSEIF(ISUB.LE.240) THEN
IF(ISUB.EQ.237) THEN
C...q + qbar -> gluino + ~chi0_1
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
ASYUK=RMSS(42)*AS
FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
GM2=SQM3
ZM2=SQM4
DO 280 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
EI=KCHG(IABS(I),1)/3D0
IA=IABS(I)
XLQC = -TANW*EI*ZMIX(IZID,1)
XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
& (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
XLQ2=XLQC**2
XRQ2=XRQC**2
XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
280 CONTINUE
ENDIF
ELSEIF(ISUB.LE.250) THEN
IF(ISUB.EQ.241) THEN
C...q + qbar' -> ~chi+-_1 + gluino
FACWG=COMFAC*AS*AEM/XW*2D0/9D0
GM2=SQM3
ZM2=SQM4
FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
FAC0=UMIX(IZID,1)**2
FAC1=VMIX(IZID,1)**2
DO 300 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
DO 290 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
FCKM=1D0
IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
KCHW=2
IF(KCHSUM.LT.0) KCHW=3
XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
& SH/(TH-XMU2)/(UH-XMD2))/2D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
& FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
290 CONTINUE
300 CONTINUE
ELSEIF(ISUB.EQ.243) THEN
C...q + qbar -> gluino + gluino
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
XMT=SQM3-TH
XMU=SQM3-UH
DO 310 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
NCHN=NCHN+1
XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
& 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
& XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
& (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
& 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
& XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
& (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
C...1/2 for identical particles
SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
310 CONTINUE
ELSEIF(ISUB.EQ.244) THEN
C...g + g -> gluino + gluino
COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
XMT=SQM3-TH
XMU=SQM3-UH
FACQQ1=COMFAC*AS**2*9D0/4D0*(
& (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
& (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
FACQQ2=COMFAC*AS**2*9D0/4D0*(
& (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
& (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
& SQM3*(SH-4D0*SQM3)/XMT/XMU)
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1/2D0
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2/2D0
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=FACQQ3/2D0
320 CONTINUE
ELSEIF(ISUB.EQ.246) THEN
C...g + q_j -> ~chi0_1 + ~q_j
FAC0=COMFAC*AS*AEM/6D0/XW
ZM2=SQM4
QM2=SQM3
FACZQ0=FAC0*( (ZM2-TH)/SH +
& (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
& (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
EI=KCHG(IABS(I),1)/3D0
IA=IABS(I)
XRQZ = -TANW*EI*ZMIX(IZID,1)
XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
& (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
IF(ILR.EQ.0) THEN
BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
ELSE
BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
ENDIF
FACZQ=FACZQ0*BS
KCHQ=2
IF(I.LT.0) KCHQ=3
DO 330 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
330 CONTINUE
340 CONTINUE
ENDIF
ELSEIF(ISUB.LE.260) THEN
IF(ISUB.EQ.254) THEN
C...g + q_j -> ~chi1_1 + ~q_i
FAC0=COMFAC*AS*AEM/12D0/XW
ZM2=SQM4
QM2=SQM3
AU=UMIX(IZID,1)**2
AD=VMIX(IZID,1)**2
FACZQ0=FAC0*( (ZM2-TH)/SH +
& (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
& (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
IF(MOD(KFNSQ1,2).EQ.0) THEN
KFNSQ=KFNSQ1-1
KCHW=2
ELSE
KFNSQ=KFNSQ1+1
KCHW=3
ENDIF
DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
IA=IABS(I)
IF(MOD(IA,2).EQ.0) THEN
FACZQ=FACZQ0*AU
ELSE
FACZQ=FACZQ0*AD
ENDIF
FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
KCHQ=2
IF(I.LT.0) KCHQ=3
KCHWQ=KCHW
IF(I.LT.0) KCHWQ=5-KCHW
DO 350 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
350 CONTINUE
360 CONTINUE
ELSEIF(ISUB.EQ.258) THEN
C...g + q_j -> gluino + ~q_i
XG2=SQM4
XQ2=SQM3
XMT=XG2-TH
XMU=XG2-UH
XST=XQ2-TH
XSU=XQ2-UH
FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
& ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
& 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
& (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
& (SH*(UH+XG2)
& +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
& 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
& (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
ASYUK=RMSS(42)*AS
FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
KCHQ=2
IF(I.LT.0) KCHQ=3
FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
DO 370 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQG1*FACSEL
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQG2*FACSEL
370 CONTINUE
380 CONTINUE
ENDIF
ELSEIF(ISUB.LE.270) THEN
IF(ISUB.EQ.261) THEN
C...q_i + q_ibar -> ~t_1 + ~t_1bar
FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
FAC0=AS**2*4D0/9D0
DO 390 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
IF(IA.GE.11.AND.IA.LE.18) THEN
EI=KCHG(IA,1)/3D0
EJ=KCHG(KFNSQ,1)/3D0
T3I=SIGN(1D0,EI)/2D0
T3J=SIGN(1D0,EJ)/2D0
XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
XLF=2D0*(T3I-EI*XW)
XRF=2D0*(-EI*XW)
TAA=0.5D0*(EI*EJ)**2
TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1*FAC0
390 CONTINUE
ELSEIF(ISUB.EQ.263) THEN
C...f + fbar -> ~t1 + ~t2bar
DO 400 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
EI=KCHG(IABS(I),1)/3D0
TT3I=SIGN(1D0,EI)/2D0
EJ=2D0/3D0
TT3J=1D0/2D0
FCOL=1D0
C...Color factor for e+ e-
IF(IA.GE.11) FCOL=3D0
XLQ=2D0*(TT3J-EJ*XW)
XRQ=2D0*(-EJ*XW)
XLF=2D0*(TT3I-EI*XW)
XRF=2D0*(-EI*XW)
TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
C...Factor of 2 for t1 t2bar + t2 t1bar
C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0
FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
400 CONTINUE
ELSEIF(ISUB.EQ.264) THEN
C...g + g -> ~t_1 + ~t_1bar
XSU=SQM3-UH
XST=SQM3-TH
FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2
410 CONTINUE
ENDIF
ELSEIF(ISUB.LE.280) THEN
IF(ISUB.EQ.271) THEN
C...q + q' -> ~q + ~q' (~g exchange)
XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
XMT=XMG2-TH
XMU=XMG2-UH
XSU1=SQM3-UH
XSU2=SQM4-UH
XST1=SQM3-TH
XST2=SQM4-TH
ASYUK=RMSS(42)*AS
IF(ILR.EQ.1) THEN
FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
FACQQB=0.0D0
ELSE
FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
& XMT/XMU )
ENDIF
KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
KCHQ=2
IF(I.LT.0) KCHQ=3
DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
IF(I*J.LT.0) GOTO 420
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
IF(I.EQ.J) THEN
IF(ILR.EQ.0) THEN
SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
ELSE
SIGH(NCHN)=0.5D0*FACQQ1*RKF*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(ILR.EQ.0) THEN
SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
ELSE
SIGH(NCHN)=0.5D0*FACQQ2*RKF*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
ENDIF
ENDIF
420 CONTINUE
430 CONTINUE
ELSEIF(ISUB.EQ.274) THEN
C...q + qbar' -> ~q + ~qbar'
XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
XMT=XMG2-TH
XMU=XMG2-UH
IF(ILR.EQ.0) THEN
C...Mrenna...Normalization.and.1/XMT
FACQQ1=COMFAC*AS**2*2D0/9D0*(
& (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
FACQQB=COMFAC*AS**2*4D0/9D0*(
& (UH*TH-SQM3*SQM4)/SH2 )
FACQQI=-COMFAC*AS**2*4D0/27D0*(
& (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
FACQQB=FACQQB+FACQQ1+FACQQI
ELSE
FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
FACQQB=FACQQ1
ENDIF
KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
KCHQ=2
IF(I.LT.0) KCHQ=3
DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
IF(I*J.GT.0) GOTO 440
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
& WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
& WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
440 CONTINUE
450 CONTINUE
ELSEIF(ISUB.EQ.277) THEN
C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
C...if i .eq. j covered in 274
FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
FAC0=0D0
DO 460 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
IF(IA.EQ.KFNSQ) GOTO 460
IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
EI=KCHG(IA,1)/3D0
EJ=KCHG(KFNSQ,1)/3D0
T3J=SIGN(0.5D0,EJ)
T3I=SIGN(1D0,EI)/2D0
IF(ILR.EQ.0) THEN
XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
ELSE
XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
ENDIF
XLF=2D0*(T3I-EI*XW)
XRF=2D0*(-EI*XW)
IF(ILR.EQ.0) THEN
XRQ=0D0
ELSE
XLQ=0D0
ENDIF
TAA=0.5D0*(EI*EJ)**2
TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
ELSEIF(IA.LE.6) THEN
FAC0=AS**2*8D0/9D0/2D0
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
460 CONTINUE
ELSEIF(ISUB.EQ.279) THEN
C...g + g -> ~q_j + ~q_jbar
XSU=SQM3-UH
XST=SQM3-TH
C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
470 CONTINUE
ENDIF
ENDIF
CMRENNA--
RETURN
END
C*********************************************************************
C...PYSGTC
C...Subprocess cross sections for Technicolor processes.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGTC(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
&/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays and complex variables
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
COMPLEX*16 SSMX,DAAST,DZAST,DWAST
COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
COMPLEX*16 DVVS,DVVT,DVVU
INTEGER INDX(6)
C...Combinations of weak mixing angle.
TANW=SQRT(XW/XW1)
CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
C...Convert almost equivalent technicolor processes into
C...a few basic processes, and set distinguishing parameters.
IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
SQTV=RTCM(12)**2
SQTA=RTCM(13)**2
SN2W=2D0*SQRT(XW*XW1)
CS2W=1D0-2D0*XW
CT2W=CS2W/SN2W
CSXI=COS(ASIN(RTCM(3)))
CSXIP=COS(ASIN(RTCM(4)))
QUPD=2D0*RTCM(2)-1D0
Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
CAB2=0D0
VOGP=0D0
VRGP=0D0
AOGP=0D0
ARGP=0D0
VXGP=0D0
AXGP=0D0
VAGP=0D0
VZGP=0D0
VWGP=0D0
C... rho_tc0, etc. -> W_L W_L, W_L W_T
IF(ISUB.EQ.361) THEN
KFA=24
KFB=24
CAB2=RTCM(3)**4
AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
AXGP = SQRT(2D0)*AXGP
ARGP = SQRT(2D0)*ARGP
VOGP = SQRT(2D0)*VOGP
C... rho_tc0 -> W_L pi_tc-
ELSEIF(ISUB.EQ.362) THEN
KFA=24
KFB=KTECHN+211
ISUB=361
CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... pi_tc pi_tc
ELSEIF(ISUB.EQ.363) THEN
KFA=KTECHN+211
KFB=KTECHN+211
ISUB=361
CAB2=(1D0-RTCM(3)**2)**2
C... rho_tc0/omega_tc -> gamma pi_tc
ELSEIF(ISUB.EQ.364) THEN
KFA=22
KFB=KTECHN+111
ISUB=361
VOGP=CSXI/RTCM(12)
VRGP=VOGP*QUPD
VAGP=2D0*QUPD*CSXI
VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
C... gamma pi_tc'
ELSEIF(ISUB.EQ.365) THEN
KFA=22
KFB=KTECHN+221
ISUB=361
VRGP=CSXIP/RTCM(12)
VOGP=VRGP*QUPD
VAGP=2D0*Q2UD*CSXIP
VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
C... Z pi_tc
ELSEIF(ISUB.EQ.366) THEN
KFA=23
KFB=KTECHN+111
ISUB=361
VOGP=CSXI*CT2W/RTCM(12)
VRGP=-QUPD*CSXI*TANW/RTCM(12)
VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
VZGP=-QUPD*CSXI*CS2W/XW1
C... Z pi_tc'
ELSEIF(ISUB.EQ.367) THEN
KFA=23
KFB=KTECHN+221
ISUB=361
C...RTCM(48) is the M_V for the techni-a
VXGP=-CSXIP/SN2W/RTCM(48)
VRGP=CSXIP*CT2W/RTCM(12)
VOGP=-QUPD*CSXIP*TANW/RTCM(12)
VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
C... W_T pi_tc
ELSEIF(ISUB.EQ.368) THEN
KFA=24
KFB=KTECHN+211
ISUB=361
C...RTCM(49) is the M_A for the techni-a
AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
VAGP=QUPD*CSXI/(2D0*SQRT(XW))
VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
ELSEIF(ISUB.EQ.370) THEN
KFA=24
KFB=23
CAB2=RTCM(3)**4
ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
C... W_L pi_tc0
ELSEIF(ISUB.EQ.371) THEN
KFA=24
KFB=KTECHN+111
ISUB=370
CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... Z_L pi_tc+
ELSEIF(ISUB.EQ.372) THEN
KFA=KTECHN+211
KFB=23
ISUB=370
CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... pi_tc+ pi_tc0
ELSEIF(ISUB.EQ.373) THEN
KFA=KTECHN+211
KFB=KTECHN+111
ISUB=370
CAB2=(1D0-RTCM(3)**2)**2
C... gamma pi_tc+
ELSEIF(ISUB.EQ.374) THEN
KFA=KTECHN+211
KFB=22
ISUB=370
VRGP=QUPD*CSXI/RTCM(12)
VWGP=QUPD*CSXI/(2D0*SQRT(XW))
AXGP=-CSXI/RTCM(49)
C... Z_T pi_tc+
ELSEIF(ISUB.EQ.375) THEN
KFA=KTECHN+211
KFB=23
ISUB=370
VRGP=-QUPD*CSXI*TANW/RTCM(12)
ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
AXGP=-CSXI*CT2W/RTCM(49)
C... W_T pi_tc0
ELSEIF(ISUB.EQ.376) THEN
KFA=24
KFB=KTECHN+111
ISUB=370
VRGP=0D0
ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
C... W_T pi_tc0'
ELSEIF(ISUB.EQ.377) THEN
KFA=24
KFB=KTECHN+221
ISUB=370
VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
VWGP=CSXIP/(2D0*XW)
VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
C... gamma W+
ELSEIF(ISUB.EQ.378) THEN
KFA=24
KFB=22
ISUB=370
VRGP=QUPD*RTCM(3)/RTCM(12)
AXGP=-RTCM(3)/RTCM(49)
C... gamma Z
ELSEIF(ISUB.EQ.379) THEN
KFA=23
KFB=22
ISUB=361
VOGP=RTCM(3)/RTCM(12)
VRGP=QUPD*RTCM(3)/RTCM(12)
ELSEIF(ISUB.EQ.380) THEN
KFA=23
KFB=23
ISUB=361
VOGP=RTCM(3)*CT2W/RTCM(12)
VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
ENDIF
ENDIF
C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
IF(ITCM(5).LE.4) THEN
SQDQQS=1D0/SH2
SQDQQT=1D0/TH2
SQDQQU=1D0/UH2
SQDGGS=SQDQQS
SQDGGT=SQDQQT
SQDGGU=SQDQQU
REDGGS=1D0/SH
REDGGT=1D0/TH
REDGGU=1D0/UH
REDGTU=1D0/UH/TH
REDGSU=1D0/SH/UH
REDGST=1D0/SH/TH
REDQST=1D0/SH/TH
REDQTU=1D0/UH/TH
SQDLGS=0D0
SQDLGT=0D0
SQDQTS=SQDQQS
ELSEIF(ITCM(5).EQ.5) THEN
TANT3=RTCM(21)
IF(ITCM(2).EQ.0) THEN
IMDL=1
ELSE
IMDL=2
ENDIF
ALPRHT=2.16D0*(3D0/ITCM(1))
SIN2T=2D0*TANT3/(TANT3**2+1D0)
SINT3=TANT3/SQRT(TANT3**2+1D0)
XIG=SQRT(PYALPS(SH)/ALPRHT)
X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
& RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
& RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
& SINT3**2)*2D0/SIN2T
X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
& SINT3**2)*2D0/SIN2T
SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
SM1112=X12*RTCM(28)**2*SIN2T
SM1121=-X21*RTCM(28)**2*SIN2T
SM2212=-SM1112
SM2221=-SM1121
SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
& (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
C.........SH LOOP
ZTC(1,1)=DCMPLX(SH,0D0)
CALL PYWIDT(3100021,SH,WDTP,WDTE)
IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
CALL PYWIDT(3100113,SH,WDTP,WDTE)
ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
CALL PYWIDT(3400113,SH,WDTP,WDTE)
ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
CALL PYWIDT(3200113,SH,WDTP,WDTE)
ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
CALL PYWIDT(3300113,SH,WDTP,WDTE)
ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
ZTC(1,2)=(0D0,0D0)
ZTC(1,3)=DCMPLX(SH*XIG,0D0)
ZTC(1,4)=ZTC(1,3)
ZTC(1,5)=ZTC(1,2)
ZTC(1,6)=ZTC(1,2)
ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
ZTC(3,4)=-SM1122
ZTC(3,5)=-SM1112
ZTC(3,6)=-SM1121
ZTC(4,5)=-SM2212
ZTC(4,6)=-SM2221
ZTC(5,6)=-SM1221
DO 110 I=1,5
DO 100 J=I+1,6
ZTC(J,I)=ZTC(I,J)
100 CONTINUE
110 CONTINUE
CALL PYLDCM(ZTC,6,6,INDX,D)
DO 130 I=1,6
DO 120 J=1,6
YTC(I,J)=(0D0,0D0)
IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
120 CONTINUE
130 CONTINUE
DO 140 I=1,6
CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
140 CONTINUE
DGGS=YTC(1,1)
DVVS=YTC(2,2)
DGVS=YTC(1,2)
XIG=SQRT(PYALPS(-TH)/ALPRHT)
C.........TH LOOP
ZTC(1,1)=DCMPLX(TH)
ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
ZTC(1,2)=(0D0,0D0)
ZTC(1,3)=DCMPLX(TH*XIG,0D0)
ZTC(1,4)=ZTC(1,3)
ZTC(1,5)=ZTC(1,2)
ZTC(1,6)=ZTC(1,2)
ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
ZTC(3,4)=-SM1122
ZTC(3,5)=-SM1112
ZTC(3,6)=-SM1121
ZTC(4,5)=-SM2212
ZTC(4,6)=-SM2221
ZTC(5,6)=-SM1221
DO 160 I=1,5
DO 150 J=I+1,6
ZTC(J,I)=ZTC(I,J)
150 CONTINUE
160 CONTINUE
CALL PYLDCM(ZTC,6,6,INDX,D)
DO 180 I=1,6
DO 170 J=1,6
YTC(I,J)=(0D0,0D0)
IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
170 CONTINUE
180 CONTINUE
DO 190 I=1,6
CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
190 CONTINUE
DGGT=YTC(1,1)
DVVT=YTC(2,2)
DGVT=YTC(1,2)
XIG=SQRT(PYALPS(-UH)/ALPRHT)
C.........UH LOOP
ZTC(1,1)=DCMPLX(UH,0D0)
ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
ZTC(1,2)=(0D0,0D0)
ZTC(1,3)=DCMPLX(UH*XIG,0D0)
ZTC(1,4)=ZTC(1,3)
ZTC(1,5)=ZTC(1,2)
ZTC(1,6)=ZTC(1,2)
ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
ZTC(3,4)=-SM1122
ZTC(3,5)=-SM1112
ZTC(3,6)=-SM1121
ZTC(4,5)=-SM2212
ZTC(4,6)=-SM2221
ZTC(5,6)=-SM1221
DO 210 I=1,5
DO 200 J=I+1,6
ZTC(J,I)=ZTC(I,J)
200 CONTINUE
210 CONTINUE
CALL PYLDCM(ZTC,6,6,INDX,D)
DO 230 I=1,6
DO 220 J=1,6
YTC(I,J)=(0D0,0D0)
IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
220 CONTINUE
230 CONTINUE
DO 240 I=1,6
CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
240 CONTINUE
DGGU=YTC(1,1)
DVVU=YTC(2,2)
DGVU=YTC(1,2)
IF(IMDL.EQ.1) THEN
DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
DQGS=DGGS-DGVS*DCMPLX(TANT3)
DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
ELSE
DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
ENDIF
SQDQTS=ABS(DQTS)**2
SQDQQS=ABS(DQQS)**2
SQDQQT=ABS(DQQT)**2
SQDQQU=ABS(DQQU)**2
SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
REDLGS=DBLE(DQGS)
SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
REDHGS=DBLE(DTGS)
SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
SQDGGS=ABS(DGGS)**2
SQDGGT=ABS(DGGT)**2
SQDGGU=ABS(DGGU)**2
REDGGS=DBLE(DGGS)
REDGGT=DBLE(DGGT)
REDGGU=DBLE(DGGU)
REDGTU=DBLE(DGGU*DCONJG(DGGT))
REDGSU=DBLE(DGGU*DCONJG(DGGS))
REDGST=DBLE(DGGS*DCONJG(DGGT))
REDQST=DBLE(DQQS*DCONJG(DQQT))
REDQTU=DBLE(DQQT*DCONJG(DQQU))
ENDIF
ENDIF
C...Differential cross section expressions.
IF(ISUB.LE.190) THEN
IF(ISUB.EQ.149) THEN
C...g + g -> eta_tc
KCTC=PYCOMP(KTECHN+331)
CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
HP=SH
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
HI=HP*WDTP(3)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
250 CONTINUE
ELSEIF(ISUB.EQ.165) THEN
C...q + qbar -> l+ + l- (including contact term for compositeness)
ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
KFF=IABS(KFPR(ISUB,1))
EF=KCHG(KFF,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
VALF=VF+AF
VARF=VF-AF
FCOF=1D0
IF(KFF.LE.10) FCOF=3D0
WID2=1D0
IF(KFF.EQ.6) WID2=WIDS(6,1)
IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
DO 260 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=VI+AI
VARI=VI-AI
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
& (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
& (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
ELSE
FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
& (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
ENDIF
FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
& (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
& MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
260 CONTINUE
ELSEIF(ISUB.EQ.166) THEN
C...q + q'bar -> l + nu_l (including contact term for compositeness)
WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
KFF=IABS(KFPR(ISUB,1))
FCOF=1D0
IF(KFF.LE.10) FCOF=3D0
DO 280 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
IA=IABS(I)
DO 270 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 270
FCOI=1D0
IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
WID2=1D0
IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
& MOD(J,2).EQ.0)) THEN
IF(KFF.EQ.5) WID2=WIDS(6,2)
IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
ELSE
IF(KFF.EQ.5) WID2=WIDS(6,3)
IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
& SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
270 CONTINUE
280 CONTINUE
ENDIF
ELSEIF(ISUB.LE.200) THEN
IF(ISUB.EQ.191) THEN
C...q + qbar -> rho_tc0.
KCTC=PYCOMP(KTECHN+113)
SQMRHT=PMAS(KCTC,1)**2
CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
ALPRHT=2.16D0*(3D0/ITCM(1))
HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
DO 290 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
IA=IABS(I)
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
& (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
IF(IA.LE.10) HI=HI*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
290 CONTINUE
ELSEIF(ISUB.EQ.192) THEN
C...q + qbar' -> rho_tc+/-.
KCTC=PYCOMP(KTECHN+213)
SQMRHT=PMAS(KCTC,1)**2
CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
ALPRHT=2.16D0*(3D0/ITCM(1))
HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
& (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
DO 310 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
IA=IABS(I)
DO 300 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 300
KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
HI=HP
IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
300 CONTINUE
310 CONTINUE
ELSEIF(ISUB.EQ.193) THEN
C...q + qbar -> omega_tc0.
KCTC=PYCOMP(KTECHN+223)
SQMOMT=PMAS(KCTC,1)**2
CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
ALPRHT=2.16D0*(3D0/ITCM(1))
HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
& (2D0*RTCM(2)-1D0)**2
BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
DO 320 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
IA=IABS(I)
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
& (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
IF(IA.LE.10) HI=HI*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
320 CONTINUE
ELSEIF(ISUB.EQ.194) THEN
C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
C...Default final state is e+e-
KFA=KFPR(ISUBSV,1)
ALPRHT=2.16D0*(3D0/ITCM(1))
HP=AEM**2*COMFAC
SN2W=2D0*SQRT(XW*XW1)
C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
QUPD=2D0*RTCM(2)-1D0
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
FZX=-FAR/SN2W*RTCM(47)
SFAR=FAR**2
SFAO=FAO**2
SFZR=FZR**2
SFZO=FZO**2
SFZX=FZX**2
CALL PYWIDT(23,SH,WDTP,WDTE)
SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
C...Propagator including a_T^0
DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
$ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
C...Add in techni-a contribution
DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
$ SFZX*SSMR*SSMO)/DETD/SH
DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
XWRHT=1D0/(4D0*XW*(1D0-XW))
KFF=IABS(KFPR(ISUB,1))
EF=KCHG(KFF,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
VALF=0.5D0*(VF+AF)
VARF=0.5D0*(VF-AF)
FCOF=1D0
IF(KFF.LE.10) FCOF=3D0
WID2=1D0
IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
DZZ=DZZ*DCMPLX(XWRHT,0D0)
DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
DO 330 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.5D0*(VI+AI)
VARI=0.5D0*(VI-AI)
FCOI=FCOF
IF(IABS(I).LE.10) FCOI=FCOI/3D0
DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
& (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=HP*FCOI*FACSIG*WID2
330 CONTINUE
ELSEIF(ISUB.EQ.195) THEN
C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
KFA=KFPR(ISUBSV,1)
KFB=KFA+1
ALPRHT=2.16D0*(3D0/ITCM(1))
FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
C
C...Propagator including a_T^+
FWX=-FWR*RTCM(47)
CALL PYWIDT(24,SH,WDTP,WDTE)
SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
& DCMPLX(FWX**2,0D0)*SSMR
DWW=SSMR*SSMX/DETD/SH
FCOF=1D0
IF(KFA.LE.8) FCOF=3D0
HP=FACTC*ABS(DWW)**2*FCOF
DO 350 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
IA=IABS(I)
DO 340 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 340
KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HI=HP
IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
340 CONTINUE
350 CONTINUE
ENDIF
ELSEIF(ISUB.LE.380) THEN
ALPRHT=2.16D0*(3D0/ITCM(1))
IF(ISUB.EQ.361) THEN
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
FZX=-FAR/SN2W*RTCM(47)
SFAR=FAR**2
SFAO=FAO**2
SFZR=FZR**2
SFZO=FZO**2
SFZX=FZX**2
CALL PYWIDT(23,SH,WDTP,WDTE)
SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
$ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
C...Add in techni-a contribution
DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
$ SFZX*FAR*SSMO)/DETD/SH
DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
$ SFZX*FAO*SSMR)/DETD/SH
DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
$ SFZX*SSMR*SSMO)/DETD/SH
DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
C...W+W-, W pi_tc, pi_T pi_T, etc.
FACA=(SH**2*BE34**2-(TH-UH)**2)
VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
DO 370 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
IA=IABS(I)
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
C...........Eqs. (5) and (6) in LSTC-rates.pdf
F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
$ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
$ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
C...........Eqs. (5) and (7) in LSTC-rates.pdf
F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
C
C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
C
c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
HI=HI+HJ+HK
IF(IA.LE.10) HI=HI/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
IF(KFA.EQ.KFB) THEN
SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
ELSE
SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
ENDIF
370 CONTINUE
ELSEIF(ISUB.EQ.370) THEN
C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
C...f + fbar' -> gamma pi_tc, etc.
FACA=(SH**2*BE34**2-(TH-UH)**2)
FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
ALPRHT=2.16D0*(3D0/ITCM(1))
FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
FWX=-FWR*RTCM(47)
CALL PYWIDT(24,SH,WDTP,WDTE)
SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
& DCMPLX(FWX**2,0D0)*SSMR
DWW=SSMR*SSMX/DETD/SH
DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
$ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
C
C...........Eq. (25) in PRD67-115011 with DWW term dropped.
C
c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
C...Add in W_L Z_T axial and vector contributions.
IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
$ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
$ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
$ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
DO 410 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
IA=IABS(I)
DO 400 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 400
KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HI=HP
IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
ELSE
SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
& WIDS(PYCOMP(KFB),2)
ENDIF
400 CONTINUE
410 CONTINUE
ENDIF
ELSEIF(ISUB.LE.390) THEN
IF(ISUB.EQ.381) THEN
C...f + f' -> f + f' (g exchange)
FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
& MSTP(34)*2D0/3D0*UH2*REDQST)
FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
C...Modifications from contact interactions (compositeness)
FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
& (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
& (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
ELSEIF(ITCM(5).EQ.5) THEN
FACCI1=FACQQ1
FACCIB=FACQQB
FACCI2=FACQQ2
FACCI3=FACQQ1
CSM.......Check this change from
CSM RATCII=1D0
RATCII=RATQQI
ENDIF
DO 430 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
DO 420 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
& JA.GE.3))) THEN
SIGH(NCHN)=FACQQ1
IF(I.EQ.-J) SIGH(NCHN)=FACQQB
ELSE
SIGH(NCHN)=FACCI1
IF(I*J.LT.0) SIGH(NCHN)=FACCI3
IF(I.EQ.-J) SIGH(NCHN)=FACCIB
ENDIF
IF(I.EQ.J) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
ELSE
SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
SIGH(NCHN)=0.5D0*FACCI2*RATCII
ENDIF
ENDIF
420 CONTINUE
430 CONTINUE
ELSEIF(ISUB.EQ.382) THEN
C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
CALL PYWIDT(21,SH,WDTP,WDTE)
FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
IF(ITCM(5).EQ.1) THEN
C...Modifications from contact interactions (compositeness)
FACCIB=FACQQB
DO 440 I=1,2
FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
& WDTE(I,2)+WDTE(I,4))
440 CONTINUE
ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
& (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
ELSEIF(ITCM(5).EQ.5) THEN
FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
& WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
ENDIF
DO 450 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
SIGH(NCHN)=FACQQB
ELSEIF(ITCM(5).EQ.5) THEN
SIGH(NCHN)=FACQQB
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=FACCIB
ELSE
SIGH(NCHN)=FACCIB
ENDIF
450 CONTINUE
ELSEIF(ISUB.EQ.383) THEN
C...f + fbar -> g + g (q + qbar -> g + g only)
FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
IF(ITCM(5).EQ.5) THEN
FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
ENDIF
DO 460 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACGG1
IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=2
SIGH(NCHN)=0.5D0*FACGG2
IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
460 CONTINUE
ELSEIF(ISUB.EQ.384) THEN
C...f + g -> f + g (q + g -> q + g only)
FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
& UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
& SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
DO 480 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
DO 470 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQG1
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQG2
470 CONTINUE
480 CONTINUE
ELSEIF(ISUB.EQ.385) THEN
C...g + g -> f + fbar (g + g -> q + qbar only)
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
IDC0=MDCY(21,2)-1
C...Begin by d, u, s flavours.
FLAVWT=0D0
IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
& SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
& UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
& TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2
C...Next c and b flavours: modified that and uhat for fixed
C...cos(theta-hat).
DO 490 IFL=4,5
SQMAVG=PMAS(IFL,1)**2
IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
BE34=SQRT(1D0-4D0*SQMAVG/SH)
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
THUHQ=THQ*UHQ-SQMAVG*SH
IF(MSTP(34).EQ.0) THEN
FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
ELSE
FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
ENDIF
IF(ITCM(5).GE.5) THEN
IF(IFL.EQ.4) THEN
FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
& 2.25D0*THQ*UHQ/SH2*SQDLGS
FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
& 2.25D0*THQ*UHQ/SH2*SQDLGS
ELSE
FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
& 2.25D0*THQ*UHQ/SH2*SQDHGS
FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
& 2.25D0*THQ*UHQ/SH2*SQDHGS
ENDIF
ENDIF
FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1+2*(IFL-3)
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2+2*(IFL-3)
SIGH(NCHN)=FACQQ2
ENDIF
490 CONTINUE
500 CONTINUE
ELSEIF(ISUB.EQ.386) THEN
C...g + g -> g + g
IF(ITCM(5).LE.4) THEN
FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
& 2D0*TH/SH+TH2/SH2)*FACA
FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
& 2D0*SH/UH+SH2/UH2)*FACA
FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
& 2D0*UH/TH+UH2/TH2)
ELSE
GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
& 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
& 4D0*REDGST*(SH + 2D0*TH)*
& (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
& 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
& 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
& 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
& SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
& 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
& 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
& 4D0*REDGSU*(SH + 2D0*UH)*
& (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
& 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
& 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
& 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
& SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
& 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
& 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
& 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
& 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
& 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
& 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
& 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
& 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
& 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
& 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
& 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
& SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
& 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
FACGG3=COMFAC*AS**2*9D0/4D0*GUT
ENDIF
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=0.5D0*FACGG1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=0.5D0*FACGG2
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=3
SIGH(NCHN)=0.5D0*FACGG3
510 CONTINUE
ELSEIF(ISUB.EQ.387) THEN
C...q + qbar -> Q + Qbar
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
& 2D0*SQMAVG/SH)
IF(ITCM(5).GE.5) THEN
IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
FACQQB=FACQQB*SH2*SQDQTS
ELSE
FACQQB=FACQQB*SH2*SQDQQS
ENDIF
ENDIF
IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
WID2=1D0
IF(MINT(55).EQ.6) WID2=WIDS(6,1)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
FACQQB=FACQQB*WID2
DO 520 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQB
520 CONTINUE
ELSEIF(ISUB.EQ.388) THEN
C...g + g -> Q + Qbar
SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
THQ=-0.5D0*SH*(1D0-BE34*CTH)
UHQ=-0.5D0*SH*(1D0+BE34*CTH)
THUHQ=THQ*UHQ-SQMAVG*SH
IF(MSTP(34).EQ.0) THEN
FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
ELSE
FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
& UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
ENDIF
IF(ITCM(5).GE.5) THEN
IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
& 2.25D0*THQ*UHQ/SH2*SQDHGS
FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
& 2.25D0*THQ*UHQ/SH2*SQDHGS
ELSE
FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
& 2.25D0*THQ*UHQ/SH2*SQDLGS
FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
& 2.25D0*THQ*UHQ/SH2*SQDLGS
ENDIF
ENDIF
FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
IF(MSTP(35).GE.1) THEN
FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
FACQQ1=FACQQ1*FATRE
FACQQ2=FACQQ2*FATRE
ENDIF
WID2=1D0
IF(MINT(55).EQ.6) WID2=WIDS(6,1)
IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
FACQQ1=FACQQ1*WID2
FACQQ2=FACQQ2*WID2
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACQQ1
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=2
SIGH(NCHN)=FACQQ2
530 CONTINUE
ENDIF
ENDIF
CMRENNA--
RETURN
END
C*********************************************************************
C...PYSGEX
C...Subprocess cross sections for assorted exotic processes,
C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
C...Auxiliary to PYSIGH.
SUBROUTINE PYSGEX(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
&/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
C...Differential cross section expressions.
IF(ISUB.LE.160) THEN
IF(ISUB.EQ.141) THEN
C...f + fbar -> gamma*/Z0/Z'0
SQMZP=PMAS(32,1)**2
MINT(61)=2
CALL PYWIDT(32,SH,WDTP,WDTE)
HP0=AEM/3D0*SH
HP1=AEM/3D0*XWC*SH
HP2=HP1
HS=SHR*VINT(117)
HSP=SHR*WDTP(0)
FACZP=4D0*COMFAC*3D0
DO 100 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI)
VI=AI-4D0*EI*XWV
IA=IABS(I)
IF(IA.LT.10) THEN
IF(IA.LE.2) THEN
VPI=PARU(123-2*MOD(IABS(I),2))
API=PARU(124-2*MOD(IABS(I),2))
ELSEIF(IA.LE.4) THEN
VPI=PARJ(182-2*MOD(IABS(I),2))
API=PARJ(183-2*MOD(IABS(I),2))
ELSE
VPI=PARJ(190-2*MOD(IABS(I),2))
API=PARJ(191-2*MOD(IABS(I),2))
ENDIF
ELSE
IF(IA.LE.12) THEN
VPI=PARU(127-2*MOD(IABS(I),2))
API=PARU(128-2*MOD(IABS(I),2))
ELSEIF(IA.LE.14) THEN
VPI=PARJ(186-2*MOD(IABS(I),2))
API=PARJ(187-2*MOD(IABS(I),2))
ELSE
VPI=PARJ(194-2*MOD(IABS(I),2))
API=PARJ(195-2*MOD(IABS(I),2))
ENDIF
ENDIF
HI0=HP0
IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
HI1=HP1
IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
HI2=HP2
IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
C...Special case: if only branching ratios known then use them.
IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
HI=0D0
IF(IA.LT.10) THEN
HI=SHR*WDTP(IA)*FACA/9D0
ELSEIF(IA.LT.20) THEN
HI=SHR*WDTP(IA-2)
ENDIF
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
ELSE
C...Normal cross section.
SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
& (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
& VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
& (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
& ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
& ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
& ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
& (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
ENDIF
100 CONTINUE
ELSEIF(ISUB.EQ.142) THEN
C...f + fbar' -> W'+/-
SQMWP=PMAS(34,1)**2
CALL PYWIDT(34,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
HP=AEM/(24D0*XW)*SH
DO 120 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
IA=IABS(I)
DO 110 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 110
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
C...Special case: if only branching ratios known then use them.
IF(MWID(34).EQ.2) THEN
HI=0D0
DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
& IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
& .AND.JA.EQ.IABS(KFDP(IDC,1))))
& HI=SHR*WDTP(IDC+1-MDCY(34,2))
105 CONTINUE
IF(IA.LT.10) HI=HI*FACA/9D0
ELSE
C...Normal cross section.
HI=HP*(PARU(133)**2+PARU(134)**2)
IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
& VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
SIGH(NCHN)=HI*FACBW*HF
110 CONTINUE
120 CONTINUE
ELSEIF(ISUB.EQ.144) THEN
C...f + fbar' -> R
SQMR=PMAS(41,1)**2
CALL PYWIDT(41,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
HP=AEM/(12D0*XW)*SH
DO 140 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
IA=IABS(I)
DO 130 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
JA=IABS(J)
IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
HI=HP
IF(IA.LE.10) HI=HI*FACA/3D0
HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
130 CONTINUE
140 CONTINUE
ELSEIF(ISUB.EQ.145) THEN
C...q + l -> LQ (leptoquark)
SQMLQ=PMAS(42,1)**2
CALL PYWIDT(42,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
HP=AEM/4D0*SH
KFLQQ=KFDP(MDCY(42,2),1)
KFLQL=KFDP(MDCY(42,2),2)
DO 160 I=MMIN1,MMAX1
IF(KFAC(1,I).EQ.0) GOTO 160
IA=IABS(I)
IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
DO 150 J=MMIN2,MMAX2
IF(KFAC(2,J).EQ.0) GOTO 150
JA=IABS(J)
IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
IF(JA.EQ.IA) GOTO 150
IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
HI=HP*PARU(151)
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
150 CONTINUE
160 CONTINUE
ELSEIF(ISUB.EQ.146) THEN
C...e + gamma* -> e* (excited lepton)
KFQSTR=KFPR(ISUB,1)
KCQSTR=PYCOMP(KFQSTR)
KFQEXC=MOD(KFQSTR,KEXCIT)
CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
QF=-RTCM(43)/2D0-RTCM(44)/2D0
FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
& FACBW=0D0
HP=SH
DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
DO 170 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
HI=HP
IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
170 CONTINUE
180 CONTINUE
ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
C...d + g -> d* and u + g -> u* (excited quarks)
KFQSTR=KFPR(ISUB,1)
KCQSTR=PYCOMP(KFQSTR)
KFQEXC=MOD(KFQSTR,KEXCIT)
CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
& FACBW=0D0
HP=SH
DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
DO 190 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
HI=HP
IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
190 CONTINUE
200 CONTINUE
ENDIF
ELSEIF(ISUB.LE.190) THEN
IF(ISUB.EQ.162) THEN
C...q + g -> LQ + lbar; LQ=leptoquark
SQMLQ=PMAS(42,1)**2
FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
& (UH2+SQMLQ**2)/(UH-SQMLQ)**2
KFLQQ=KFDP(MDCY(42,2),1)
DO 220 I=MMINA,MMAXA
IF(IABS(I).NE.KFLQQ) GOTO 220
KCHLQ=ISIGN(1,I)
DO 210 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
210 CONTINUE
220 CONTINUE
ELSEIF(ISUB.EQ.163) THEN
C...g + g -> LQ + LQbar; LQ=leptoquark
SQMLQ=PMAS(42,1)**2
FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
& (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
& (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
& ((TH-SQMLQ)*(UH-SQMLQ)))
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
C...Since don't know proper colour flow, randomize between alternatives
ISIG(NCHN,3)=INT(1.5D0+PYR(0))
SIGH(NCHN)=FACLQ
230 CONTINUE
ELSEIF(ISUB.EQ.164) THEN
C...q + qbar -> LQ + LQbar; LQ=leptoquark
DELTA=0.25D0*(SQM3-SQM4)**2/SH
SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
TH=TH-DELTA
UH=UH-DELTA
C SQMLQ=PMAS(42,1)**2
FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
& (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
& (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
& ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
KFLQQ=KFDP(MDCY(42,2),1)
DO 240 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACLQA
IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
240 CONTINUE
ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
KFQSTR=KFPR(ISUB,2)
KCQSTR=PYCOMP(KFQSTR)
KFQEXC=MOD(KFQSTR,KEXCIT)
FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
& (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
C...Propagators: as simulated in PYOFSH and as desired
GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
GMMQC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
FACQSA=FACQSA*HBW4C/HBW4
FACQSB=FACQSB*HBW4C/HBW4
C...Branching ratios.
BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
DO 260 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
DO 250 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
ELSEIF(I.EQ.-J) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
ENDIF
250 CONTINUE
260 CONTINUE
ELSEIF(ISUB.EQ.169) THEN
C...q + qbar -> e + e* (excited lepton)
KFQSTR=KFPR(ISUB,2)
KCQSTR=PYCOMP(KFQSTR)
KFQEXC=MOD(KFQSTR,KEXCIT)
FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
& (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
C...Propagators: as simulated in PYOFSH and as desired
GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
GMMQC=SQRT(SQM4)*WDTP(0)
HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
FACQSB=FACQSB*HBW4C/HBW4
C...Branching ratios.
BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
DO 270 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
J=-I
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=2
IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
270 CONTINUE
ENDIF
ELSEIF(ISUB.LE.360) THEN
IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
C...l + l -> H_L++/-- or H_R++/--.
KFRES=KFPR(ISUB,1)
KFREC=PYCOMP(KFRES)
CALL PYWIDT(KFRES,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
DO 290 I=MMIN1,MMAX1
IA=IABS(I)
IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
& GOTO 290
DO 280 J=MMIN2,MMAX2
JA=IABS(J)
IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
& GOTO 280
IF(I*J.LT.0) GOTO 280
KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
SIGH(NCHN)=HI*FACBW*HF
280 CONTINUE
290 CONTINUE
ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
KFRES=KFPR(ISUB,1)
KFREC=PYCOMP(KFRES)
C...Propagators: as simulated in PYOFSH and as desired
HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
& (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
GMMC=SQRT(SQM3)*WDTP(0)
HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
FHCC=COMFAC*AEM*HBW3C/HBW3
DO 310 I=MMINA,MMAXA
IA=IABS(I)
IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
SQML=PMAS(IA,1)**2
J=ISIGN(KFPR(ISUB,2),-I)
KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
& (UH-SQM3)**2
SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
& (TH-SQM4)*SH)/(TH-SQM4)**2
SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
& SH)/(SH-SQML)**2
SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
& 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
& ((UH-SQM3)*(TH-SQM4))
SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
& SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
& ((UH-SQM3)*(SH-SQML))
SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
& 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
& ((SH-SQML)*(TH-SQM4))
SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
& PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
DO 300 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=22
ISIG(NCHN,3)=0
SIGH(NCHN)=FHCC*SMM*WIDSC
300 CONTINUE
310 CONTINUE
ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
KFRES=KFPR(ISUB,1)
KFREC=PYCOMP(KFRES)
SQMH=PMAS(KFREC,1)**2
GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
C...Propagators: H++/-- as simulated in PYOFSH and as desired
HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
GMMH3=SQRT(SQM3)*WDTP(0)
HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
GMMH4=SQRT(SQM4)*WDTP(0)
HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
C...Kinematical and coupling functions
FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
C...Loop over allowed flavours
DO 320 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)
VI=AI-4D0*EI*XWV
FCOI=1D0
IF(IABS(I).LE.10) FCOI=FACA/3D0
IF(ISUB.EQ.349) THEN
HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
IF(IABS(I).LT.10) THEN
DSIGHH=8D0*AEM**2*(EI**2/SH2+
& 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
& (VI**2+AI**2)*XWHH**2*HBWZ)
ELSE
IAOFF=181+3*((IABS(I)-11)/2)
HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
& (4D0*PARU(1))
DSIGHH=8D0*AEM**2*(EI**2/SH2+
& 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
& (VI**2+AI**2)*XWHH**2*HBWZ)+
& 8D0*AEM*(EI*HSUM/(SH*TH)+
& (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
& 4D0*HSUM**2/TH2
ENDIF
ELSE
IF(IABS(I).LT.10) THEN
DSIGHH=8D0*AEM**2*EI**2/SH2
ELSE
IAOFF=181+3*((IABS(I)-11)/2)
HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
& (4D0*PARU(1))
DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
& 4D0*HSUM**2/TH2
ENDIF
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACHH*FCOI*DSIGHH
320 CONTINUE
ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
KFRES=KFPR(ISUB,1)
KFREC=PYCOMP(KFRES)
SQMH=PMAS(KFREC,1)**2
IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
& PMAS(PYCOMP(9900024),1)**2
FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
FACPRT=1D0/((VINT(204)**2-VINT(215))*
& (VINT(209)**2-VINT(216)))
FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
& (VINT(209)**2+2D0*VINT(218)))
CALL PYWIDT(KFRES,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
& FACBW=0D0
DO 340 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
DO 330 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
KCHH=KCHWI+KCHWJ
IF(IABS(KCHH).NE.2) GOTO 330
FACLR=VINT(180+I)*VINT(180+J)
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
IF(I.EQ.J.AND.IABS(I).GT.10) THEN
FACPRP=0.5D0*(FACPRT+FACPRU)**2
ELSE
FACPRP=FACPRT**2
ENDIF
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
330 CONTINUE
340 CONTINUE
ELSEIF(ISUB.EQ.353) THEN
C...f + fbar -> Z_R0
SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
DO 350 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
IF(IABS(I).LE.8) THEN
EI=KCHG(IABS(I),1)/3D0
AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
ELSE
AI=-(1D0-2D0*XW)
VI=-1D0+4D0*XW
ENDIF
HI=HP*(VI**2+AI**2)
IF(IABS(I).LE.10) HI=HI*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=HI*FACBW*HF
350 CONTINUE
ELSEIF(ISUB.EQ.354) THEN
C...f + fbar' -> W_R+/-
SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
HP=AEM/(24D0*XW)*SH
DO 370 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
IA=IABS(I)
DO 360 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 360
KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
HI=HP*2D0
IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
SIGH(NCHN)=HI*FACBW*HF
360 CONTINUE
370 CONTINUE
ENDIF
ELSEIF(ISUB.LE.400) THEN
IF(ISUB.EQ.391) THEN
C...f + fbar -> G*.
KFGSTR=KFPR(ISUB,1)
KCGSTR=PYCOMP(KFGSTR)
CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
& ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
C...Modify cross section in wings of peak.
FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
DO 380 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
HI=1D0
IF(IABS(I).LE.10) HI=HI*FACA/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACG*HI
380 CONTINUE
ELSEIF(ISUB.EQ.392) THEN
C...g + g -> G*.
KFGSTR=KFPR(ISUB,1)
KCGSTR=PYCOMP(KFGSTR)
CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
& ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
C...Modify cross section in wings of peak.
FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACG
390 CONTINUE
ELSEIF(ISUB.EQ.393) THEN
C...q + qbar -> g + G*.
KFGSTR=KFPR(ISUB,2)
KCGSTR=PYCOMP(KFGSTR)
FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
& (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
& 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
& 2D0*SH2/(TH*UH))
C...Propagators: as simulated in PYOFSH and as desired
GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
HS=SQRT(SQM4)*WDTP(0)
HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
FACG=FACG*HBW4C/HBW4
DO 400 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=FACG
400 CONTINUE
ELSEIF(ISUB.EQ.394) THEN
C...q + g -> q + G*.
KFGSTR=KFPR(ISUB,2)
KCGSTR=PYCOMP(KFGSTR)
FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
& (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
& 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
& 2D0*TH2*TH/(UH*SH2))
C...Propagators: as simulated in PYOFSH and as desired
GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
HS=SQRT(SQM4)*WDTP(0)
HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
FACG=FACG*HBW4C/HBW4
DO 420 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
DO 410 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACG
410 CONTINUE
420 CONTINUE
ELSEIF(ISUB.EQ.395) THEN
C...g + g -> g + G*.
KFGSTR=KFPR(ISUB,2)
KCGSTR=PYCOMP(KFGSTR)
FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
& ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
& 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
C...Propagators: as simulated in PYOFSH and as desired
GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
HS=SQRT(SQM4)*WDTP(0)
HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
FACG=FACG*HBW4C/HBW4
IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=FACG
ENDIF
ENDIF
ELSEIF(ISUB.LE.500) THEN
IF(ISUBSV.EQ.481) ISUB=482
c... GENERIC 2->(1)->2
IF(ISUB.EQ.482) THEN
KFRES=9900001
KCRES=PYCOMP(KFRES)
IF(KCRES.EQ.0) RETURN
IDCY=MDCY(KCRES,2)
KCOL=KCHG(KCRES,2)
KCEM=KCHG(KCRES,1)
FACT=COMFAC
KCF1=PYCOMP(KFPR(ISUB,1))
KCF2=PYCOMP(KFPR(ISUB,2))
IF(ISUBSV.EQ.481) THEN
SQMZR=PMAS(KCRES,1)**2
CALL PYWIDT(KFRES,SH,WDTP,WDTE)
HS=SHR*WDTP(0)
FACBW=SH2/((SH-SQMZR)**2+HS**2)
FACT=FACT*FACBW
ELSE
SQMH=PMAS(KCF1,1)**2
GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
C...Propagators: as simulated in PYOFSH and as desired
HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
GMMH3=SQRT(SQM3)*WDTP(0)
HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
SQMH=PMAS(KCF2,1)**2
GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
GMMH4=SQRT(SQM4)*WDTP(0)
HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
ENDIF
KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
IF(KCOL.EQ.0) THEN
NCOL=1
ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
NCOL=3
ELSE
NCOL=2
ENDIF
ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
NCOL=2
ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
$ JCOL2.EQ.0) THEN
NCOL=1
ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
$ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
NCOL=1
ELSE
NCOL=2
ENDIF
DO 440 I=MMIN1,MMAX1
IF(KFAC(1,I).EQ.0) GOTO 440
IP=I
IF(IP.EQ.0) IP=21
IA=ABS(IP)
DO 430 J=MMIN2,MMAX2
IF(KFAC(2,J).EQ.0) GOTO 430
JP=J
IF(JP.EQ.0) JP=21
JA=ABS(JP)
IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
$ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
DO II=1,NCOL
NCHN=NCHN+1
ISIG(NCHN,1)=IP
ISIG(NCHN,2)=JP
ISIG(NCHN,3)=II
SIGH(NCHN)=FACT/NCOL
ENDDO
ENDIF
ENDIF
430 CONTINUE
440 CONTINUE
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYPDFU
C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
C...parton distributions according to a few different parametrizations.
C...Note that what is coded is x times the probability distribution,
C...i.e. xq(x,Q2) etc.
SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
&XPDIR(-6:6)
COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
& XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
& XMI(2,240),PT2MI(240),IMISEP(0:240)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
&/PYINT9/,/PYINTM/
C...Local arrays.
DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
&XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
SAVE PPAR
C...Interface to PDFLIB.
COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
SAVE /W50513/
DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
&VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
CHARACTER*20 PARM(20)
DATA VALUE/20*0D0/,PARM/20*' '/
C...Data related to Schuler-Sjostrand photon distributions.
DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
C...Valence PDF momentum integral parametrizations PER PARTON!
DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
&LOG(LOG(MAX(Q2,1D0)/0.04D0)))
C...Reset parton distributions.
MINT(92)=0
DO 100 KFL=-25,25
XPQ(KFL)=0D0
100 CONTINUE
DO 110 KFL=-6,6
XPVAL(KFL)=0D0
110 CONTINUE
C...Check x and particle species.
IF(X.LE.0D0.OR.X.GE.1D0) THEN
WRITE(MSTU(11),5000) X
GOTO 9999
ENDIF
KFA=IABS(KF)
IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
&KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
&KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
&KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
&KFA.NE.310.AND.KFA.NE.130) THEN
WRITE(MSTU(11),5100) KF
GOTO 9999
ENDIF
C...Electron (or muon or tau) parton distribution call.
IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
CALL PYPDEL(KFA,X,Q2,XPEL)
DO 120 KFL=-25,25
XPQ(KFL)=XPEL(KFL)
120 CONTINUE
C...Photon parton distribution call (VDM+anomalous).
ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
CALL PYPDGA(X,Q2,XPGA)
DO 130 KFL=-6,6
XPQ(KFL)=XPGA(KFL)
130 CONTINUE
XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
XPVAL(1)=XPVU/4D0
XPVAL(2)=XPVU
XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
XPVAL(4)=MIN(XPQ(4),XPVU)
XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
XPVAL(-1)=XPVAL(1)
XPVAL(-2)=XPVAL(2)
XPVAL(-3)=XPVAL(3)
XPVAL(-4)=XPVAL(4)
XPVAL(-5)=XPVAL(5)
ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
Q2MX=Q2
P2MX=0.36D0
IF(MSTP(55).GE.7) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
DO 140 KFL=-6,6
XPQ(KFL)=XPGA(KFL)
XPVAL(KFL)=VXPDGM(KFL)
140 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
Q2MX=Q2
P2MX=0.36D0
IF(MSTP(55).GE.11) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
DO 150 KFL=-6,6
XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
150 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(56).EQ.2) THEN
C...Call PDFLIB parton distributions.
PARM(1)='NPTYPE'
VALUE(1)=3
PARM(2)='NGROUP'
VALUE(2)=MSTP(55)/1000
PARM(3)='NSET'
VALUE(3)=MOD(MSTP(55),1000)
IF(MINT(93).NE.3000000+MSTP(55)) THEN
CALL PDFSET(PARM,VALUE)
MINT(93)=3000000+MSTP(55)
ENDIF
XX=X
QQ2=MAX(0D0,Q2MIN,Q2)
IF(MSTP(57).EQ.0) QQ2=Q2MIN
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
IP2=MSTP(60)
IF(MSTP(55).EQ.5004) THEN
IF(5D0*P2.LT.QQ2.AND.
& QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
& P2.GE.0D0.AND.P2.LT.10D0.AND.
& XX.GT.1D-4.AND.XX.LT.1D0) THEN
CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
& BOT,TOP,GLU)
ELSE
UPV=0D0
DNV=0D0
USEA=0D0
DSEA=0D0
STR=0D0
CHM=0D0
BOT=0D0
TOP=0D0
GLU=0D0
ENDIF
ELSE
IF(P2.LT.QQ2) THEN
CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
& BOT,TOP,GLU)
ELSE
UPV=0D0
DNV=0D0
USEA=0D0
DSEA=0D0
STR=0D0
CHM=0D0
BOT=0D0
TOP=0D0
GLU=0D0
ENDIF
ENDIF
VINT(231)=Q2MIN
XPQ(0)=GLU
XPQ(1)=DNV
XPQ(-1)=DNV
XPQ(2)=UPV
XPQ(-2)=UPV
XPQ(3)=STR
XPQ(-3)=STR
XPQ(4)=CHM
XPQ(-4)=CHM
XPQ(5)=BOT
XPQ(-5)=BOT
XPQ(6)=TOP
XPQ(-6)=TOP
XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
XPVAL(1)=XPVU/4D0
XPVAL(2)=XPVU
XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
XPVAL(4)=MIN(XPQ(4),XPVU)
XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
XPVAL(-1)=XPVAL(1)
XPVAL(-2)=XPVAL(2)
XPVAL(-3)=XPVAL(3)
XPVAL(-4)=XPVAL(4)
XPVAL(-5)=XPVAL(5)
ELSE
WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
ENDIF
C...Pion/gammaVDM parton distribution call.
ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
&KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
& MSTP(55).LE.12) THEN
ISET=1+MOD(MSTP(55)-1,4)
Q2MX=Q2
P2MX=0.36D0
IF(ISET.GE.3) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
DO 160 KFL=-6,6
XPQ(KFL)=XPVMD(KFL)
XPVAL(KFL)=VXPVMD(KFL)
160 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
CALL PYPDPI(X,Q2,XPPI)
DO 170 KFL=-6,6
XPQ(KFL)=XPPI(KFL)
170 CONTINUE
XPVAL(2)=XPQ(2)-XPQ(-2)
XPVAL(-1)=XPQ(-1)-XPQ(1)
ELSEIF(MSTP(54).EQ.2) THEN
C...Call PDFLIB parton distributions.
PARM(1)='NPTYPE'
VALUE(1)=2
PARM(2)='NGROUP'
VALUE(2)=MSTP(53)/1000
PARM(3)='NSET'
VALUE(3)=MOD(MSTP(53),1000)
IF(MINT(93).NE.2000000+MSTP(53)) THEN
CALL PDFSET(PARM,VALUE)
MINT(93)=2000000+MSTP(53)
ENDIF
XX=X
QQ=SQRT(MAX(0D0,Q2MIN,Q2))
IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
VINT(231)=Q2MIN
XPQ(0)=GLU
XPQ(1)=DSEA
XPQ(-1)=UPV+DSEA
XPQ(2)=UPV+USEA
XPQ(-2)=USEA
XPQ(3)=STR
XPQ(-3)=STR
XPQ(4)=CHM
XPQ(-4)=CHM
XPQ(5)=BOT
XPQ(-5)=BOT
XPQ(6)=TOP
XPQ(-6)=TOP
XPVAL(2)=UPV
XPVAL(-1)=UPV
ELSE
WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
ENDIF
C...Anomalous photon parton distribution call.
ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
Q2MX=Q2
P2MX=PARP(15)**2
IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
DO 180 KFL=-6,6
XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
180 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(56).EQ.1) THEN
IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
DO 190 KFL=-6,6
XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
190 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(56).EQ.2) THEN
IF(MSTP(57).EQ.0) Q2MX=P2MX
CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
DO 200 KFL=-6,6
XPQ(KFL)=XPGA(KFL)
XPVAL(KFL)=VXPGA(KFL)
200 CONTINUE
VINT(231)=P2MX
ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
IF(MSTP(57).EQ.0) Q2MX=P2MX
CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
DO 210 KFL=-6,6
XPQ(KFL)=XPGA(KFL)
XPVAL(KFL)=VXPGA(KFL)
210 CONTINUE
VINT(231)=P2MX
ELSE
220 RKF=11D0*PYR(0)
KFR=1
IF(RKF.GT.1D0) KFR=2
IF(RKF.GT.5D0) KFR=3
IF(RKF.GT.6D0) KFR=4
IF(RKF.GT.10D0) KFR=5
IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
IF(MSTP(57).EQ.0) Q2MX=P2MX
CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
DO 230 KFL=-6,6
XPQ(KFL)=XPGA(KFL)
XPVAL(KFL)=VXPGA(KFL)
230 CONTINUE
VINT(231)=P2MX
ENDIF
C...Proton parton distribution call.
ELSE
IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
CALL PYPDPR(X,Q2,XPPR)
DO 240 KFL=-6,6
XPQ(KFL)=XPPR(KFL)
240 CONTINUE
C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
ELSEIF(MSTP(52).EQ.2) THEN
C...Call PDFLIB parton distributions.
PARM(1)='NPTYPE'
VALUE(1)=1
PARM(2)='NGROUP'
VALUE(2)=MSTP(51)/1000
PARM(3)='NSET'
VALUE(3)=MOD(MSTP(51),1000)
IF(MINT(93).NE.1000000+MSTP(51)) THEN
call setlhaparm('SILENT')
CALL PDFSET(PARM,VALUE)
MINT(93)=1000000+MSTP(51)
ENDIF
XX=X
QQ=SQRT(MAX(0D0,Q2MIN,Q2))
IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
VINT(231)=Q2MIN
XPQ(0)=GLU
XPQ(1)=DNV+DSEA
XPQ(-1)=DSEA
XPQ(2)=UPV+USEA
XPQ(-2)=USEA
XPQ(3)=STR
XPQ(-3)=STR
XPQ(4)=CHM
XPQ(-4)=CHM
XPQ(5)=BOT
XPQ(-5)=BOT
XPQ(6)=TOP
XPQ(-6)=TOP
XPVAL(1)=DNV
XPVAL(2)=UPV
ELSE
WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
ENDIF
ENDIF
C...Isospin average for pi0/gammaVDM.
IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
XPV=XPQ(2)-XPQ(1)
XPQ(2)=XPQ(1)
XPQ(-2)=XPQ(-1)
ELSE
XPS=0.5D0*(XPQ(1)+XPQ(-2))
XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
XPQ(2)=XPS
XPQ(-1)=XPS
ENDIF
XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
& XPVAL(3)+XPVAL(4)+XPVAL(5)
DO 250 KFL=-6,6
XPVAL(KFL)=0D0
250 CONTINUE
IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
XPQ(1)=XPQ(1)+0.2D0*XPV
XPQ(2)=XPQ(2)+0.8D0*XPV
XPVAL(1)=0.2D0*XPVL
XPVAL(2)=0.8D0*XPVL
ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
XPQ(3)=XPQ(3)+XPV
XPVAL(3)=XPVL
ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
XPQ(4)=XPQ(4)+XPV
XPVAL(4)=XPVL
IF(MSTP(55).GE.9) THEN
DO 260 KFL=-6,6
XPQ(KFL)=0D0
260 CONTINUE
ENDIF
ELSE
XPQ(1)=XPQ(1)+0.5D0*XPV
XPQ(2)=XPQ(2)+0.5D0*XPV
XPVAL(1)=0.5D0*XPVL
XPVAL(2)=0.5D0*XPVL
ENDIF
DO 270 KFL=1,6
XPQ(-KFL)=XPQ(KFL)
XPVAL(-KFL)=XPVAL(KFL)
270 CONTINUE
C...Rescale for gammaVDM by effective gamma -> rho coupling.
C+++Do not rescale?
IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
& .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
DO 280 KFL=-6,6
XPQ(KFL)=VINT(281)*XPQ(KFL)
XPVAL(KFL)=VINT(281)*XPVAL(KFL)
280 CONTINUE
VINT(232)=VINT(281)*XPV
ENDIF
C...Simple recipes for kaons.
ELSEIF(KFA.EQ.321) THEN
XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
XPQ(-1)=XPQ(1)
XPVAL(-3)=XPVAL(-1)
XPVAL(-1)=0D0
ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
XPS=0.5D0*(XPQ(1)+XPQ(-2))
XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
XPQ(2)=XPS
XPQ(-1)=XPS
XPQ(1)=XPQ(1)+0.5D0*XPV
XPQ(-1)=XPQ(-1)+0.5D0*XPV
XPQ(3)=XPQ(3)+0.5D0*XPV
XPQ(-3)=XPQ(-3)+0.5D0*XPV
XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
XPVAL(2)=0D0
XPVAL(-1)=0D0
XPVAL(1)=0.5D0*XPV
XPVAL(-1)=0.5D0*XPV
XPVAL(3)=0.5D0*XPV
XPVAL(-3)=0.5D0*XPV
C...Isospin conjugation for neutron.
ELSEIF(KFA.EQ.2112) THEN
XPSV=XPQ(1)
XPQ(1)=XPQ(2)
XPQ(2)=XPSV
XPSV=XPQ(-1)
XPQ(-1)=XPQ(-2)
XPQ(-2)=XPSV
XPSV=XPVAL(1)
XPVAL(1)=XPVAL(2)
XPVAL(2)=XPSV
C...Simple recipes for hyperon (average valence parton distribution).
ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
& .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
XPS=0.5D0*(XPQ(-1)+XPQ(-2))
XPQ(1)=XPS
XPQ(2)=XPS
XPQ(-1)=XPS
XPQ(-2)=XPS
XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
XPV=(XPVAL(1)+XPVAL(2))/3D0
XPVAL(1)=0D0
XPVAL(2)=0D0
XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
ENDIF
C...Charge conjugation for antiparticle.
IF(KF.LT.0) THEN
DO 290 KFL=1,25
IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
XPSV=XPQ(KFL)
XPQ(KFL)=XPQ(-KFL)
XPQ(-KFL)=XPSV
290 CONTINUE
DO 300 KFL=1,6
XPSV=XPVAL(KFL)
XPVAL(KFL)=XPVAL(-KFL)
XPVAL(-KFL)=XPSV
300 CONTINUE
ENDIF
C...MULTIPLE INTERACTIONS - PDF RESHAPING.
C...Set side.
JS=MINT(30)
C...Only reshape PDFs for the non-first interactions;
C...But need valence/sea separation already from first interaction.
IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
KFVSEL=KFIVAL(JS,1)
C...If valence quark kicked out of pi0 or gamma then that decides
C...whether we should consider state as d dbar, u ubar, s sbar, etc.
IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
XPVL=0D0
DO 310 KFL=1,6
XPVL=XPVL+XPVAL(KFL)
XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
XPVAL(KFL)=0D0
310 CONTINUE
XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
XPVAL(IABS(KFVSEL))=XPVL
DO 320 KFL=1,6
XPQ(-KFL)=XPQ(KFL)
XPVAL(-KFL)=XPVAL(KFL)
320 CONTINUE
C...If valence quark kicked out of K0S or K0S then that decides whether
C...we should consider state as d sbar or s dbar.
ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
KFS=1
IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
XPVAL(-KFS)=0D0
KFS=-3*KFS
XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
XPVAL(-KFS)=0D0
ENDIF
C...XPQ distributions are nominal for a (signed) beam particle
C...of KF type, with 1-Sum(x_prev) rescaled to 1.
CMPFAC=1D0
NRESC=0
345 NRESC=NRESC+1
PVCTOT(JS,-1)=0D0
PVCTOT(JS, 0)=0D0
PVCTOT(JS, 1)=0D0
DO 350 IFL=-6,6
IF(IFL.EQ.0) GOTO 350
C...Count up number of original IFL valence quarks.
IVORG=0
IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
C...bookkeep as if d dbar (for total momentum sum in valence sector).
IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
C...Count down number of remaining IFL valence quarks. Skip current
C...interaction initiator.
IVREM=IVORG
DO 330 I1=1,NMI(JS)
IF (I1.EQ.MINT(36)) GOTO 330
IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
& IVREM=IVREM-1
330 CONTINUE
C...Separate out original VALENCE and SEA content.
VAL=XPVAL(IFL)
SEA=MAX(0D0,XPQ(IFL)-VAL)
XPSVC(IFL,0)=VAL
XPSVC(IFL,-1)=SEA
C...Rescale valence content if changed.
IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
& (VAL*IVREM)/IVORG
C...Momentum integrals of original and removed valence quarks.
IF(IVORG.NE.0) THEN
C...For p/n/pbar/nbar beams can split into d_val and u_val.
C...Isospin conjugation for neutrons
IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
IAFLP=IABS(IFL)
IF (KFA.EQ.2112) IAFLP=3-IAFLP
VPAVG=PAVG(IAFLP,Q2)
C...For other baryons average d_val and u_val, like for PDFs.
ELSEIF(KFA.GT.1000) THEN
VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
C...For mesons and photon average d_val and u_val and scale by 3/2.
C...Very crude, especially for photon.
ELSE
VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
ENDIF
PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
ENDIF
C...Now add companions (at X with partner having been at Z=XASSOC).
C...NOTE: due to the assumed simple x scaling, the partner was at what
C...corresponds to a higher Z than XASSOC, if there were intermediate
C...scatterings. Nothing done about that for the moment.
DO 340 IVC=1,NVC(JS,IFL)
C...Skip companions that have been kicked out
IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
XPSVC(IFL,IVC)=0D0
GOTO 340
ELSE
C...Momentum fraction of the partner quark.
C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
XS=XASSOC(JS,IFL,IVC)
XREM=VINT(142+JS)
YS=XS/(XREM+XS)
C...Momentum fraction of the companion quark.
C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
Y=X*(1D0-YS)
XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
C...Add to momentum sum, with rescaling compensation factor.
XCFAC=(XREM+XS)/XREM*CMPFAC
PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
ENDIF
340 CONTINUE
350 CONTINUE
C...Wait until all flavours treated, then rescale seas and gluon.
XPSVC(0,-1)=XPQ(0)
XPSVC(0,0)=0D0
RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
IF (RSFAC.LE.0D0) THEN
C...First calculate factor needed to exactly restore pz cons.
IF (NRESC.EQ.1) CMPFAC =
& (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
C...Add a bit of headroom
CMPFAC=0.99*CMPFAC
C...Try a few times if more headroom is needed, then print error message.
IF (NRESC.LE.10) GOTO 345
CALL PYERRM(15,
& '(PYPDFU:) Negative reshaping factor persists!')
WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
RSFAC=0D0
ENDIF
DO 370 IFL=-6,6
XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
C...Also store resulting distributions in XPQ
XPQ(IFL)=0D0
DO 360 ISVC=-1,NVC(JS,IFL)
XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
360 CONTINUE
370 CONTINUE
C...Save companion reweighting factor for PYPTIS.
VINT(140)=CMPFAC
ENDIF
C...Allow gluon also in position 21.
XPQ(21)=XPQ(0)
C...Check positivity and reset above maximum allowed flavour.
DO 380 KFL=-25,25
XPQ(KFL)=MAX(0D0,XPQ(KFL))
IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
380 CONTINUE
C...Formats for error printouts.
5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
5100 FORMAT(' Error: illegal particle code for parton distribution;',
&' KF =',I5)
5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
&3I5)
5300 FORMAT(' Original valence momentum fraction : ',F6.3/
& ' Removed valence momentum fraction : ',F6.3/
& ' Added companion momentum fraction : ',F6.3/
& ' Resulting rescale factor : ',F6.3)
C...Reset side pointer and return
9999 MINT(30)=0
RETURN
END
C*********************************************************************
C...PYPDFL
C...Gives proton parton distribution at small x and/or Q^2 according to
C...correct limiting behaviour.
SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
MINT(92)=0
KFA=IABS(KF)
IACC=0
IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
IF(IACC.EQ.0) THEN
CALL PYPDFU(KF,X,Q2,XPQ)
RETURN
ENDIF
C...Reset. Check x.
DO 100 KFL=-25,25
XPQ(KFL)=0D0
100 CONTINUE
IF(X.LE.0D0.OR.X.GE.1D0) THEN
WRITE(MSTU(11),5000) X
RETURN
ENDIF
C...Define valence content.
KFC=KF
NV1=2
NV2=1
IF(KF.EQ.2212) THEN
KFV1=2
KFV2=1
ELSEIF(KF.EQ.-2212) THEN
KFV1=-2
KFV2=-1
ELSEIF(KF.EQ.2112) THEN
KFV1=1
KFV2=2
ELSEIF(KF.EQ.-2112) THEN
KFV1=-1
KFV2=-2
ELSEIF(KF.EQ.211) THEN
NV1=1
KFV1=2
KFV2=-1
ELSEIF(KF.EQ.-211) THEN
NV1=1
KFV1=-2
KFV2=1
ELSEIF(MINT(105).LE.223) THEN
KFV1=1
WTV1=0.2D0
KFV2=2
WTV2=0.8D0
ELSEIF(MINT(105).EQ.333) THEN
KFV1=3
WTV1=1.0D0
KFV2=1
WTV2=0.0D0
ELSEIF(MINT(105).EQ.443) THEN
KFV1=4
WTV1=1.0D0
KFV2=1
WTV2=0.0D0
ENDIF
C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
MINT30=MINT(30)
CALL PYPDFU(KFC,X,Q2,XPA)
Q2MN=MAX(3D0,VINT(231))
Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
C...Large Q2 and large x: naive call is enough.
IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
DO 110 KFL=-25,25
XPQ(KFL)=XPA(KFL)
110 CONTINUE
MINT(92)=1
C...Small Q2 and large x: dampen boundary value.
ELSEIF(X.GT.XMN) THEN
C...Evaluate at boundary and define dampening factors.
MINT(30)=MINT30
CALL PYPDFU(KFC,X,Q2MN,XPA)
FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
C...Separate valence and sea parts of parton distribution.
IF(KFA.NE.22) THEN
XFV1=XPA(KFV1)-XPA(-KFV1)
XPA(KFV1)=XPA(-KFV1)
XFV2=XPA(KFV2)-XPA(-KFV2)
XPA(KFV2)=XPA(-KFV2)
ELSE
XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
ENDIF
C...Dampen valence and sea separately. Put back together.
DO 120 KFL=-25,25
XPQ(KFL)=FS*XPA(KFL)
120 CONTINUE
IF(KFA.NE.22) THEN
XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
ELSE
XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
ENDIF
MINT(92)=2
C...Large Q2 and small x: interpolate behaviour.
ELSEIF(Q2.GT.Q2MN) THEN
C...Evaluate at extremes and define coefficients for interpolation.
MINT(30)=MINT30
CALL PYPDFU(KFC,XMN,Q2MN,XPA)
VI232A=VINT(232)
MINT(30)=MINT30
CALL PYPDFU(KFC,X,Q2B,XPB)
VI232B=VINT(232)
FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
FVA=(X/XMN)**0.45D0*FLA
FSA=(X/XMN)**(-0.08D0)*FLA
FB=1D0-FLA
C...Separate valence and sea parts of parton distribution.
IF(KFA.NE.22) THEN
XFVA1=XPA(KFV1)-XPA(-KFV1)
XPA(KFV1)=XPA(-KFV1)
XFVA2=XPA(KFV2)-XPA(-KFV2)
XPA(KFV2)=XPA(-KFV2)
XFVB1=XPB(KFV1)-XPB(-KFV1)
XPB(KFV1)=XPB(-KFV1)
XFVB2=XPB(KFV2)-XPB(-KFV2)
XPB(KFV2)=XPB(-KFV2)
ELSE
XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
ENDIF
C...Interpolate for valence and sea. Put back together.
DO 130 KFL=-25,25
XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
130 CONTINUE
IF(KFA.NE.22) THEN
XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
ELSE
XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
ENDIF
MINT(92)=3
C...Small Q2 and small x: dampen boundary value and add term.
ELSE
C...Evaluate at boundary and define dampening factors.
MINT(30)=MINT30
CALL PYPDFU(KFC,XMN,Q2MN,XPA)
FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
FA=1D0-FB
FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
C...Separate valence and sea parts of parton distribution.
IF(KFA.NE.22) THEN
XFV1=XPA(KFV1)-XPA(-KFV1)
XPA(KFV1)=XPA(-KFV1)
XFV2=XPA(KFV2)-XPA(-KFV2)
XPA(KFV2)=XPA(-KFV2)
ELSE
XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
ENDIF
C...Dampen valence and sea separately. Add constant terms.
C...Put back together.
DO 140 KFL=-25,25
XPQ(KFL)=FSA*XPA(KFL)
140 CONTINUE
IF(KFA.NE.22) THEN
DO 150 KFL=-3,3
XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
150 CONTINUE
XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
ELSE
DO 160 KFL=-3,3
XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
160 CONTINUE
XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
ENDIF
XPQ(21)=XPQ(0)
MINT(92)=4
ENDIF
C...Format for error printout.
5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
RETURN
END
C*********************************************************************
C...PYPDEL
C...Gives electron (or muon, or tau) parton distribution.
SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
C...Interface to PDFLIB.
COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
SAVE /W50513/
DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
&VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
CHARACTER*20 PARM(20)
DATA VALUE/20*0D0/,PARM/20*' '/
C...Some common constants.
DO 100 KFL=-25,25
XPEL(KFL)=0D0
100 CONTINUE
AEM=PARU(101)
PME=PMAS(11,1)
IF(KFA.EQ.13) PME=PMAS(13,1)
IF(KFA.EQ.15) PME=PMAS(15,1)
XL=LOG(MAX(1D-10,X))
X1L=LOG(MAX(1D-10,1D0-X))
HLE=LOG(MAX(3D0,Q2/PME**2))
HBE2=(AEM/PARU(1))*(HLE-1D0)
C...Electron inside electron, see R. Kleiss et al., in Z physics at
C...LEP 1, CERN 89-08, p. 34
IF(MSTP(59).LE.1) THEN
HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
& (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
& 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
& 4D0*XL/(1D0-X)-5D0-X)
ELSE
HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
& PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
& (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
ENDIF
C...Zero distribution for very large x and rescale it for intermediate.
IF(X.GT.1D0-1D-10) THEN
HEE=0D0
ELSEIF(X.GT.1D0-1D-7) THEN
HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
ENDIF
XPEL(KFA)=X*HEE
C...Photon and (transverse) W- inside electron.
AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
IF(MSTP(13).LE.1) THEN
HLG=HLE
ELSE
HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
ENDIF
XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
C...Electron or positron inside photon inside electron.
IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
& 2D0*X*(1D0+X)*XL)
XPEL(11)=XPEL(11)+XFSEA
XPEL(-11)=XFSEA
C...Initialize PDFLIB photon parton distributions.
IF(MSTP(56).EQ.2) THEN
PARM(1)='NPTYPE'
VALUE(1)=3
PARM(2)='NGROUP'
VALUE(2)=MSTP(55)/1000
PARM(3)='NSET'
VALUE(3)=MOD(MSTP(55),1000)
IF(MINT(93).NE.3000000+MSTP(55)) THEN
CALL PDFSET(PARM,VALUE)
MINT(93)=3000000+MSTP(55)
ENDIF
ENDIF
C...Quarks and gluons inside photon inside electron:
C...numerical convolution required.
DO 110 KFL=0,6
SXP(KFL)=0D0
110 CONTINUE
SUMXPP=0D0
ITER=-1
120 ITER=ITER+1
SUMXP=SUMXPP
NSTP=2**(ITER-1)
IF(ITER.EQ.0) NSTP=2
DO 130 KFL=0,6
SXP(KFL)=0.5D0*SXP(KFL)
130 CONTINUE
WTSTP=0.5D0/NSTP
IF(ITER.EQ.0) WTSTP=0.5D0
C...Pick grid of x_{gamma} values logarithmically even.
DO 150 ISTP=1,NSTP
IF(ITER.EQ.0) THEN
XLE=XL*(ISTP-1)
ELSE
XLE=XL*(ISTP-0.5D0)/NSTP
ENDIF
XE=MIN(1D0-1D-10,EXP(XLE))
XG=MIN(1D0-1D-10,X/XE)
C...Evaluate photon inside electron parton distribution for convolution.
XPGP=1D0+(1D0-XE)**2
IF(MSTP(13).LE.1) THEN
XPGP=XPGP*HLE
ELSE
XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
ENDIF
C...Evaluate photon parton distributions for convolution.
IF(MSTP(56).EQ.1) THEN
IF(MSTP(55).EQ.1) THEN
CALL PYPDGA(XG,Q2,XPGA)
ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
Q2MX=Q2
P2MX=0.36D0
IF(MSTP(55).GE.7) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
VINT(231)=P2MX
ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
Q2MX=Q2
P2MX=0.36D0
IF(MSTP(55).GE.11) P2MX=4.0D0
IF(MSTP(57).EQ.0) Q2MX=P2MX
P2=0D0
IF(VINT(120).LT.0D0) P2=VINT(120)**2
CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
VINT(231)=P2MX
ENDIF
DO 140 KFL=0,5
SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
140 CONTINUE
ELSEIF(MSTP(56).EQ.2) THEN
C...Call PDFLIB parton distributions.
XX=XG
QQ=SQRT(MAX(0D0,Q2MIN,Q2))
IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
SXP(0)=SXP(0)+WTSTP*XPGP*GLU
SXP(1)=SXP(1)+WTSTP*XPGP*DNV
SXP(2)=SXP(2)+WTSTP*XPGP*UPV
SXP(3)=SXP(3)+WTSTP*XPGP*STR
SXP(4)=SXP(4)+WTSTP*XPGP*CHM
SXP(5)=SXP(5)+WTSTP*XPGP*BOT
SXP(6)=SXP(6)+WTSTP*XPGP*TOP
ENDIF
150 CONTINUE
SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
& PARP(14)*(SUMXPP+SUMXP))) GOTO 120
C...Put convolution into output arrays.
FCONV=AEMP*(-XL)
XPEL(0)=FCONV*SXP(0)
DO 160 KFL=1,6
XPEL(KFL)=FCONV*SXP(KFL)
XPEL(-KFL)=XPEL(KFL)
160 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYPDGA
C...Gives photon parton distribution.
SUBROUTINE PYPDGA(X,Q2,XPGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
&DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
&DGCS(4,3),DGDS(4,3),DGES(4,3)
C...The following data lines are coefficients needed in the
C...Drees and Grassie photon parton distribution parametrization.
DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
&.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
&-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
&6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
&4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
&1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
&.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
&2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
&2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
&1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
&-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
&.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
&.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
&-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
C...Photon parton distribution from Drees and Grassie.
C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
DO 100 KFL=-6,6
XPGA(KFL)=0D0
100 CONTINUE
VINT(231)=1D0
IF(MSTP(57).LE.0) THEN
T=LOG(1D0/0.16D0)
ELSE
T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
ENDIF
X1=1D0-X
NF=3
IF(Q2.GT.25D0) NF=4
IF(Q2.GT.300D0) NF=5
NFE=NF-2
AEM=PARU(101)
C...Evaluate gluon content.
DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
XPGL=DGA*X**DGB*X1**DGC
C...Evaluate up- and down-type quark content.
DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
DGF=9D0
IF(NF.EQ.4) DGF=10D0
IF(NF.EQ.5) DGF=55D0/6D0
XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
IF(NF.LE.3) THEN
XPQU=(XPQS+9D0*XPQN)/6D0
XPQD=(XPQS-4.5D0*XPQN)/6D0
ELSEIF(NF.EQ.4) THEN
XPQU=(XPQS+6D0*XPQN)/8D0
XPQD=(XPQS-6D0*XPQN)/8D0
ELSE
XPQU=(XPQS+7.5D0*XPQN)/10D0
XPQD=(XPQS-5D0*XPQN)/10D0
ENDIF
C...Put into output arrays.
XPGA(0)=AEM*XPGL
XPGA(1)=AEM*XPQD
XPGA(2)=AEM*XPQU
XPGA(3)=AEM*XPQD
IF(NF.GE.4) XPGA(4)=AEM*XPQU
IF(NF.GE.5) XPGA(5)=AEM*XPQD
DO 110 KFL=1,6
XPGA(-KFL)=XPGA(KFL)
110 CONTINUE
RETURN
END
C*********************************************************************
C...PYGGAM
C...Constructs the F2 and parton distributions of the photon
C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
C...For F2, c and b are included by the Bethe-Heitler formula;
C...in the 'MSbar' scheme additionally a Cgamma term is added.
C...Contains the SaS sets 1D, 1M, 2D and 2M.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
&XPDIR(-6:6)
COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
SAVE /PYINT8/,/PYINT9/
C...Local arrays.
DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
C...Charm and bottom masses (low to compensate for J/psi etc.).
DATA PMC/1.3D0/, PMB/4.6D0/
C...alpha_em and alpha_em/(2*pi).
DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
C...Lambda value for 4 flavours.
DATA ALAM/0.20D0/
C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
DATA FRACU/0.8D0/
C...VMD couplings f_V**2/(4*pi).
DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
C...Masses for rho (=omega) and phi.
DATA PMRHO/0.770D0/, PMPHI/1.020D0/
C...Number of points in integration for IP2=1.
DATA NSTEP/100/
C...Reset output.
F2GM=0D0
DO 100 KFL=-6,6
XPDFGM(KFL)=0D0
XPVMD(KFL)=0D0
XPANL(KFL)=0D0
XPANH(KFL)=0D0
XPBEH(KFL)=0D0
XPDIR(KFL)=0D0
VXPVMD(KFL)=0D0
VXPANL(KFL)=0D0
VXPANH(KFL)=0D0
VXPDGM(KFL)=0D0
100 CONTINUE
C...Set Q0 cut-off parameter as function of set used.
IF(ISET.LE.2) THEN
Q0=0.6D0
ELSE
Q0=2D0
ENDIF
Q02=Q0**2
C...Scale choice for off-shell photon; common factors.
Q2A=Q2
FACNOR=1D0
IF(IP2.EQ.1) THEN
P2MX=P2+Q02
Q2A=Q2+P2*Q02/MAX(Q02,Q2)
FACNOR=LOG(Q2/Q02)/NSTEP
ELSEIF(IP2.EQ.2) THEN
P2MX=MAX(P2,Q02)
ELSEIF(IP2.EQ.3) THEN
P2MX=P2+Q02
Q2A=Q2+P2*Q02/MAX(Q02,Q2)
ELSEIF(IP2.EQ.4) THEN
P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
& ((Q2+P2)*(Q02+P2)))
ELSEIF(IP2.EQ.5) THEN
P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
& ((Q2+P2)*(Q02+P2)))
P2MX=Q0*SQRT(P2MXA)
FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
ELSEIF(IP2.EQ.6) THEN
P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
& ((Q2+P2)*(Q02+P2)))
P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
ELSE
P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
& ((Q2+P2)*(Q02+P2)))
P2MX=Q0*SQRT(P2MXA)
P2MXB=P2MX
P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
IF(ABS(Q2-Q02).GT.1D-6) THEN
FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
ELSEIF(P2.LT.Q02) THEN
FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
ELSE
FACNOR=1D0
ENDIF
ENDIF
C...Call VMD parametrization for d quark and use to give rho, omega,
C...phi. Note dipole dampening for off-shell photon.
CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
XFVAL=VXPGA(1)
XPGA(1)=XPGA(2)
XPGA(-1)=XPGA(-2)
FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
DO 110 KFL=-5,5
XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
110 CONTINUE
XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
XPVMD(3)=XPVMD(3)+FACS*XFVAL
XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
VXPVMD(2)=FRACU*FACUD*XFVAL
VXPVMD(3)=FACS*XFVAL
VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
VXPVMD(-2)=FRACU*FACUD*XFVAL
VXPVMD(-3)=FACS*XFVAL
IF(IP2.NE.1) THEN
C...Anomalous parametrizations for different strategies
C...for off-shell photons; except full integration.
C...Call anomalous parametrization for d + u + s.
CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
DO 120 KFL=-5,5
XPANL(KFL)=FACNOR*XPGA(KFL)
VXPANL(KFL)=FACNOR*VXPGA(KFL)
120 CONTINUE
C...Call anomalous parametrization for c and b.
CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
DO 130 KFL=-5,5
XPANH(KFL)=FACNOR*XPGA(KFL)
VXPANH(KFL)=FACNOR*VXPGA(KFL)
130 CONTINUE
CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
DO 140 KFL=-5,5
XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
140 CONTINUE
ELSE
C...Special option: loop over flavours and integrate over k2.
DO 170 KF=1,5
DO 160 ISTEP=1,NSTEP
Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
& (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
DO 150 KFL=-5,5
IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
150 CONTINUE
160 CONTINUE
170 CONTINUE
ENDIF
C...Call Bethe-Heitler term expression for charm and bottom.
CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
XPBEH(4)=XPBH
XPBEH(-4)=XPBH
CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
XPBEH(5)=XPBH
XPBEH(-5)=XPBH
C...For MSbar subtraction call C^gamma term expression for d, u, s.
IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
CALL PYGDIR(X,Q2,P2,Q02,XPGA)
DO 180 KFL=-5,5
XPDIR(KFL)=XPGA(KFL)
180 CONTINUE
ENDIF
C...Store result in output array.
DO 190 KFL=-5,5
CHSQ=1D0/9D0
IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
190 CONTINUE
RETURN
END
C*********************************************************************
C...PYGVMD
C...Evaluates the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local arrays and data.
DIMENSION XPGA(-6:6), VXPGA(-6:6)
DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
C...Reset output.
DO 100 KFL=-6,6
XPGA(KFL)=0D0
VXPGA(KFL)=0D0
100 CONTINUE
KFA=IABS(KF)
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
P2EFF=MAX(P2,1.2D0*ALAM3**2)
IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
Q2EFF=MAX(Q2,P2EFF)
C...Find number of flavours at lower and upper scale.
NFP=4
IF(P2EFF.LT.PMC**2) NFP=3
IF(P2EFF.GT.PMB**2) NFP=5
NFQ=4
IF(Q2EFF.LT.PMC**2) NFQ=3
IF(Q2EFF.GT.PMB**2) NFQ=5
C...Find s as sum of 3-, 4- and 5-flavour parts.
S=0D0
IF(NFP.EQ.3) THEN
Q2DIV=PMC**2
IF(NFQ.EQ.3) Q2DIV=Q2EFF
S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
ENDIF
IF(NFP.LE.4.AND.NFQ.GE.4) THEN
P2DIV=P2EFF
IF(NFP.EQ.3) P2DIV=PMC**2
Q2DIV=Q2EFF
IF(NFQ.EQ.5) Q2DIV=PMB**2
S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
ENDIF
IF(NFQ.EQ.5) THEN
P2DIV=PMB**2
IF(NFP.EQ.5) P2DIV=P2EFF
S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
ENDIF
C...Calculate frequent combinations of x and s.
X1=1D0-X
XL=-LOG(X)
S2=S**2
S3=S**3
S4=S**4
C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
IF(ISET.EQ.0) THEN
IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
& (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
XVAL = X * 1.5D0 * (X**2+X1**2)
XGLU = 0D0
XSEA = 0D0
ELSE
XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
& (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
& 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
& X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
& X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
& ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
& X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
& ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
& (2D0*X-1D0)*X*XL**2)
ENDIF
C...Evaluate set 1D parton distributions below or above threshold.
ELSEIF(ISET.EQ.1) THEN
IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
& (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
XSEA = 0.100D0 * X1**3.76D0
ELSE
XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
& X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
& X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
& XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
& X**0.40D0 * X1**(1.76D0+3D0*S)
XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
& (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
& X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
XSEA0 = 0.100D0 * X1**3.76D0
ENDIF
C...Evaluate set 1M parton distributions below or above threshold.
ELSEIF(ISET.EQ.2) THEN
IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
& (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
XSEA = 0D0
ELSE
XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
& X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
& EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
& X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
& EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
& X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
& XL**(2.8D0*S)
XSEA0 = 0D0
ENDIF
C...Evaluate set 2D parton distributions below or above threshold.
ELSEIF(ISET.EQ.3) THEN
IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
& (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
XGLU = 1.925D0 * X1**2
XSEA = 0.242D0 * X1**4
ELSE
XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
& X**(0.46D0+0.25D0*S) *
& X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
& (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
& EXP(-18.67D0*S) *
& X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
& * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
& XL**(9.3D0*S/(1D0+1.7D0*S))
XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
& (1D0-0.607D0*S+21.95D0*S2) *
& X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
XSEA0 = 0.242D0 * X1**4
ENDIF
C...Evaluate set 2M parton distributions below or above threshold.
ELSEIF(ISET.EQ.4) THEN
IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
& (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
XGLU = 1.808D0 * X1**2
XSEA = 0.209D0 * X1**4
ELSE
XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
& X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
& X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
& XL**(5.15D0*S/(1D0+2D0*S)) +
& (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
& X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
& X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
& XL**(10.9D0*S/(1D0+2.5D0*S))
XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
& X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
& X1**(4D0+S) * XL**(0.45D0*S)
XSEA0 = 0.209D0 * X1**4
ENDIF
ENDIF
C...Threshold factors for c and b sea.
SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
XCHM=0D0
IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
IF(ISET.EQ.0) THEN
XCHM=XSEA*(1D0-(SCH/SLL)**2)
ELSE
XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
ENDIF
ENDIF
XBOT=0D0
IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
IF(ISET.EQ.0) THEN
XBOT=XSEA*(1D0-(SBT/SLL)**2)
ELSE
XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
ENDIF
ENDIF
C...Fill parton distributions.
XPGA(0)=XGLU
XPGA(1)=XSEA
XPGA(2)=XSEA
XPGA(3)=XSEA
XPGA(4)=XCHM
XPGA(5)=XBOT
XPGA(KFA)=XPGA(KFA)+XVAL
DO 110 KFL=1,5
XPGA(-KFL)=XPGA(KFL)
110 CONTINUE
VXPGA(KFA)=XVAL
VXPGA(-KFA)=XVAL
RETURN
END
C*********************************************************************
C...PYGANO
C...Evaluates the parton distributions of the anomalous photon,
C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
C...KF=0 gives the sum over (up to) 5 flavours,
C...KF<0 limits to flavours up to abs(KF),
C...KF>0 is for flavour KF only.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local arrays and data.
DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
C...Reset output.
DO 100 KFL=-6,6
XPGA(KFL)=0D0
VXPGA(KFL)=0D0
100 CONTINUE
IF(Q2.LE.P2) RETURN
KFA=IABS(KF)
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
ALAMSQ(4)=ALAM**2
ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
Q2EFF=MAX(Q2,P2EFF)
XL=-LOG(X)
C...Find number of flavours at lower and upper scale.
NFP=4
IF(P2EFF.LT.PMC**2) NFP=3
IF(P2EFF.GT.PMB**2) NFP=5
NFQ=4
IF(Q2EFF.LT.PMC**2) NFQ=3
IF(Q2EFF.GT.PMB**2) NFQ=5
C...Define range of flavour loop.
IF(KF.EQ.0) THEN
KFLMN=1
KFLMX=5
ELSEIF(KF.LT.0) THEN
KFLMN=1
KFLMX=KFA
ELSE
KFLMN=KFA
KFLMX=KFA
ENDIF
C...Loop over flavours the photon can branch into.
DO 110 KFL=KFLMN,KFLMX
C...Light flavours: calculate t range and (approximate) s range.
IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
TDIFF=LOG(Q2EFF/P2EFF)
S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
& LOG(P2EFF/ALAMSQ(NFQ)))
IF(NFQ.GT.NFP) THEN
Q2DIV=PMB**2
IF(NFQ.EQ.4) Q2DIV=PMC**2
SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
& LOG(P2EFF/ALAMSQ(NFQ)))
SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
& LOG(P2EFF/ALAMSQ(NFQ-1)))
S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
ENDIF
IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
Q2DIV=PMC**2
SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
& LOG(P2EFF/ALAMSQ(4)))
SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
& LOG(P2EFF/ALAMSQ(3)))
S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
ENDIF
C...u and s quark do not need a separate treatment when d has been done.
ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
C...Charm: as above, but only include range above c threshold.
ELSEIF(KFL.EQ.4) THEN
IF(Q2.LE.PMC**2) GOTO 110
P2EFF=MAX(P2EFF,PMC**2)
Q2EFF=MAX(Q2EFF,P2EFF)
TDIFF=LOG(Q2EFF/P2EFF)
S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
& LOG(P2EFF/ALAMSQ(NFQ)))
IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
Q2DIV=PMB**2
SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
& LOG(P2EFF/ALAMSQ(NFQ)))
SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
& LOG(P2EFF/ALAMSQ(NFQ-1)))
S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
ENDIF
C...Bottom: as above, but only include range above b threshold.
ELSEIF(KFL.EQ.5) THEN
IF(Q2.LE.PMB**2) GOTO 110
P2EFF=MAX(P2EFF,PMB**2)
Q2EFF=MAX(Q2,P2EFF)
TDIFF=LOG(Q2EFF/P2EFF)
S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
& LOG(P2EFF/ALAMSQ(NFQ)))
ENDIF
C...Evaluate flavour-dependent prefactor (charge^2 etc.).
CHSQ=1D0/9D0
IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
FAC=AEM2PI*2D0*CHSQ*TDIFF
C...Evaluate parton distributions (normalized to unit momentum sum).
IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
& (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
& 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
& X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
& X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
& ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
& X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
& ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
& (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
C...Threshold factors for c and b sea.
SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
XCHM=0D0
IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
XCHM=XSEA*(1D0-(SCH/SLL)**3)
ENDIF
XBOT=0D0
IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
XBOT=XSEA*(1D0-(SBT/SLL)**3)
ENDIF
ENDIF
C...Add contribution of each valence flavour.
XPGA(0)=XPGA(0)+FAC*XGLU
XPGA(1)=XPGA(1)+FAC*XSEA
XPGA(2)=XPGA(2)+FAC*XSEA
XPGA(3)=XPGA(3)+FAC*XSEA
XPGA(4)=XPGA(4)+FAC*XCHM
XPGA(5)=XPGA(5)+FAC*XBOT
XPGA(KFL)=XPGA(KFL)+FAC*XVAL
VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
110 CONTINUE
DO 120 KFL=1,5
XPGA(-KFL)=XPGA(KFL)
VXPGA(-KFL)=VXPGA(KFL)
120 CONTINUE
RETURN
END
C*********************************************************************
C...PYGBEH
C...Evaluates the Bethe-Heitler cross section for heavy flavour
C...production.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local data.
DATA AEM2PI/0.0011614D0/
C...Reset output.
XPBH=0D0
SIGBH=0D0
C...Check kinematics limits.
IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
W2=Q2*(1D0-X)/X-P2
BETA2=1D0-4D0*PM2/W2
IF(BETA2.LT.1D-10) RETURN
BETA=SQRT(BETA2)
RMQ=4D0*PM2/Q2
C...Simple case: P2 = 0.
IF(P2.LT.1D-4) THEN
IF(BETA.LT.0.99D0) THEN
XBL=LOG((1D0+BETA)/(1D0-BETA))
ELSE
XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
ENDIF
SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
& XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
ELSE
RPQ=1D0-4D0*X**2*P2/Q2
IF(RPQ.GT.1D-10) THEN
RPBE=SQRT(RPQ*BETA2)
IF(RPBE.LT.0.99D0) THEN
XBL=LOG((1D0+RPBE)/(1D0-RPBE))
XBI=2D0*RPBE/(1D0-RPBE**2)
ELSE
RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
XBL=LOG((1D0+RPBE)**2/RPBESN)
XBI=2D0*RPBE/RPBESN
ENDIF
SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
& XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
& XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
ENDIF
ENDIF
C...Multiply by charge-squared etc. to get parton distribution.
CHSQ=1D0/9D0
IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
RETURN
END
C*********************************************************************
C...PYGDIR
C...Evaluates the direct contribution, i.e. the C^gamma term,
C...as needed in MSbar parametrizations.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local array and data.
DIMENSION XPGA(-6:6)
DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
C...Reset output.
DO 100 KFL=-6,6
XPGA(KFL)=0D0
100 CONTINUE
C...Evaluate common x-dependent expression.
XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
C...d, u, s part by simple charge factor.
XPGA(1)=(1D0/9D0)*CGAM
XPGA(2)=(4D0/9D0)*CGAM
XPGA(3)=(1D0/9D0)*CGAM
C...Also fill for antiquarks.
DO 110 KF=1,5
XPGA(-KF)=XPGA(KF)
110 CONTINUE
RETURN
END
C*********************************************************************
C...PYPDPI
C...Gives pi+ parton distribution according to two different
C...parametrizations.
SUBROUTINE PYPDPI(X,Q2,XPPI)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
C...The following data lines are coefficients needed in the
C...Owens pion parton distribution parametrizations, see below.
C...Expansion coefficients for up and down valence quark distributions.
DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
&4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
&-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
&-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
&4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
&-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
&-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
C...Expansion coefficients for gluon distribution.
DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
&8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
&-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
&1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
&7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
&-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
&5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
C...Expansion coefficients for (up+down+strange) quark sea distribution.
DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
&9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
&-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
&1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
&9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
&-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
&-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
C...Expansion coefficients for charm quark sea distribution.
DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
&0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
&7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
&-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
&0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
&6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
&-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
C...Euler's beta function, requires ordinary Gamma function
EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
C...Reset output array.
DO 100 KFL=-6,6
XPPI(KFL)=0D0
100 CONTINUE
IF(MSTP(53).LE.2) THEN
C...Pion parton distributions from Owens.
C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
C...Determine set, Lambda and s expansion variable.
NSET=MSTP(53)
IF(NSET.EQ.1) ALAM=0.2D0
IF(NSET.EQ.2) ALAM=0.4D0
VINT(231)=4D0
IF(MSTP(57).LE.0) THEN
SD=0D0
ELSE
Q2IN=MIN(2D3,MAX(4D0,Q2))
SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
ENDIF
C...Calculate parton distributions.
DO 120 KFL=1,4
DO 110 IS=1,5
TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
& COW(3,IS,KFL,NSET)*SD**2
110 CONTINUE
IF(KFL.EQ.1) THEN
XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
ELSE
XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
& TS(5)*X**2)
ENDIF
120 CONTINUE
C...Put into output array.
XPPI(0)=XQ(2)
XPPI(1)=XQ(3)/6D0
XPPI(2)=XQ(1)+XQ(3)/6D0
XPPI(3)=XQ(3)/6D0
XPPI(4)=XQ(4)
XPPI(-1)=XQ(1)+XQ(3)/6D0
XPPI(-2)=XQ(3)/6D0
XPPI(-3)=XQ(3)/6D0
XPPI(-4)=XQ(4)
C...Leading order pion parton distributions from Glueck, Reya and Vogt.
C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
C...10^-5 < x < 1.
ELSE
C...Determine s expansion variable and some x expressions.
VINT(231)=0.25D0
IF(MSTP(57).LE.0) THEN
SD=0D0
ELSE
Q2IN=MIN(1D8,MAX(0.25D0,Q2))
SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
ENDIF
SD2=SD**2
XL=-LOG(X)
XS=SQRT(X)
C...Evaluate valence, gluon and sea distributions.
XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
& (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
& SD-0.175D0*SD2)+
& (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
& SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
& XL)))*
& (1D0-X)**(0.390D0+1.053D0*SD)
XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
& X)**3.359D0*
& EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
& XL))/
& XL**(2.538D0-0.763D0*SD)
IF(SD.LE.0.888D0) THEN
XFCHM=0D0
ELSE
XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
& 0.771D0*SD)*
& EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
& XL))
ENDIF
IF(SD.LE.1.351D0) THEN
XFBOT=0D0
ELSE
XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
& EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
& XL))
ENDIF
C...Put into output array.
XPPI(0)=XFGLU
XPPI(1)=XFSEA
XPPI(2)=XFSEA
XPPI(3)=XFSEA
XPPI(4)=XFCHM
XPPI(5)=XFBOT
DO 130 KFL=1,5
XPPI(-KFL)=XPPI(KFL)
130 CONTINUE
XPPI(2)=XPPI(2)+XFVAL
XPPI(-1)=XPPI(-1)+XFVAL
ENDIF
RETURN
END
C*********************************************************************
C...PYPDPR
C...Gives proton parton distributions according to a few different
C...parametrizations.
SUBROUTINE PYPDPR(X,Q2,XPPR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Arrays and data.
DIMENSION XPPR(-6:6),Q2MIN(16)
DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
&1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
C...Reset output array.
DO 100 KFL=-6,6
XPPR(KFL)=0D0
100 CONTINUE
C...Common preliminaries.
NSET=MAX(1,MIN(16,MSTP(51)))
IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
VINT(231)=Q2MIN(NSET)
IF(MSTP(57).EQ.0) THEN
Q2L=Q2MIN(NSET)
ELSE
Q2L=MAX(Q2MIN(NSET),Q2)
ENDIF
IF(NSET.GE.1.AND.NSET.LE.3) THEN
C...Interface to the CTEQ 3 parton distributions.
QRT=SQRT(MAX(1D0,Q2L))
C...Loop over flavours.
DO 110 I=-6,6
IF(I.LE.0) THEN
XPPR(I)=PYCTEQ(NSET,I,X,QRT)
ELSEIF(I.LE.2) THEN
XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
ELSE
XPPR(I)=XPPR(-I)
ENDIF
110 CONTINUE
ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
C...Interface to the GRV 94 distributions.
IF(NSET.EQ.4) THEN
CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
ELSEIF(NSET.EQ.5) THEN
CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
ELSE
CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
ENDIF
C...Put into output array.
XPPR(0)=GL
XPPR(-1)=0.5D0*(UDB+DEL)
XPPR(-2)=0.5D0*(UDB-DEL)
XPPR(-3)=SB
XPPR(-4)=CHM
XPPR(-5)=BOT
XPPR(1)=DV+XPPR(-1)
XPPR(2)=UV+XPPR(-2)
XPPR(3)=SB
XPPR(4)=CHM
XPPR(5)=BOT
ELSEIF(NSET.EQ.7) THEN
C...Interface to the CTEQ 5L parton distributions.
C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
C...freezing x*f(x,Q2) at borders.
QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
XIN=MAX(1D-6,MIN(1D0,X))
C...Loop over flavours (with u <-> d notation mismatch).
SUMUDB=PYCT5L(-1,XIN,QRT)
RATUDB=PYCT5L(-2,XIN,QRT)
DO 120 I=-5,2
IF(I.EQ.1) THEN
XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
ELSEIF(I.EQ.2) THEN
XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
ELSEIF(I.EQ.-1) THEN
XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
ELSEIF(I.EQ.-2) THEN
XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
ELSE
XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
IF(I.LT.0) XPPR(-I)=XPPR(I)
ENDIF
120 CONTINUE
ELSEIF(NSET.EQ.8) THEN
C...Interface to the CTEQ 5M1 parton distributions.
QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
XIN=MAX(1D-6,MIN(1D0,X))
C...Loop over flavours (with u <-> d notation mismatch).
SUMUDB=PYCT5M(-1,XIN,QRT)
RATUDB=PYCT5M(-2,XIN,QRT)
DO 130 I=-5,2
IF(I.EQ.1) THEN
XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
ELSEIF(I.EQ.2) THEN
XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
ELSEIF(I.EQ.-1) THEN
XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
ELSEIF(I.EQ.-2) THEN
XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
ELSE
XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
IF(I.LT.0) XPPR(-I)=XPPR(I)
ENDIF
130 CONTINUE
ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
C...obsolete but offers backwards compatibility.
CALL PYPDPO(X,Q2L,XPPR)
C...Symmetric choice for debugging only
ELSEIF(NSET.EQ.16) THEN
XPPR(0)=.5D0/X
XPPR(1)=.05D0/X
XPPR(2)=.05D0/X
XPPR(3)=.05D0/X
XPPR(4)=.05D0/X
XPPR(5)=.05D0/X
XPPR(-1)=.05D0/X
XPPR(-2)=.05D0/X
XPPR(-3)=.05D0/X
XPPR(-4)=.05D0/X
XPPR(-5)=.05D0/X
ENDIF
RETURN
END
C*********************************************************************
C...PYCTEQ
C...Gives the CTEQ 3 parton distribution function sets in
C...parametrized form, of October 24, 1994.
C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
C...J. Qiu, W.K. Tung and H. Weerts.
FUNCTION PYCTEQ (ISET, IPRT, X, Q)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Data on Lambda values of fits, minimum Q and quark masses.
DIMENSION ALM(3), QMS(4:6)
DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
C....Check flavour thresholds. Set up QI for SB.
IP = IABS(IPRT)
IF(IP .GE. 4) THEN
IF(Q .LE. QMS(IP)) THEN
PYCTEQ = 0D0
RETURN
ENDIF
QI = QMS(IP)
ELSE
QI = QMN
ENDIF
C...Use "standard lambda" of parametrization program for expansion.
ALAM = ALM (ISET)
SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
SB = LOG (SBL)
SB2 = SB*SB
SB3 = SB2*SB
C...Expansion for CTEQ3L.
IF(ISET .EQ. 1) THEN
IF(IPRT .EQ. 2) THEN
A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
& 0.3171D+00*SB3)
A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
ELSEIF(IPRT .EQ. 1) THEN
A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
& 0.7728D+00*SB3)
A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
ELSEIF(IPRT .EQ. 0) THEN
A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
& 0.5343D+00*SB3)
A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
ELSEIF(IPRT .EQ. -1) THEN
A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
& 0.2031D+01*SB3)
A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
ELSEIF(IPRT .EQ. -2) THEN
A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
& 0.9872D-01*SB3)
A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
ELSEIF(IPRT .EQ. -3) THEN
A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
& 0.8390D+00*SB3)
A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
ELSEIF(IPRT .EQ. -4) THEN
A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
& 0.1651D-01*SB2)
A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
ELSEIF(IPRT .EQ. -5) THEN
A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
& 0.3702D+01*SB2)
A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
ELSEIF(IPRT .EQ. -6) THEN
A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
& 0.6943D+00*SB2)
A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
ENDIF
C...Expansion for CTEQ3M.
ELSEIF(ISET .EQ. 2) THEN
IF(IPRT .EQ. 2) THEN
A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
& 0.2935D+00*SB3)
A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
ELSEIF(IPRT .EQ. 1) THEN
A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
& 0.4305D-01*SB3)
A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
ELSEIF(IPRT .EQ. 0) THEN
A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
& 0.1037D-01*SB3)
A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
ELSEIF(IPRT .EQ. -1) THEN
A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
& 0.1602D+01*SB3)
A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
ELSEIF(IPRT .EQ. -2) THEN
A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
& 0.2496D+00*SB3)
A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
ELSEIF(IPRT .EQ. -3) THEN
A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
& 0.1936D+01*SB3)
A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
ELSEIF(IPRT .EQ. -4) THEN
A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
& 0.5348D+00*SB2)
A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
ELSEIF(IPRT .EQ. -5) THEN
A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
& 0.1569D+01*SB2)
A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
ELSEIF(IPRT .EQ. -6) THEN
A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
& 0.8838D+01*SB2)
A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
ENDIF
C...Expansion for CTEQ3D.
ELSEIF(ISET .EQ. 3) THEN
IF(IPRT .EQ. 2) THEN
A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
& 0.2902D+00*SB3)
A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
ELSEIF(IPRT .EQ. 1) THEN
A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
& 0.7257D+00*SB3)
A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
ELSEIF(IPRT .EQ. 0) THEN
A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
& 0.2734D-04*SB3)
A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
ELSEIF(IPRT .EQ. -1) THEN
A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
& 0.1671D+01*SB3)
A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
ELSEIF(IPRT .EQ. -2) THEN
A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
& 0.2223D+00*SB3)
A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
ELSEIF(IPRT .EQ. -3) THEN
A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
& 0.1937D+01*SB3)
A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
ELSEIF(IPRT .EQ. -4) THEN
A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
& 0.5137D+00*SB2)
A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
ELSEIF(IPRT .EQ. -5) THEN
A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
& 0.2143D+01*SB2)
A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
ELSEIF(IPRT .EQ. -6) THEN
A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
& 0.9998D+01*SB2)
A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
ENDIF
ENDIF
C...Calculation of x * f(x, Q).
PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
& *(LOG(1D0+1D0/X))**A5 )
RETURN
END
C*********************************************************************
C...PYGRVL
C...Gives the GRV 94 L (leading order) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Common expressions.
MU2 = 0.23D0
LAM2 = 0.2322D0 * 0.2322D0
S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
DS = SQRT (S)
S2 = S * S
S3 = S2 * S
C...uv :
NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
AKU = 0.590D0 - 0.024D0 * S
BKU = 0.131D0 + 0.063D0 * S
AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
C...dv :
ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
AKD = 0.376D0
BKD = 0.486D0 + 0.062D0 * S
AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
C...del :
NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
AKE = 0.409D0 - 0.005D0 * S
BKE = 0.799D0 + 0.071D0 * S
AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
CE = 0.0D0
DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
C...udb :
ALX = 1.451D0
BEX = 0.271D0
AKX = 0.410D0 - 0.232D0 * S
BKX = 0.534D0 - 0.457D0 * S
AGX = 0.890D0 - 0.140D0 * S
BGX = -0.981D0
CX = 0.320D0 + 0.683D0 * S
DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
EX = 4.119D0 + 1.713D0 * S
ESX = 0.682D0 + 2.978D0 * S
UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
& DX, EX, ESX)
C...sb :
STS = 0D0
ALS = 0.914D0
BES = 0.577D0
AKS = 1.798D0 - 0.596D0 * S
AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
EST = 3.981D0 + 1.638D0 * S
ESS = 6.402D0
SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
C...cb :
STC = 0.888D0
ALC = 1.01D0
BEC = 0.37D0
AKC = 0D0
AC = 0D0
BC = 4.24D0 - 0.804D0 * S
DCT = 3.46D0 - 1.076D0 * S
ECT = 4.61D0 + 1.49D0 * S
ESC = 2.555D0 + 1.961D0 * S
CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
C...bb :
STB = 1.351D0
ALB = 1.00D0
BEB = 0.51D0
AKB = 0D0
AB = 0D0
BB = 1.848D0
DBT = 2.929D0 + 1.396D0 * S
EBT = 4.71D0 + 1.514D0 * S
ESB = 4.02D0 + 1.239D0 * S
BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
C...gl :
ALG = 0.524D0
BEG = 1.088D0
AKG = 1.742D0 - 0.930D0 * S
BKG = - 0.399D0 * S2
AG = 7.486D0 - 2.185D0 * S
BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
EG = 0.807D0 + 2.005D0 * S
ESG = 3.841D0 + 0.316D0 * S
GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
& DG, EG, ESG)
RETURN
END
C*********************************************************************
C...PYGRVM
C...Gives the GRV 94 M (MSbar) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Common expressions.
MU2 = 0.34D0
LAM2 = 0.248D0 * 0.248D0
S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
DS = SQRT (S)
S2 = S * S
S3 = S2 * S
C...uv :
NU = 1.304D0 + 0.863D0 * S
AKU = 0.558D0 - 0.020D0 * S
BKU = 0.183D0 * S
AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
C...dv :
ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
AKD = 0.270D0 - 0.019D0 * S
BKD = 0.260D0
AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
C...del :
NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
AKE = 0.409D0 - 0.007D0 * S
BKE = 0.782D0 + 0.082D0 * S
AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
CE = 0.0D0
DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
C...udb :
ALX = 0.877D0
BEX = 0.561D0
AKX = 0.275D0
BKX = 0.0D0
AGX = 0.997D0
BGX = 3.210D0 - 1.866D0 * S
CX = 7.300D0
DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
EX = 3.077D0 + 1.446D0 * S
ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
& DX, EX, ESX)
C...sb :
STS = 0D0
ALS = 0.756D0
BES = 0.216D0
AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
AS = -4.329D0 + 1.131D0 * S
BS = 9.568D0 - 1.744D0 * S
DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
EST = 3.031D0 + 1.639D0 * S
ESS = 5.837D0 + 0.815D0 * S
SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
C...cb :
STC = 0.820D0
ALC = 0.98D0
BEC = 0D0
AKC = -0.625D0 - 0.523D0 * S
AC = 0D0
BC = 1.896D0 + 1.616D0 * S
DCT = 4.12D0 + 0.683D0 * S
ECT = 4.36D0 + 1.328D0 * S
ESC = 0.677D0 + 0.679D0 * S
CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
C...bb :
STB = 1.297D0
ALB = 0.99D0
BEB = 0D0
AKB = - 0.193D0 * S
AB = 0D0
BB = 0D0
DBT = 3.447D0 + 0.927D0 * S
EBT = 4.68D0 + 1.259D0 * S
ESB = 1.892D0 + 2.199D0 * S
BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
C...gl :
ALG = 1.014D0
BEG = 1.738D0
AKG = 1.724D0 + 0.157D0 * S
BKG = 0.800D0 + 1.016D0 * S
AG = 7.517D0 - 2.547D0 * S
BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
CG = 4.039D0 + 1.491D0 * S
DG = 3.404D0 + 0.830D0 * S
EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
ESG = 3.256D0 - 0.436D0 * S
GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
RETURN
END
C*********************************************************************
C...PYGRVD
C...Gives the GRV 94 D (DIS) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Common expressions.
MU2 = 0.34D0
LAM2 = 0.248D0 * 0.248D0
S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
DS = SQRT (S)
S2 = S * S
S3 = S2 * S
C...uv :
NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
AKU = 0.563D0 - 0.025D0 * S
BKU = 0.054D0 + 0.154D0 * S
AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
C...dv :
ND = 0.156D0 - 0.017D0 * S
AKD = 0.299D0 - 0.022D0 * S
BKD = 0.259D0 - 0.015D0 * S
AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
C...del :
NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
AKE = 0.419D0 - 0.013D0 * S
BKE = 1.064D0 - 0.038D0 * S
AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
C...udb :
ALX = 1.215D0
BEX = 0.466D0
AKX = 0.326D0 + 0.150D0 * S
BKX = 0.956D0 + 0.405D0 * S
AGX = 0.272D0
BGX = 3.794D0 - 2.359D0 * DS
CX = 2.014D0
DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
EX = 3.049D0 + 1.597D0 * S
ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
& DX, EX, ESX)
C...sb :
STS = 0D0
ALS = 0.175D0
BES = 0.344D0
AKS = 1.415D0 - 0.641D0 * DS
AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
EST = 4.546D0 + 0.372D0 * S2
ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
C...cb :
STC = 0.820D0
ALC = 0.98D0
BEC = 0D0
AKC = -0.625D0 - 0.523D0 * S
AC = 0D0
BC = 1.896D0 + 1.616D0 * S
DCT = 4.12D0 + 0.683D0 * S
ECT = 4.36D0 + 1.328D0 * S
ESC = 0.677D0 + 0.679D0 * S
CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
C...bb :
STB = 1.297D0
ALB = 0.99D0
BEB = 0D0
AKB = - 0.193D0 * S
AB = 0D0
BB = 0D0
DBT = 3.447D0 + 0.927D0 * S
EBT = 4.68D0 + 1.259D0 * S
ESB = 1.892D0 + 2.199D0 * S
BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
C...gl :
ALG = 1.258D0
BEG = 1.846D0
AKG = 2.423D0
BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
AG = 25.09D0 - 7.935D0 * S
BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
CG = 590.3D0 - 173.8D0 * S
DG = 5.196D0 + 1.857D0 * S
EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
ESG = 3.232D0 - 0.542D0 * S
GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
RETURN
END
C*********************************************************************
C...PYGRVV
C...Auxiliary for the GRV 94 parton distribution functions
C...for u and d valence and d-u sea.
C...Authors: M. Glueck, E. Reya and A. Vogt.
FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Evaluation.
DX = SQRT (X)
PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
& (1D0- X)**D
RETURN
END
C*********************************************************************
C...PYGRVW
C...Auxiliary for the GRV 94 parton distribution functions
C...for d+u sea and gluon.
C...Authors: M. Glueck, E. Reya and A. Vogt.
FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Evaluation.
LX = LOG (1D0/X)
PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
& * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
RETURN
END
C*********************************************************************
C...PYGRVS
C...Auxiliary for the GRV 94 parton distribution functions
C...for s, c and b sea.
C...Authors: M. Glueck, E. Reya and A. Vogt.
FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION (A - Z)
C...Evaluation.
IF(S.LE.STH) THEN
PYGRVS = 0D0
ELSE
DX = SQRT (X)
LX = LOG (1D0/X)
PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
& (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
ENDIF
RETURN
END
C*********************************************************************
C...PYCT5L
C...Auxiliary function for parametrization of CTEQ5L.
C...Author: J. Pumplin 9/99.
C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
C...in Parametrized Form
C... September 15, 1999
C
C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
C... CTEQ5 PPARTON DISTRIBUTIONS"
C...hep-ph/9903282
C...The CTEQ5M1 set given here is an updated version of the original
C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
C...almost all applications.
C...The improvement is in the QCD evolution which is now more
C...accurate, and which agrees completely with the benchmark work
C...of the HERA 96/97 Workshop.
C...The differences between the parametrized and the corresponding
C...table versions (on which it is based) are of similar order as
C...between the two version.
C...!! Because accurate parametrizations over a wide range of (x,Q)
C...is hard to obtain, only the most widely used sets CTEQ5M and
C...CTEQ5L are available in parametrized form for now.
C...These parametrizations were obtained by Jon Pumplin.
C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
C -------------------------------------------------------------------
C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
C 3 CTEQ5L Leading Order 0.127 192 146
C -------------------------------------------------------------------
C...Note the Qcd-lambda values given for CTEQ5L is for the leading
C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
C...calibration.
C...The two Iset value are adopted to agree with the standard table
C...versions.
C...Range of validity:
C...The range of (x, Q) covered by this parametrization of the QCD
C...evolved parton distributions is 1E-6 < x < 1 ;
C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
C...data only in a subset of that region; and the assumed DGLAP
C...evolution is unlikely to be valid for all of it either.
C...The range of (x, Q) used in the CTEQ5 round of global analysis is
C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
FUNCTION PYCT5L(IFL,X,Q)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
PARAMETER (NEX=8, NLF=2)
DIMENSION AM(0:NEX,0:NLF,-5:2)
DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
DIMENSION AF(0:NEX)
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 /
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 /
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 /
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 /
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 /
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 /
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 /
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 /
IF(Q .LE. QMAVEC(IFL)) THEN
PYCT5L = 0.D0
RETURN
ENDIF
IF(X .GE. 1.D0) THEN
PYCT5L = 0.D0
RETURN
ENDIF
TMP = LOG(Q/ALFVEC(IFL))
IF(TMP .LE. 0.D0) THEN
PYCT5L = 0.D0
RETURN
ENDIF
SB = LOG(TMP)
SB1 = SB - 1.2D0
SB2 = SB1*SB1
DO 110 I = 0, NEX
AF(I) = 0.D0
SBX = 1.D0
DO 100 K = 0, MLFVEC(IFL)
AF(I) = AF(I) + SBX*AM(I,K,IFL)
SBX = SB1*SBX
100 CONTINUE
110 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)
PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
C...Include threshold factor.
PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
RETURN
END
C*********************************************************************
C...PYCT5M
C...Auxiliary function for parametrization of CTEQ5M1.
C...Author: J. Pumplin 9/99.
FUNCTION PYCT5M(IFL,X,Q)
C...Double precision declaration.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
PARAMETER (NEX=8, NLF=2)
DIMENSION AM(0:NEX,0:NLF,-5:2)
DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
DIMENSION AF(0:NEX)
DATA MEXVEC( 2) / 8 /
DATA MLFVEC( 2) / 2 /
DATA UT1VEC( 2) / 0.5141718E+01 /
DATA UT2VEC( 2) / -0.1346944E+01 /
DATA ALFVEC( 2) / 0.5260555E+00 /
DATA QMAVEC( 2) / 0.0000000E+00 /
DATA (AM( 0,K, 2),K=0, 2)
& / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
DATA (AM( 1,K, 2),K=0, 2)
& / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
DATA (AM( 2,K, 2),K=0, 2)
& / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
DATA (AM( 3,K, 2),K=0, 2)
& / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
DATA (AM( 4,K, 2),K=0, 2)
& / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
DATA (AM( 5,K, 2),K=0, 2)
& / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
DATA (AM( 6,K, 2),K=0, 2)
& / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
DATA (AM( 7,K, 2),K=0, 2)
& / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
DATA (AM( 8,K, 2),K=0, 2)
& / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
DATA MEXVEC( 1) / 8 /
DATA MLFVEC( 1) / 2 /
DATA UT1VEC( 1) / 0.4138426E+01 /
DATA UT2VEC( 1) / -0.3221374E+01 /
DATA ALFVEC( 1) / 0.4960962E+00 /
DATA QMAVEC( 1) / 0.0000000E+00 /
DATA (AM( 0,K, 1),K=0, 2)
& / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
DATA (AM( 1,K, 1),K=0, 2)
& / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
DATA (AM( 2,K, 1),K=0, 2)
& / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
DATA (AM( 3,K, 1),K=0, 2)
& / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
DATA (AM( 4,K, 1),K=0, 2)
& / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
DATA (AM( 5,K, 1),K=0, 2)
& / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
DATA (AM( 6,K, 1),K=0, 2)
& / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
DATA (AM( 7,K, 1),K=0, 2)
& / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
DATA (AM( 8,K, 1),K=0, 2)
& / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
DATA MEXVEC( 0) / 8 /
DATA MLFVEC( 0) / 2 /
DATA UT1VEC( 0) / -0.1026789E+01 /
DATA UT2VEC( 0) / -0.9051707E+01 /
DATA ALFVEC( 0) / 0.9462977E+00 /
DATA QMAVEC( 0) / 0.0000000E+00 /
DATA (AM( 0,K, 0),K=0, 2)
& / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
DATA (AM( 1,K, 0),K=0, 2)
& / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
DATA (AM( 2,K, 0),K=0, 2)
& / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
DATA (AM( 3,K, 0),K=0, 2)
& / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
DATA (AM( 4,K, 0),K=0, 2)
& / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
DATA (AM( 5,K, 0),K=0, 2)
& / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
DATA (AM( 6,K, 0),K=0, 2)
& / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
DATA (AM( 7,K, 0),K=0, 2)
& / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
DATA (AM( 8,K, 0),K=0, 2)
& / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
DATA MEXVEC(-1) / 8 /
DATA MLFVEC(-1) / 2 /
DATA UT1VEC(-1) / 0.5243571E+01 /
DATA UT2VEC(-1) / -0.2870513E+01 /
DATA ALFVEC(-1) / 0.6701448E+00 /
DATA QMAVEC(-1) / 0.0000000E+00 /
DATA (AM( 0,K,-1),K=0, 2)
& / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
DATA (AM( 1,K,-1),K=0, 2)
& / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
DATA (AM( 2,K,-1),K=0, 2)
& / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
DATA (AM( 3,K,-1),K=0, 2)
& / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
DATA (AM( 4,K,-1),K=0, 2)
& / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
DATA (AM( 5,K,-1),K=0, 2)
& / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
DATA (AM( 6,K,-1),K=0, 2)
& / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
DATA (AM( 7,K,-1),K=0, 2)
& / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
DATA (AM( 8,K,-1),K=0, 2)
& / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
DATA MEXVEC(-2) / 7 /
DATA MLFVEC(-2) / 2 /
DATA UT1VEC(-2) / 0.4782210E+01 /
DATA UT2VEC(-2) / -0.1976856E+02 /
DATA ALFVEC(-2) / 0.7558374E+00 /
DATA QMAVEC(-2) / 0.0000000E+00 /
DATA (AM( 0,K,-2),K=0, 2)
& / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
DATA (AM( 1,K,-2),K=0, 2)
& / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
DATA (AM( 2,K,-2),K=0, 2)
& / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
DATA (AM( 3,K,-2),K=0, 2)
& / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
DATA (AM( 4,K,-2),K=0, 2)
& / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
DATA (AM( 5,K,-2),K=0, 2)
& / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
DATA (AM( 6,K,-2),K=0, 2)
& / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
DATA (AM( 7,K,-2),K=0, 2)
& / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
DATA MEXVEC(-3) / 7 /
DATA MLFVEC(-3) / 2 /
DATA UT1VEC(-3) / 0.4518239E+01 /
DATA UT2VEC(-3) / -0.2690590E+01 /
DATA ALFVEC(-3) / 0.6124079E+00 /
DATA QMAVEC(-3) / 0.0000000E+00 /
DATA (AM( 0,K,-3),K=0, 2)
& / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
DATA (AM( 1,K,-3),K=0, 2)
& / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
DATA (AM( 2,K,-3),K=0, 2)
& / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
DATA (AM( 3,K,-3),K=0, 2)
& / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
DATA (AM( 4,K,-3),K=0, 2)
& / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
DATA (AM( 5,K,-3),K=0, 2)
& / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
DATA (AM( 6,K,-3),K=0, 2)
& / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
DATA (AM( 7,K,-3),K=0, 2)
& / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
DATA MEXVEC(-4) / 7 /
DATA MLFVEC(-4) / 2 /
DATA UT1VEC(-4) / 0.2783230E+01 /
DATA UT2VEC(-4) / -0.1746328E+01 /
DATA ALFVEC(-4) / 0.1115653E+01 /
DATA QMAVEC(-4) / 0.1300000E+01 /
DATA (AM( 0,K,-4),K=0, 2)
& / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
DATA (AM( 1,K,-4),K=0, 2)
& / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
DATA (AM( 2,K,-4),K=0, 2)
& / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
DATA (AM( 3,K,-4),K=0, 2)
& / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
DATA (AM( 4,K,-4),K=0, 2)
& / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
DATA (AM( 5,K,-4),K=0, 2)
& / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
DATA (AM( 6,K,-4),K=0, 2)
& / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
DATA (AM( 7,K,-4),K=0, 2)
& / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
DATA MEXVEC(-5) / 6 /
DATA MLFVEC(-5) / 2 /
DATA UT1VEC(-5) / 0.1619654E+02 /
DATA UT2VEC(-5) / -0.3367346E+01 /
DATA ALFVEC(-5) / 0.5109891E-02 /
DATA QMAVEC(-5) / 0.4500000E+01 /
DATA (AM( 0,K,-5),K=0, 2)
& / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
DATA (AM( 1,K,-5),K=0, 2)
& / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
DATA (AM( 2,K,-5),K=0, 2)
& / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
DATA (AM( 3,K,-5),K=0, 2)
& / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
DATA (AM( 4,K,-5),K=0, 2)
& / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
DATA (AM( 5,K,-5),K=0, 2)
& / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
DATA (AM( 6,K,-5),K=0, 2)
& / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
IF(Q .LE. QMAVEC(IFL)) THEN
PYCT5M = 0.D0
RETURN
ENDIF
IF(X .GE. 1.D0) THEN
PYCT5M = 0.D0
RETURN
ENDIF
TMP = LOG(Q/ALFVEC(IFL))
IF(TMP .LE. 0.D0) THEN
PYCT5M = 0.D0
RETURN
ENDIF
SB = LOG(TMP)
SB1 = SB - 1.2D0
SB2 = SB1*SB1
DO 110 I = 0, NEX
AF(I) = 0.D0
SBX = 1.D0
DO 100 K = 0, MLFVEC(IFL)
AF(I) = AF(I) + SBX*AM(I,K,IFL)
SBX = SB1*SBX
100 CONTINUE
110 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)
PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
C...Include threshold factor.
PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
RETURN
END
C*********************************************************************
C...PYPDPO
C...Auxiliary to PYPDPR. Gives proton parton distributions according to
C...a few older parametrizations, now obsolete but convenient for
C...backwards checks.
SUBROUTINE PYPDPO(X,Q2,XPPR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
&CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
C...The following data lines are coefficients needed in the
C...Eichten, Hinchliffe, Lane, Quigg proton structure function
C...parametrizations, see below.
C...Powers of 1-x in different cases.
DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
C...Expansion coefficients for up valence quark distribution.
DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
C...Expansion coefficients for down valence quark distribution.
DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
C...Expansion coefficients for up and down sea quark distributions.
DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
C...Expansion coefficients for gluon distribution.
DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
C...Expansion coefficients for strange sea quark distribution.
DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
C...Expansion coefficients for charm sea quark distribution.
DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
C...Expansion coefficients for bottom sea quark distribution.
DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
C...Expansion coefficients for top sea quark distribution.
DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
C...The following data lines are coefficients needed in the
C...Duke, Owens proton structure function parametrizations, see below.
C...Expansion coefficients for (up+down) valence quark distribution.
DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
C...Expansion coefficients for down valence quark distribution.
DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
C...Expansion coefficients for (up+down+strange) sea quark distribution.
DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
C...Expansion coefficients for charm sea quark distribution.
DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
C...Expansion coefficients for gluon distribution.
DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
C...Euler's beta function, requires ordinary Gamma function
EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
C...Leading order proton parton distributions from Glueck, Reya and
C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
C...10^-5 < x < 1.
IF(MSTP(51).EQ.11) THEN
C...Determine s expansion variable and some x expressions.
Q2IN=MIN(1D8,MAX(0.25D0,Q2))
SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
SD2=SD**2
XL=-LOG(X)
XS=SQRT(X)
C...Evaluate valence, gluon and sea distributions.
XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
& X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
& (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
& (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
& (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
& 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
& (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
& 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
& SQRT(4.066D0*SD**1.218D0*XL)))*
& (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
& 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
& SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
& XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
& (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
& EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
& SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
IF(SD.LE.0.888D0) THEN
XFCHM=0D0
ELSE
XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
& (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
& SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
ENDIF
IF(SD.LE.1.351D0) THEN
XFBOT=0D0
ELSE
XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
& 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
& SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
ENDIF
C...Put into output array.
XPPR(0)=XFGLU
XPPR(1)=XFVDD+XFSEA
XPPR(2)=XFVUD-XFVDD+XFSEA
XPPR(3)=XFSTR
XPPR(4)=XFCHM
XPPR(5)=XFBOT
XPPR(-1)=XFSEA
XPPR(-2)=XFSEA
XPPR(-3)=XFSTR
XPPR(-4)=XFCHM
XPPR(-5)=XFBOT
C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
C...Determine set, Lambda and x and t expansion variables.
NSET=MSTP(51)-11
IF(NSET.EQ.1) ALAM=0.2D0
IF(NSET.EQ.2) ALAM=0.29D0
TMIN=LOG(5D0/ALAM**2)
TMAX=LOG(1D8/ALAM**2)
T=LOG(MAX(1D0,Q2/ALAM**2))
VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
NX=1
IF(X.LE.0.1D0) NX=2
IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
C...Chebyshev polynomials for x and t expansion.
TX(1)=1D0
TX(2)=VX
TX(3)=2D0*VX**2-1D0
TX(4)=4D0*VX**3-3D0*VX
TX(5)=8D0*VX**4-8D0*VX**2+1D0
TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
TT(1)=1D0
TT(2)=VT
TT(3)=2D0*VT**2-1D0
TT(4)=4D0*VT**3-3D0*VT
TT(5)=8D0*VT**4-8D0*VT**2+1D0
TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
C...Calculate structure functions.
DO 120 KFL=1,6
XQSUM=0D0
DO 110 IT=1,6
DO 100 IX=1,6
XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
100 CONTINUE
110 CONTINUE
XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
120 CONTINUE
C...Put into output array.
XPPR(0)=XQ(4)
XPPR(1)=XQ(2)+XQ(3)
XPPR(2)=XQ(1)+XQ(3)
XPPR(3)=XQ(5)
XPPR(4)=XQ(6)
XPPR(-1)=XQ(3)
XPPR(-2)=XQ(3)
XPPR(-3)=XQ(5)
XPPR(-4)=XQ(6)
C...Special expansion for bottom (threshold effects).
IF(MSTP(58).GE.5) THEN
IF(NSET.EQ.1) TMIN=8.1905D0
IF(NSET.EQ.2) TMIN=7.4474D0
IF(T.GT.TMIN) THEN
VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
TT(1)=1D0
TT(2)=VT
TT(3)=2D0*VT**2-1D0
TT(4)=4D0*VT**3-3D0*VT
TT(5)=8D0*VT**4-8D0*VT**2+1D0
TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
XQSUM=0D0
DO 140 IT=1,6
DO 130 IX=1,6
XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
130 CONTINUE
140 CONTINUE
XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
XPPR(-5)=XPPR(5)
ENDIF
ENDIF
C...Special expansion for top (threshold effects).
IF(MSTP(58).GE.6) THEN
IF(NSET.EQ.1) TMIN=11.5528D0
IF(NSET.EQ.2) TMIN=10.8097D0
TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
IF(T.GT.TMIN) THEN
VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
TT(1)=1D0
TT(2)=VT
TT(3)=2D0*VT**2-1D0
TT(4)=4D0*VT**3-3D0*VT
TT(5)=8D0*VT**4-8D0*VT**2+1D0
TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
XQSUM=0D0
DO 160 IT=1,6
DO 150 IX=1,6
XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
150 CONTINUE
160 CONTINUE
XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
XPPR(-6)=XPPR(6)
ENDIF
ENDIF
C...Proton parton distributions from Duke, Owens.
C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
C...Determine set, Lambda and s expansion parameter.
NSET=MSTP(51)-13
IF(NSET.EQ.1) ALAM=0.2D0
IF(NSET.EQ.2) ALAM=0.4D0
Q2IN=MIN(1D6,MAX(4D0,Q2))
SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
C...Calculate structure functions.
DO 180 KFL=1,5
DO 170 IS=1,6
TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
& CDO(3,IS,KFL,NSET)*SD**2
170 CONTINUE
IF(KFL.LE.2) THEN
XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
& TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
ELSE
XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
& TS(5)*X**2+TS(6)*X**3)
ENDIF
180 CONTINUE
C...Put into output arrays.
XPPR(0)=XQ(5)
XPPR(1)=XQ(2)+XQ(3)/6D0
XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
XPPR(3)=XQ(3)/6D0
XPPR(4)=XQ(4)
XPPR(-1)=XQ(3)/6D0
XPPR(-2)=XQ(3)/6D0
XPPR(-3)=XQ(3)/6D0
XPPR(-4)=XQ(4)
ENDIF
RETURN
END
C*********************************************************************
C...PYHFTH
C...Gives threshold attractive/repulsive factor for heavy flavour
C...production.
FUNCTION PYHFTH(SH,SQM,FRATT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Value for alpha_strong.
IF(MSTP(35).LE.1) THEN
ALSSG=PARP(35)
ELSE
MST115=MSTU(115)
MSTU(115)=MSTP(36)
Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
& PARP(36)**2)))
ALSSG=PYALPS(Q2BN)
MSTU(115)=MST115
ENDIF
C...Evaluate attractive and repulsive factors.
XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
VINT(138)=PYHFTH
RETURN
END
C*********************************************************************
C...PYSPLI
C...Splits a hadron remnant into two (partons or hadron + parton)
C...in case it is more complicated than just a quark or a diquark.
SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks. PYDAT1 temporary
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYPARS/,/PYINT1/,/PYDAT1/
C...Local array.
DIMENSION KFL(3)
C...Preliminaries. Parton composition.
KFA=IABS(KF)
KFS=ISIGN(1,KF)
KFL(1)=MOD(KFA/1000,10)
KFL(2)=MOD(KFA/100,10)
KFL(3)=MOD(KFA/10,10)
IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
KFL(2)=INT(1.5D0+PYR(0))
IF(MINT(105).EQ.333) KFL(2)=3
IF(MINT(105).EQ.443) KFL(2)=4
KFL(3)=KFL(2)
ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
KFL(2)=2
KFL(3)=2
ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
KFL(2)=1
KFL(3)=1
ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
KFL(2)=MOD(KFA/10,10)
KFL(3)=MOD(KFA/100,10)
ENDIF
IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
KFLR=KFLIN*KFS
ELSE
KFLR=KFLIN
ENDIF
KFLCH=0
C...Subdivide lepton.
IF(KFA.GE.11.AND.KFA.LE.18) THEN
IF(KFLR.EQ.KFA) THEN
KFLSP=KFS*22
ELSEIF(KFLR.EQ.22) THEN
KFLSP=KFA
ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
KFLSP=KFA+1
ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
KFLSP=KFA-1
ELSEIF(KFLR.EQ.21) THEN
KFLSP=KFA
KFLCH=KFS*21
ELSE
KFLSP=KFA
KFLCH=-KFLR
ENDIF
C...Subdivide photon.
ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
IF(KFLR.NE.21) THEN
KFLSP=-KFLR
ELSE
RAGR=0.75D0*PYR(0)
KFLSP=1
IF(RAGR.GT.0.125D0) KFLSP=2
IF(RAGR.GT.0.625D0) KFLSP=3
IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
KFLCH=-KFLSP
ENDIF
C...Subdivide Reggeon or Pomeron.
ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
IF(KFLIN.EQ.21) THEN
KFLSP=KFS*21
ELSE
KFLSP=-KFLIN
ENDIF
C...Subdivide meson.
ELSEIF(KFL(1).EQ.0) THEN
KFL(2)=KFL(2)*(-1)**KFL(2)
KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
IF(KFLR.EQ.KFL(2)) THEN
KFLSP=KFL(3)
ELSEIF(KFLR.EQ.KFL(3)) THEN
KFLSP=KFL(2)
ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
KFLSP=KFL(2)
KFLCH=KFL(3)
ELSEIF(KFLR.EQ.21) THEN
KFLSP=KFL(3)
KFLCH=KFL(2)
ELSEIF(KFLR*KFL(2).GT.0) THEN
NTRY=0
100 NTRY=NTRY+1
CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
GOTO 100
ELSEIF(KFLCH.EQ.0) THEN
CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
MINT(51)=1
RETURN
ENDIF
KFLSP=KFL(3)
ELSE
NTRY=0
110 NTRY=NTRY+1
CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
GOTO 110
ELSEIF(KFLCH.EQ.0) THEN
CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
MINT(51)=1
RETURN
ENDIF
KFLSP=KFL(2)
ENDIF
C...Special case for extracting photon from baryon without splitting
C...the latter. (Currently only used by external programs.)
ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
KFLSP=KFA
KFLCH=0
C...Subdivide baryon.
ELSE
NAGR=0
DO 120 J=1,3
IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
120 CONTINUE
IF(NAGR.GE.1) THEN
RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
IAGR=0
DO 130 J=1,3
IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
130 CONTINUE
ELSE
IAGR=1.00001D0+2.99998D0*PYR(0)
ENDIF
ID1=1
IF(IAGR.EQ.1) ID1=2
IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
ID2=6-IAGR-ID1
KSP=3
IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
ELSEIF(MOD(KFA,10).EQ.2) THEN
IF(IAGR.EQ.1) KSP=1
IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
ENDIF
KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
IF(KFLR.EQ.21) THEN
KFLCH=KFL(IAGR)
ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
NTRY=0
140 NTRY=NTRY+1
CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
GOTO 140
ELSEIF(KFLCH.EQ.0) THEN
CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
MINT(51)=1
RETURN
ENDIF
ELSEIF(NAGR.EQ.0) THEN
NTRY=0
150 NTRY=NTRY+1
CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
GOTO 150
ELSEIF(KFLCH.EQ.0) THEN
CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
MINT(51)=1
RETURN
ENDIF
KFLSP=KFL(IAGR)
ENDIF
ENDIF
C...Add on correct sign for result.
KFLCH=KFLCH*KFS
KFLSP=KFLSP*KFS
RETURN
END
C*********************************************************************
C...PYGAMM
C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
C...(Dover, 1965) 6.1.36.
FUNCTION PYGAMM(X)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local array and data.
DIMENSION B(8)
DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
&-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
NX=INT(X)
DX=X-NX
PYGAMM=1D0
DXP=1D0
DO 100 I=1,8
DXP=DXP*DX
PYGAMM=PYGAMM+B(I)*DXP
100 CONTINUE
IF(X.LT.1D0) THEN
PYGAMM=PYGAMM/X
ELSE
DO 110 IX=1,NX-1
PYGAMM=(X-IX)*PYGAMM
110 CONTINUE
ENDIF
RETURN
END
C***********************************************************************
C...PYWAUX
C...Calculates real and imaginary parts of the auxiliary functions W1
C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
C...der Bij, Nucl. Phys. B297 (1988) 221.
SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
ASINH(X)=LOG(X+SQRT(X**2+1D0))
ACOSH(X)=LOG(X+SQRT(X**2-1D0))
IF(EPS.LT.0D0) THEN
IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
WIM=0D0
ELSEIF(EPS.LT.1D0) THEN
IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
ELSE
IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
WIM=0D0
ENDIF
RETURN
END
C***********************************************************************
C...PYI3AU
C...Calculates real and imaginary parts of the auxiliary function I3;
C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
C...Nucl. Phys. B297 (1988) 221.
SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
IF(EPS.LT.0D0) THEN
IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
& PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
& PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
& PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
& LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
& LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
& LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
& EPS))
ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
& PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
& PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
& PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
& 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
& LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
& LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
& PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
& PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
& PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
& 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
& LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
& LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
ELSE
F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
& PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
& PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
& LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
& LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
ENDIF
F3IM=0D0
ELSEIF(EPS.LT.1D0) THEN
IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
& PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
& PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
& PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
& (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
& (0.25D0*(RAT+1D0)*EPS))
F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
& (0.25D0*(RAT+1D0)*EPS))
ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
& PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
& PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
& PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
& LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
& LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
& PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
& PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
& PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
& LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
& (1D0+0.25D0*RAT*EPS-GA))
F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
& (1D0+0.25D0*RAT*EPS-GA))
ELSE
F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
& PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
& PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
& LOG((GA+BE-1D0)/(BE-GA))
F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
ENDIF
ELSE
RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
RCTHE=RSQ*(1D0-2D0*BE/EPS)
RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
R=SQRT(RSQ)
THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
& PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
& (PHI-THE)*(PHI+THE-PARU(1))
F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
& PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
ENDIF
Y3RE=2D0/(2D0*BE-1D0)*F3RE
Y3IM=2D0/(2D0*BE-1D0)*F3IM
RETURN
END
C***********************************************************************
C...PYSPEN
C...Calculates real and imaginary part of Spence function; see
C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
C...Local array and data.
DIMENSION B(0:14)
DATA B/
&1.000000D+00, -5.000000D-01, 1.666667D-01,
&0.000000D+00, -3.333333D-02, 0.000000D+00,
&2.380952D-02, 0.000000D+00, -3.333333D-02,
&0.000000D+00, 7.575757D-02, 0.000000D+00,
&-2.531135D-01, 0.000000D+00, 1.166667D+00/
XRE=XREIN
XIM=XIMIN
IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
IF(IREIM.EQ.2) PYSPEN=0D0
RETURN
ENDIF
XMOD=SQRT(XRE**2+XIM**2)
IF(XMOD.LT.1D-6) THEN
IF(IREIM.EQ.1) PYSPEN=0D0
IF(IREIM.EQ.2) PYSPEN=0D0
RETURN
ENDIF
XARG=SIGN(ACOS(XRE/XMOD),XIM)
SP0RE=0D0
SP0IM=0D0
SGN=1D0
IF(XMOD.GT.1D0) THEN
ALGXRE=LOG(XMOD)
ALGXIM=XARG-SIGN(PARU(1),XARG)
SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
SP0IM=-ALGXRE*ALGXIM
SGN=-1D0
XMOD=1D0/XMOD
XARG=-XARG
XRE=XMOD*COS(XARG)
XIM=XMOD*SIN(XARG)
ENDIF
IF(XRE.GT.0.5D0) THEN
ALGXRE=LOG(XMOD)
ALGXIM=XARG
XRE=1D0-XRE
XIM=-XIM
XMOD=SQRT(XRE**2+XIM**2)
XARG=SIGN(ACOS(XRE/XMOD),XIM)
ALGYRE=LOG(XMOD)
ALGYIM=XARG
SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
SGN=-SGN
ENDIF
XRE=1D0-XRE
XIM=-XIM
XMOD=SQRT(XRE**2+XIM**2)
XARG=SIGN(ACOS(XRE/XMOD),XIM)
ZRE=-LOG(XMOD)
ZIM=-XARG
SPRE=0D0
SPIM=0D0
SAVERE=1D0
SAVEIM=0D0
DO 100 I=0,14
IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
SAVERE=TERMRE
SAVEIM=TERMIM
SPRE=SPRE+B(I)*TERMRE
SPIM=SPIM+B(I)*TERMIM
100 CONTINUE
110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
RETURN
END
C***********************************************************************
C...PYQQBH
C...Calculates the matrix element for the processes
C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
C...REDUCE output and part of the rest courtesy Z. Kunszt, see
C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
SUBROUTINE PYQQBH(WTQQBH)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
C...Local arrays and function.
DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
&PP(I,3)*PP(J,3)
C...Mass parameters.
WTQQBH=0D0
ISUB=MINT(1)
SHPR=SQRT(VINT(26))*VINT(1)
PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
PH=SQRT(VINT(21))*VINT(1)
SPQ=PQ**2
SPH=PH**2
C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
DO 100 I=1,2
PT=SQRT(MAX(0D0,VINT(197+5*I)))
PP(I,1)=PT*COS(VINT(198+5*I))
PP(I,2)=PT*SIN(VINT(198+5*I))
100 CONTINUE
PP(3,1)=-PP(1,1)-PP(2,1)
PP(3,2)=-PP(1,2)-PP(2,2)
PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
PMS3=SPH+PP(3,1)**2+PP(3,2)**2
PMT3=SQRT(PMS3)
PP(3,3)=PMT3*SINH(VINT(211))
PP(3,4)=PMT3*COSH(VINT(211))
PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
&VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
PP(2,3)=-PP(1,3)-PP(3,3)
PP(1,4)=SQRT(PMS1+PP(1,3)**2)
PP(2,4)=SQRT(PMS2+PP(2,3)**2)
C...Set up incoming kinematics and derived momentum combinations.
DO 110 I=4,5
PP(I,1)=0D0
PP(I,2)=0D0
PP(I,3)=-0.5D0*SHPR*(-1)**I
PP(I,4)=-0.5D0*SHPR
110 CONTINUE
DO 120 J=1,4
PP(6,J)=PP(1,J)+PP(2,J)
PP(7,J)=PP(1,J)+PP(3,J)
PP(8,J)=PP(1,J)+PP(4,J)
PP(9,J)=PP(1,J)+PP(5,J)
PP(10,J)=-PP(2,J)-PP(3,J)
PP(11,J)=-PP(2,J)-PP(4,J)
PP(12,J)=-PP(2,J)-PP(5,J)
PP(13,J)=-PP(4,J)-PP(5,J)
120 CONTINUE
C...Derived kinematics invariants.
X1=DOT(1,2)
X2=DOT(1,3)
X3=DOT(1,4)
X4=DOT(1,5)
X5=DOT(2,3)
X6=DOT(2,4)
X7=DOT(2,5)
X8=DOT(3,4)
X9=DOT(3,5)
X10=DOT(4,5)
C...Propagators.
SS1=DOT(7,7)-SPQ
SS2=DOT(8,8)-SPQ
SS3=DOT(9,9)-SPQ
SS4=DOT(10,10)-SPQ
SS5=DOT(11,11)-SPQ
SS6=DOT(12,12)-SPQ
SS7=DOT(13,13)
DX(1)=SS1*SS6
DX(2)=SS2*SS6
DX(3)=SS2*SS4
DX(4)=SS1*SS5
DX(5)=SS3*SS5
DX(6)=SS3*SS4
DX(7)=SS7*SS1
DX(8)=SS7*SS4
C...Define colour coefficients for g + g -> Q + Qbar + H.
IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
DO 140 I=1,3
DO 130 J=1,3
CLR(I,J)=16D0/3D0
CLR(I+3,J+3)=16D0/3D0
CLR(I,J+3)=-2D0/3D0
CLR(I+3,J)=-2D0/3D0
130 CONTINUE
140 CONTINUE
DO 160 L=1,2
DO 150 I=1,3
CLR(I,6+L)=-6D0
CLR(I+3,6+L)=6D0
CLR(6+L,I)=-6D0
CLR(6+L,I+3)=6D0
150 CONTINUE
160 CONTINUE
DO 180 K1=1,2
DO 170 K2=1,2
CLR(6+K1,6+K2)=12D0
170 CONTINUE
180 CONTINUE
C...Evaluate matrix elements for g + g -> Q + Qbar + H.
FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
& X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
& X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
& *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
& X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
& X10)
FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
& X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
& +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
& -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
& -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
& X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
& X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
& )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
& 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
& X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
& X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
& X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
& *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
& 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
& X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
& +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
& X4*X6*X5)
FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
& X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
& X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
& *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
& +X4*X9*X5+X4*X5**2)
FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
& PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
& X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
& X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
& X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
& X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
& PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
& 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
& X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
& +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
& X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
& X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
& X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
& X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
& X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
& *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
& X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
& X6)
FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
& X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
& X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
& *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
& **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
& *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
& X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
& X5+X4*X6*X5)
FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
& *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
& 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
& X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
& X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
& *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
& X6**2)
FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
& X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
& X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
& X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
& 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
& X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
& -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
& X4*X6*X5)
FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
& 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
& X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
& X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
& *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
& +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
& -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
& X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
& X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
& X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
& *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
& 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
& X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
& X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
& *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
& X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
& X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
& X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
& *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
& X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
& X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
& +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
& X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
& X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
& X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
& *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
& +X3*X8*X5+X3*X5**2)
FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
& X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
& X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
& *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
& **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
& *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
& X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
& X5+X4*X6*X5)
FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
& X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
& )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
& X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
& X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
& PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
& X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
& X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
& X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
& X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
& X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
& *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
& +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
& PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
& 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
& +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
& X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
& *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
& X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
& X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
& *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
& X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
& X10)
FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
& X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
& +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
& -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
& -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
& X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
& *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
& X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
& X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
& X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
& X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
& *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
& +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
& *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
& X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
& *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
& *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
& *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
& X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
& X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
& *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
& X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
& X7)
FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
& 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
& X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
& 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
& 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
& 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
& X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
& *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
& X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
& X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
& *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
& 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
& X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
& 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
& X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
& 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
& X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
& X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
& *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
& X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
& X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
& +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
& X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
& *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
& -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
& -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
& 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
& *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
& *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
& **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
& 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
& *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
& X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
& X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
& *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
& X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
& X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
& X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
& *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
& *X6)
FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
& 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
& X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
& X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
& X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
& +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
& 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
& *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
& *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
& X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
& X8)
FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
& X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
& )+2*X2*(-X10*X5+X9*X6+X8*X7)
FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
& X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
& *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
& X9*X5)
FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
& X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
& *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
& X8*X5)
FM(9,10)=0.5D0*(FMXX+FM(9,10))
FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
& X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
& )+2*X5*(-X10*X2+X9*X3+X8*X4)
C...Repackage matrix elements.
DO 200 I=1,8
DO 190 J=I,8
RM(I,J)=FM(I,J)
190 CONTINUE
200 CONTINUE
RM(7,7)=FM(7,7)-2D0*FM(9,9)
RM(7,8)=FM(7,8)-2D0*FM(9,10)
RM(8,8)=FM(8,8)-2D0*FM(10,10)
C...Produce final result: matrix elements * colours * propagators.
DO 220 I=1,8
DO 210 J=I,8
FAC=8D0
IF(I.EQ.J)FAC=4D0
WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
210 CONTINUE
220 CONTINUE
WTQQBH=-WTQQBH/256D0
ELSE
C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
& *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
& *X6+X8*X7)
A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
& 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
& +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
& X5)
A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
& X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
& *X9+X4*X8)
C...Produce final result: matrix elements * propagators.
A11=A11/DX(7)**2
A12=A12/(DX(7)*DX(8))
A22=A22/DX(8)**2
WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
ENDIF
RETURN
END
C*********************************************************************
C...PYSTBH (and auxiliaries)
C.. Evaluates the matrix elements for t + b + H production.
SUBROUTINE PYSTBH(WTTBH)
C...DOUBLE PRECISION AND INTEGER DECLARATIONS
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...COMMONBLOCKS
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
DOUBLE PRECISION MW2
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
&/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
C...LOCAL ARRAYS AND COMPLEX VARIABLES
DIMENSION QQ(4,2),PP(4,3)
DATA QQ/8*0D0/
WTTBH=0D0
C...KINEMATIC PARAMETERS.
SHPR=SQRT(VINT(26))*VINT(1)
PH=SQRT(VINT(21))*VINT(1)
SPH=PH**2
C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
DO 100 I=1,2
PT=SQRT(MAX(0D0,VINT(197+5*I)))
PP(1,I)=PT*COS(VINT(198+5*I))
PP(2,I)=PT*SIN(VINT(198+5*I))
100 CONTINUE
PP(1,3)=-PP(1,1)-PP(1,2)
PP(2,3)=-PP(2,1)-PP(2,2)
PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
PMS3=SPH+PP(1,3)**2+PP(2,3)**2
PMT3=SQRT(PMS3)
PP(3,3)=PMT3*SINH(VINT(211))
PP(4,3)=PMT3*COSH(VINT(211))
PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
&VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
PP(3,2)=-PP(3,1)-PP(3,3)
PP(4,1)=SQRT(PMS1+PP(3,1)**2)
PP(4,2)=SQRT(PMS2+PP(3,2)**2)
C...CM SYSTEM, INGOING QUARKS/GLUONS
QQ(3,1) = SHPR/2.D0
QQ(4,1) = QQ(3,1)
QQ(3,2) = -QQ(3,1)
QQ(4,2) = QQ(4,1)
C...PARAMETERS FOR AMPLITUDE METHOD
ALPHA = AEM
ALPHAS = AS
SW2 = PARU(102)
MW2 = PMAS(24,1)**2
TANB = PARU(141)
VTB = VCKM(3,3)
RMB=PYMRUN(5,VINT(52))
ISUB=MINT(1)
IF (ISUB.EQ.401) THEN
CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
& VINT(201),VINT(206),RMB,VINT(43),WTTBH)
ELSE IF (ISUB.EQ.402) THEN
CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
& VINT(201),VINT(206),RMB,VINT(43),WTTBH)
END IF
RETURN
END
C------------------------------------------------------------------
SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
SAVE /PYCTBH/
C TOP WIDTH CALCULATION
C VTB = 0.99
MW=DSQRT(MW2)
XB=(MB/MT)**2
XW=(MW/MT)**2
XH =(MHP/MT)**2
GAMTBH = 0D0
IF (MT .LT. (MHP+MB)) THEN
C T ->B W ONLY
BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
& (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
GAMT = GAMTBW
ELSE
C T ->BW +T ->B H^+
BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
& (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
C
KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
& -4.D0*(MHP*MB/MT**2)**2 )
GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
& (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
GAMT = GAMTBW+GAMTBH
ENDIF
C THUS BR IS
BR=GAMTBH/GAMT
RETURN
END
C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
C GG->TBH^+, QQBAR->TBH^+
C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
C (FOR INSTANCE WITH PYTHIA)
C------------------------------------------------------------
C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
C PHYS REV. D 60 (1999) 115011
C (THESE FILES PREPARED BY J.-L. KNEUR)
C------------------------------------------------------------
C 1) GG->TBH^+
SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
C
C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
C
C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
C "PHYSICAL PARAMETERS" INPUT:
C MT,MB TOP AND BOTTOM MASSES;
C MHP CHARGED HIGGS MASS
C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
C
C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
C
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
DOUBLE PRECISION MW2,MT,MB,MHP,MW
DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
C (TAN BETA) VALUES
C
C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
PI = 4*DATAN(1.D0)
MW = DSQRT(MW2)
C
C COLLECTING THE RELEVANT OVERALL FACTORS:
C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
C COUPLING CONSTANT (OVERALL NORMALIZATION)
FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
C ALPHAS IS ALPHA_STRONG;
C SW2 IS SIN(THETA_W)**2.
C
C VTB=.998D0
C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
C
V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
C
C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
DO 100 KK=1,4
P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
100 CONTINUE
C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
S = 2*PYTBHS(Q1,Q2)
P1Q1=PYTBHS(Q1,P1)
P1Q2=PYTBHS(P1,Q2)
P2Q1=PYTBHS(P2,Q1)
P2Q2=PYTBHS(P2,Q2)
P1P2=PYTBHS(P1,P2)
C
C TOP WIDTH CALCULATION
CALL PYTBHB(MT,MB,MHP,BR,GAMT)
C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
C THEN DEFINE TOP (RESONANT) PROPAGATOR:
A1INV= S -2*P1Q1 -2*P1Q2
A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
C THE TOP WIDTH
A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
C NOW COMES THE AMP**2:
C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
C THE EXPRESSIONS BELOW
V18=0.D0
A18=0.D0
V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
&512*A1*A2*MB*MT/3-
&368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
&320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
&128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
&256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
&8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
&88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
&704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
&104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
&128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
&448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
&656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
&128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
&256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
&256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
&8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
&704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
&104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
&128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
&448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
&32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
&64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
&64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
&112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
&272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
&400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
&96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
&544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
&256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
&112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
&272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
&400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
&544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
&128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
&256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
&256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
&64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
&64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
&64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
&64*MB**3*MT/(3*P1Q2*P2Q1**2)+
&256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
&256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
&256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
&512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
&256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
&256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
&88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
&224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
&448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
&128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
&16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
&32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
&64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
&64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
&448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
&224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
&64*MB*MT**3/(3*P1Q2**2*P2Q1)-
&256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
&256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
&64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
&128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
&128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
&256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
&64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
&128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
&112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
&32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
&48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
&512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
&8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
&32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
&16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
&32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
&160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
&56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
&48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
&256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
&256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
&1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
&64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
&112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
&32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
&32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
&32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
&64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
&656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
&256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
&224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
&448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
&256*A12*MT**4*P2Q1/(3*P1Q2**2)+
&256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
&112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
&16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
&640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
&32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
&128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
&256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
&256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
&64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
&64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
&64*MB**3*MT/(3*P1Q1*P2Q2**2)+
&256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
&256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
&256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
&256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
&64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
&256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
&512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
&256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
&64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
&64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
&128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
&128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
&256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
&256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
&256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
&72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
&32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
&704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
&104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
&512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
&32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
&256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
&256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
&4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
&128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
&112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
&32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
&48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
&512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
&64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
&112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
&16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
&32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
&64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
&64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
&8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
&32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
&16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
&32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
&32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
&32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
&64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
&448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
&224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
&64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
&128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
&128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
&256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
&160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
&56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
&48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
&1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
&32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
&16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
&64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
&8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
&32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
&16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
&16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
&8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
&32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
&16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
&16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
&16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
&112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
&400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
&272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
&96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
&512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
&200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
&272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
&256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
&256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
&256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
&1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
&544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
&32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
&32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
&64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
&32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
&64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
&944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
&256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
&96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
&128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
&256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
&128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
&512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
&512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
&256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
&272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
&656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
&16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
&32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
&368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
&256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
&224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
&448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
&16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
&32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
&256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
&640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
&256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
&64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
&64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
&128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
&256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
&256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
&256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
&112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
&400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
&272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
&96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
&32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
&32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
&64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
&32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
&512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
&256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
&200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
&272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
&256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
&256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
&1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
&32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
&96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
&128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
&256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
&128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
&512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
&512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
&640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
&64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
&256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
&272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
&384*A12*MB*MT*P1Q1**2/S**2+
&384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
&2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
&384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
&768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
&2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
&960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
&960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
&384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
&960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
&2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
&960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
&768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
&960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
&2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
&960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
&960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
&960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
&768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
&192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
&768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
&96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
&96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
&144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
&480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
&864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
&96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
&96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
&48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
&48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
&192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
&192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
&192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
&96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
&192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
&384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
&480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
&864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
&48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
&48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
&192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
&192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
&96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
&192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
&192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
&192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
&96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
&192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
&192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
&192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
&96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
&192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
&192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
&96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
&96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
&96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
&192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
&48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
&96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
&48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
&192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
&96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
&96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
&480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
&672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
&96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
&192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
&192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
&192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
&48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
&192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
&192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
&96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
&192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
&96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
&384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
&384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
&960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
&144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
&384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
&96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
&96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
&576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
&96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
&288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
&96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
&192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
&48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
&192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
&96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
&192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
&192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
&192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
&192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
&192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
&96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
&96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
&96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
&192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
&96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
&96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
&192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
&192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
&192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
&192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
&96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
&192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
&96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
&96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
&192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
&96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
&384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
&144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
&96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
&384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
&96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
&48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
&48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
&96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
&96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
&192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
&96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
&192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
&48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
&192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
&96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
&96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
&384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
&96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
&96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
&96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
&480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
&672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
&48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
&192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
&192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
&960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
&96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
&96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
&192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
&144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
&384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
&96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
&96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
&192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
&384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
&192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
&192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
&96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
&384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
&384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
&96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
&192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
&192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
&192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
&144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
&96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
&384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
&576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
&192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
&192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
&48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
V18BIS=
&48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
&96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
&192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
&96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
&384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
&96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
&96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
&96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
&96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
&192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
&96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
&192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
&192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
&48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
&192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
&384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
&128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
&152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
&128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
&16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
&128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
&152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
&128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
&16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
&16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
&272*A1*A2*P1Q1*S/(3*P1Q2)+
&272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
&128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
&32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
&64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
&64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
&128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
&128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
&128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
&112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
&152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
&16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
&16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
&8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
&8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
&16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
&32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
&32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
&64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
&128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
&24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
&24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
&64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
&56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
&128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
&64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
&256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
&8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
&8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
&128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
&128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
&256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
&32*A12*P2Q1*S/(3*P1Q1)-
&128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
&128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
&32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
&64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
&64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
&128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
&128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
&128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
&112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
&152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
&16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
&64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
&64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
&128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
&24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
&128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
&64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
&56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
&128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
&64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
&256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
&8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
&16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
&8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
&8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
&16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
&8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
&32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
&8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
&8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
&16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
&128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
&128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
&256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
&32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
&4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
&8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
&8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
&8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
&2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
&272*A1*A2*P2Q1*S/(3*P2Q2)-
&128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
&128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
&128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
&256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
&16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
&8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
&256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
&128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
&32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
&16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
&128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
&128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
&128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
&256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
&8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
&8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
&8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
&8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
&8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
&4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
&4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
&2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
C
A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
&512*A1*A2*MB*MT/3+
&368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
&320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
&128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
&256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
&8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
&88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
&704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
&104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
&128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
&448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
&656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
&128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
&256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
&256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
&8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
&704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
&104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
&128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
&448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
&32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
&64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
&64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
&112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
&272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
&400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
&96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
&544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
&256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
&112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
&272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
&400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
&544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
&128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
&256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
&256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
&64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
&64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
&64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
&64*MB**3*MT/(3*P1Q2*P2Q1**2)-
&256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
&256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
&256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
&512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
&256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
&256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
&88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
&224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
&448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
&128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
&16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
&32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
&64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
&64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
&448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
&224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
&64*MB*MT**3/(3*P1Q2**2*P2Q1)+
&256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
&256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
&64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
&128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
&128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
&256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
&64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
&128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
&112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
&32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
&48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
&512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
&8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
&32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
&16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
&32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
&160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
&56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
&48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
&256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
&256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
&1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
&256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
&64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
&112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
&32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
&32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
&32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
&64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
&656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
&256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
&224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
&448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
&256*A12*MT**4*P2Q1/(3*P1Q2**2)+
&256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
&112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
&16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
&640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
&32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
&128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
&256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
&256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
&64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
&64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
&64*MB**3*MT/(3*P1Q1*P2Q2**2)-
&256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
&256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
&256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
&256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
&64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
&256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
&512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
&256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
&64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
&64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
&128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
&128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
&256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
&256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
&256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
&72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
&32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
&704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
&104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
&512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
&32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
&256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
&256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
&4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
&128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
&112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
&32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
&48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
&512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
&64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
&112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
&16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
&32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
&64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
&64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
&8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
&32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
&16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
&32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
&32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
&32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
&64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
&448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
&224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
&64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
&128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
&128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
&256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
&160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
&56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
&48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
&256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
&1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
&256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
&32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
&16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
&64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
&8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
&32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
&16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
&16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
&8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
&32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
&16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
&16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
&16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
&32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
&112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
&400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
&272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
&96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
&512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
&200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
&272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
&256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
&256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
&256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
&1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
&544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
&32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
&32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
&64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
&32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
&64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
&944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
&256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
&96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
&128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
&256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
&128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
&512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
&512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
&256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
&272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
&256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
&256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
&512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
&656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
&16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
&32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
&368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
&256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
&224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
&448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
&16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
&32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
&256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
&640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
&256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
&64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
&64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
&128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
&256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
&256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
&256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
&112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
&400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
&272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
&96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
&32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
&32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
&64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
&32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
&512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
&256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
&200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
&272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
&256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
&256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
&1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
&32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
&96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
&128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
&256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
&128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
&512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
&512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
&640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
&64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
&256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
&272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
&256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
&256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
&512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
&384*A12*MB*MT*P1Q1**2/S**2+
&384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
&2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
&384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
&768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
&2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
&960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
&960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
&384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
&960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
&2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
&960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
&768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
&960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
&2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
&960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
&384*A2**2*MB*MT*P2Q2**2/S**2+
&384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
&960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
&768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
&192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
&768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
&96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
&96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
&144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
&480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
&864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
&96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
&96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
&48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
&48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
&192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
&192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
&192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
&192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
&384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
&480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
&864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
&48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
&48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
&192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
&192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
&96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
&192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
&192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
&192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
&96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
&192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
&192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
&192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
&96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
&192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
&192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
&96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
&96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
&96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
&192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
&48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
&96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
&48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
&192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
&96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
&96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
&480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
&96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
&96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
&192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
&192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
&48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
&192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
&192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
&96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
&192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
&96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
&384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
&384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
&960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
&144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
&384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
&96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
&576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
&384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
&96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
&288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
&96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
&192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
&48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
&192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
&96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
&192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
&192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
&192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
&192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
&192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
&96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
&96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
&192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
&48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
&96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
&96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
&192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
&192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
&192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
&192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
&96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
&192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
&96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
&96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
&192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
&96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
&384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
&144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
&384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
&576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
&96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
&96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
&96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
&96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
&192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
&96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
&192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
&48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
&192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
&96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
&384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
&384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
&192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
&96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
&96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
&480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
&672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
&48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
&192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
&192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
&960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
&96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
&96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
&192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
&144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
&384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
&96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
&576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
&384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
&192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
&192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
&96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
&384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
&384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
&96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
&192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
&192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
&192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
&144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
&96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
&384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
&576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
&96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
&192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
&96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
&96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
&192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
&96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
&384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
&96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
&96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
&96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
&192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
&96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
&192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
&384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
&48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
&192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
&96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
&384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
&128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
&152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
&128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
&16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
&128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
&128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
&16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
&16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
&16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
&272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
&128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
&32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
A18BIS=
&64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
&64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
&128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
&128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
&128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
&112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
&152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
&16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
&16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
&8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
&8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
&16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
&8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
&32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
&32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
&64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
&12*S/(P1Q2*P2Q1)+
&24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
&24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
&64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
&56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
&128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
&64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
&256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
&8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
&8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
&128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
&128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
&256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
&16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
&128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
&128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
&32*MB**2*S/(3*P1Q1*P2Q2**2)+
&64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
&64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
&128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
&128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
&128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
&112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
&152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
&16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
&64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
&64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
&128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
&24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
&24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
&64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
&56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
&64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
&256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
&8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
&16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
&8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
&8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
&16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
&8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
&32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
&8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
&8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
&16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
&136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
&128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
&256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
&32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
&8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
&8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
&8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
&8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
&2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
&8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
&8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
&8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
&128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
&128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
&128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
&16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
&8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
&256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
&128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
&32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
&16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
&128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
&128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
&128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
&256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
&8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
&256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
&8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
&8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
&8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
&8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
&4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
&2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
C
V18=V18+V18BIS
A18=A18+A18BIS
V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
&384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
&384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
&192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
&192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
&192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
&384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
&192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
&192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
&384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
&192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
&192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
&192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
&96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
&96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
&96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
&96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
V910=V910+96*A1*A2*P1P2*P2Q1/S-
&96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
&192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
&96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
&96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
&192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
C
A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
&384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
&384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
&192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
&192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
&192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
&384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
&192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
&192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
&384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
&192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
&192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
&192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
&96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
&96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
&96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
&96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
A910=A910+96*A1*A2*P1P2*P2Q1/S-
&96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
&192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
&96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
&96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
&192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
C
C FINAL RESULT;
C
AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
END
C---------------------------------------------------------
C 2) Q QBAR ->TBH^+
SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
C
C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
DOUBLE PRECISION MW2,MT,MB,MHP,MW
DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
C
C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
C
DIMENSION YY(2,2)
PI = 4*DATAN(1.D0)
MW = DSQRT(MW2)
C COLLECTING THE RELEVANT OVERALL FACTORS:
C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
C COUPLING CONSTANT (OVERALL NORMALIZATION)
FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
C ALPHAS IS ALPHA_STRONG;
C SW2 IS SIN(THETA_W)**2.
C
C VTB=.998D0
C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
C
V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
C
C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
DO 100 KK=1,4
P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
100 CONTINUE
C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
S = 2*PYTBHS(Q1,Q2)
P1Q1=PYTBHS(Q1,P1)
P1Q2=PYTBHS(P1,Q2)
P2Q1=PYTBHS(P2,Q1)
P2Q2=PYTBHS(P2,Q2)
P1P2=PYTBHS(P1,P2)
C
C TOP WIDTH CALCULATION
CALL PYTBHB(MT,MB,MHP,BR,GAMT)
C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
C THEN DEFINE TOP (RESONANT) PROPAGATOR:
A1INV= S -2*P1Q1 -2*P1Q2
A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
C NOW COMES THE AMP**2:
C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
C THE EXPRESSIONS BELOW
YY(1, 1) = -16*A**2*A2**2*MB*MT+
&64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
&128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
&128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
&64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
&64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
&64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
&32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
&32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
&32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
&32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
&16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
&128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
&128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
&64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
&64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
&64*A2**2*P1Q1*P2Q2**2*V**2/S**2
YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
&32*A2**2*MB**2*P1P2*V**2/S+
&32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
&32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
&32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
YY(1, 1)=2*YY(1, 1)
YY(1, 2) = -32*A**2*A1*A2*MB*MT+
&128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
&128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
&64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
&64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
&64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
&128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
&128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
&64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
&64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
&64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
&64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
&64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
&64*A**2*A1*A2*MB*MT*P1P2/S+
&64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
&32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
&32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
&64*A**2*A1*A2*P1Q1*P2Q1/S-
&32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
&64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
&128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
&128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
&64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
&64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
&64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
&128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
&128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
&64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
&64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
&64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
&64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
&64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
&64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
&32*A1*A2*P1P2*P1Q1*V**2/S+
&32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
&32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
&64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
&32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
YY(2, 2) =-16*A**2*A12*MB*MT+
&128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
&128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
&64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
&64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
&64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
&32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
&32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
&32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
&32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
&128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
&128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
&64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
&64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
&64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
&32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
&32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
&32*A12*MT**2*P2Q2*V**2/S-
&32*A12*P1Q2*P2Q2*V**2/S
YY(2, 2)=2*YY(2, 2)
RES=YY(1,1)+2*YY(1,2)+YY(2,2)
AMP2= FACT*PS*VTB**2*RES
END
C=====================================================================
C ************* FUNCTION SCALAR PRODUCTS *************************
DOUBLE PRECISION FUNCTION PYTBHS(A,B)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
DIMENSION A(4),B(4)
DUM=A(4)*B(4)
DO 100 ID=1,3
DUM=DUM-A(ID)*B(ID)
100 CONTINUE
PYTBHS=DUM
RETURN
END
C*********************************************************************
C...PYMSIN
C...Initializes supersymmetry: finds sparticle masses and
C...branching ratios and stores this information.
C...AUTHOR: STEPHEN MRENNA
C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
SUBROUTINE PYMSIN
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYHTRI/HHH(7)
COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
&/PYMSSM/,/PYMSRV/,/PYSSMT/
C...Local variables.
DOUBLE PRECISION ALFA,BETA
DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
INTEGER I,J,J1,I1,K1
INTEGER KC,LKNT,IDLAM(400,3)
DOUBLE PRECISION XLAM(0:400)
DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
DOUBLE PRECISION DELM,XMDIF
DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
DOUBLE PRECISION ARG,SGNMU,R
INTEGER IMSSM
INTEGER IRPRTY
INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
SAVE MWIDSU,MDCYSU
DATA KFSUSY/
&1000001,2000001,1000002,2000002,1000003,2000003,
&1000004,2000004,1000005,2000005,1000006,2000006,
&1000011,2000011,1000012,2000012,1000013,2000013,
&1000014,2000014,1000015,2000015,1000016,2000016,
&1000021,1000022,1000023,1000025,1000035,1000024,
&1000037,1000039, 25, 35, 36, 37,
& 6, 24, 45, 46,1000045, 9*0/
DATA INIT/0/
C...Automatically read QNUMBERS, MASS, and DECAY tables
IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
NQNUM=0
CALL PYSLHA(0,0,IFAIL)
CALL PYSLHA(5,0,IFAIL)
ENDIF
IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
C...Do nothing further if SUSY not requested
IMSSM=IMSS(1)
IF(IMSSM.EQ.0) RETURN
C...Save copy of MWID(KC) and MDCY(KC,1) values before
C...they are set to zero for the LSP.
IF(INIT.EQ.0) THEN
INIT=1
DO 100 I=1,36
KF=KFSUSY(I)
KC=PYCOMP(KF)
MWIDSU(I)=MWID(KC)
MDCYSU(I)=MDCY(KC,1)
100 CONTINUE
ENDIF
C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
DO 110 I=1,36
KF=KFSUSY(I)
KC=PYCOMP(KF)
IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
MWID(KC)=MWIDSU(I)
MDCY(KC,1)=MDCYSU(I)
ENDIF
110 CONTINUE
C...First part of routine: set masses and couplings.
C...Reset mixing values in sfermion sector to pure left/right.
DO 120 I=1,16
SFMIX(I,1)=1D0
SFMIX(I,4)=1D0
SFMIX(I,2)=0D0
SFMIX(I,3)=0D0
120 CONTINUE
C...Add NMSSM states if NMSSM switched on, and change old names.
IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
C... Switch on NMSSM
WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
KFN=25
KCN=KFN
CHAF(KCN,1)='h_10'
CHAF(KCN,2)=' '
KFN=35
KCN=KFN
CHAF(KCN,1)='h_20'
CHAF(KCN,2)=' '
KFN=45
KCN=KFN
CHAF(KCN,1)='h_30'
CHAF(KCN,2)=' '
KFN=36
KCN=KFN
CHAF(KCN,1)='A_10'
CHAF(KCN,2)=' '
KFN=46
KCN=KFN
CHAF(KCN,1)='A_20'
CHAF(KCN,2)=' '
KFN=1000045
KCN=PYCOMP(KFN)
IF (KCN.EQ.0) THEN
DO 123 KCT=100,MSTU(6)
IF(KCHG(KCT,4).GT.100) KCN=KCT
123 CONTINUE
KCN=KCN+1
KCHG(KCN,4)=KFN
MSTU(20)=0
ENDIF
C... Set stable for now
PMAS(KCN,2)=1D-6
MWID(KCN)=0
MDCY(KCN,1)=0
MDCY(KCN,2)=0
MDCY(KCN,3)=0
CHAF(KCN,1)='~chi_50'
CHAF(KCN,2)=' '
ENDIF
C...Read spectrum from SLHA file.
IF (IMSSM.EQ.11) THEN
CALL PYSLHA(1,0,IFAIL)
ENDIF
C...Common couplings.
TANB=RMSS(5)
BETA=ATAN(TANB)
COSB=COS(BETA)
SINB=TANB*COSB
COS2B=COS(2D0*BETA)
ALFA=RMSS(18)
XMW2=PMAS(24,1)**2
XMZ2=PMAS(23,1)**2
XW=PARU(102)
C...Define sparticle masses for a general MSSM simulation.
IF(IMSSM.EQ.1) THEN
IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
DO 130 I=1,5,2
KC=PYCOMP(KSUSY1+I)
PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
KC=PYCOMP(KSUSY2+I)
PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
KC=PYCOMP(KSUSY1+I+1)
PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
KC=PYCOMP(KSUSY2+I+1)
PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
130 CONTINUE
XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
IF(XARG.LT.0D0) THEN
WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
& ' FROM THE SUM RULE. '
WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
RETURN
ELSE
XARG=SQRT(XARG)
ENDIF
DO 140 I=11,15,2
PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
140 CONTINUE
IF(IMSS(8).EQ.1) THEN
RMSS(13)=RMSS(6)
RMSS(14)=RMSS(7)
ENDIF
C...Alternatively derive masses from SUGRA relations.
ELSEIF(IMSSM.EQ.2) THEN
RMSS(36)=RMSS(16)
CALL PYAPPS
C...Or use ISASUSY
ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
RMSS(36)=RMSS(16)
CALL PYSUGI
ALFA=RMSS(18)
GOTO 170
ELSE
GOTO 170
ENDIF
C...Add in extra D-term contributions.
IF(IMSS(7).EQ.1) THEN
R=0.43D0
DX=RMSS(23)
DY=RMSS(24)
DS=RMSS(25)
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
WRITE(MSTU(11),*) 'C DX = ',DX
WRITE(MSTU(11),*) 'C DY = ',DY
WRITE(MSTU(11),*) 'C DS = ',DS
WRITE(MSTU(11),*) 'C '
DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
DQ2=DY/6D0-DX/3D0-DS/3D0
DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
DD2=DY/3D0+DX-2D0*DS/3D0
DL2=-DY/2D0+DX-2D0*DS/3D0
DE2=DY-DX/3D0-DS/3D0
DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
DHD2=-DY/2D0-2D0*DX/3D0+DS
DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
& /ABS(COS2B)
DMA2 = 2D0*DMU2+DHU2+DHD2
DO 150 I=1,5,2
KC=PYCOMP(KSUSY1+I)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
KC=PYCOMP(KSUSY2+I)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
KC=PYCOMP(KSUSY1+I+1)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
KC=PYCOMP(KSUSY2+I+1)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
150 CONTINUE
DO 160 I=11,15,2
KC=PYCOMP(KSUSY1+I)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
KC=PYCOMP(KSUSY2+I)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
KC=PYCOMP(KSUSY1+I+1)
PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
160 CONTINUE
IF(RMSS(4)**2+DMU2.LT.0D0) THEN
WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
CALL PYSTOP(104)
ENDIF
SGNMU=SIGN(1D0,RMSS(4))
RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
CALL PYSTOP(104)
ENDIF
RMSS(19)=SQRT(RMSS(19)**2+DMA2)
RMSS(6)=SQRT(RMSS(6)**2+DL2)
RMSS(7)=SQRT(RMSS(7)**2+DE2)
WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
ENDIF
C...Fix the third generation sfermions.
CALL PYTHRG
C...Fix the neutralino--chargino--gluino sector.
CALL PYINOM
C...Fix the Higgs sector.
CALL PYHGGM(ALFA)
C...Choose the Gunion-Haber convention.
ALFA=-ALFA
RMSS(18)=ALFA
C...Print information on mass parameters.
IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
WRITE(MSTU(11),*) ' TANB=',RMSS(5)
WRITE(MSTU(11),*) ' MU = ',RMSS(4)
WRITE(MSTU(11),*) ' AT = ',RMSS(16)
WRITE(MSTU(11),*) ' MA = ',RMSS(19)
WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
ENDIF
IF(IMSS(20).EQ.1) THEN
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
WRITE(MSTU(11),*) ' DEBUG MODE '
WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
& UMIX(2,1),UMIX(2,2)
WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
& UMIXI(2,1),UMIXI(2,2)
WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
& VMIX(2,1),VMIX(2,2)
WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
& VMIXI(2,1),VMIXI(2,2)
WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
WRITE(MSTU(11),*) ' ALFA = ',ALFA
WRITE(MSTU(11),*) ' BETA = ',BETA
WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
ENDIF
C...Set up the Higgs couplings - needed here since initialization
C...in PYINRE did not yet occur when PYWIDT is called below.
170 AL=ALFA
BE=BETA
SINA=SIN(AL)
COSA=COS(AL)
COSB=COS(BE)
SINB=TANB*COSB
SBMA=SIN(BE-AL)
SAPB=SIN(AL+BE)
CAPB=COS(AL+BE)
CBMA=COS(BE-AL)
C2A=COS(2D0*AL)
C2B=COSB**2-SINB**2
C...tanb (used for H+)
PARU(141)=TANB
C...Firstly: h
C...Coupling to d-type quarks
PARU(161)=SINA/COSB
C...Coupling to u-type quarks
PARU(162)=-COSA/SINB
C...Coupling to leptons
PARU(163)=PARU(161)
C...Coupling to Z
PARU(164)=SBMA
C...Coupling to W
PARU(165)=PARU(164)
C...Secondly: H
C...Coupling to d-type quarks
PARU(171)=-COSA/COSB
C...Coupling to u-type quarks
PARU(172)=-SINA/SINB
C...Coupling to leptons
PARU(173)=PARU(171)
C...Coupling to Z
PARU(174)=CBMA
C...Coupling to W
PARU(175)=PARU(174)
C...Coupling to h
IF(IMSS(4).GE.2) THEN
PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
ELSE
HHH(3)=HHH(3)+HHH(4)+HHH(5)
PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
ENDIF
C...Coupling to H+
C...Define later
IF(IMSS(4).GE.2) THEN
PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
ELSE
PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
ENDIF
C...Coupling to A
IF(IMSS(4).GE.2) THEN
PARU(177)=COS(2D0*BE)*COS(BE+AL)
ELSE
PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
ENDIF
C...Coupling to H+
IF(IMSS(4).GE.2) THEN
PARU(178)=PARU(177)
ELSE
PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
ENDIF
C...Thirdly, A
C...Coupling to d-type quarks
PARU(181)=TANB
C...Coupling to u-type quarks
PARU(182)=1D0/PARU(181)
C...Coupling to leptons
PARU(183)=PARU(181)
PARU(184)=0D0
PARU(185)=0D0
C...Coupling to Z h
PARU(186)=COS(BE-AL)
C...Coupling to Z H
PARU(187)=SIN(BE-AL)
PARU(188)=0D0
PARU(189)=0D0
PARU(190)=0D0
C...Finally: H+
C...Coupling to W h
PARU(195)=COS(BE-AL)
C...Tell that all Higgs couplings have been set.
MSTP(4)=1
C...Set R-Violating couplings.
C...Set lambda couplings to common value or "natural values".
IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
VIR3=1D0/(126D0)**3
DO 200 IRK=1,3
DO 190 IRI=1,3
DO 180 IRJ=1,3
IF (IRI.NE.IRJ) THEN
IF (IRI.LT.IRJ) THEN
RVLAM(IRI,IRJ,IRK)=RMSS(51)
IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
& SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
& PMAS(9+2*IRK,1)*VIR3)
ELSE
RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
ENDIF
ELSE
RVLAM(IRI,IRJ,IRK)=0D0
ENDIF
180 CONTINUE
190 CONTINUE
200 CONTINUE
ENDIF
C...Set lambda' couplings to common value or "natural values".
IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
VIR3=1D0/(126D0)**3
DO 230 IRI=1,3
DO 220 IRJ=1,3
DO 210 IRK=1,3
RVLAMP(IRI,IRJ,IRK)=RMSS(52)
IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
& SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
& PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
210 CONTINUE
220 CONTINUE
230 CONTINUE
ENDIF
C...Set lambda'' couplings to common value or "natural values".
IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
VIR3=1D0/(126D0)**3
DO 260 IRI=1,3
DO 250 IRJ=1,3
DO 240 IRK=1,3
IF (IRJ.NE.IRK) THEN
IF (IRJ.LT.IRK) THEN
RVLAMB(IRI,IRJ,IRK)=RMSS(53)
IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
& RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
& PMAS(2*IRK-1,1)*VIR3)
ELSE
RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
ENDIF
ELSE
RVLAMB(IRI,IRJ,IRK) = 0D0
ENDIF
240 CONTINUE
250 CONTINUE
260 CONTINUE
ENDIF
C...Antisymmetrize couplings set by user
IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
DO 290 IRI=1,3
DO 280 IRJ=1,3
DO 270 IRK=1,3
IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
ENDIF
IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
ENDIF
270 CONTINUE
280 CONTINUE
290 CONTINUE
ENDIF
C...Write spectrum to SLHA file
IF (IMSS(23).NE.0) THEN
IFAIL=0
CALL PYSLHA(3,0,IFAIL)
ENDIF
C...Second part of routine: set decay modes and branching ratios.
C...Allow chi10 -> gravitino + gamma or not.
KC=PYCOMP(KSUSY1+39)
IF( IMSS(11) .NE. 0 ) THEN
PMAS(KC,1)=RMSS(21)/1D9
PMAS(KC,2)=0D0
IRPRTY=0
WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
IRPRTY=0
IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
& ' ALLOWING SUSY LLE DECAYS'
IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
& ' ALLOWING SUSY LQD DECAYS'
IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
& ' ALLOWING SUSY UDD DECAYS'
IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
& ' --- Warning: R-Violating couplings possibly',
& ' incompatible with proton decay'
ELSE
PMAS(KC,1)=9999D0
IRPRTY=1
ENDIF
C...Loop over sparticle and Higgs species.
PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
C...Find the LSP or NLSP for a gravitino LSP
ILSP=0
PMLSP=1D20
DO 300 I=1,36
KF=KFSUSY(I)
IF(KF.EQ.1000039) GOTO 300
KC=PYCOMP(KF)
IF(PMAS(KC,1).LT.PMLSP) THEN
ILSP=I
PMLSP=PMAS(KC,1)
ENDIF
300 CONTINUE
DO 370 I=1,50
IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
KF=KFSUSY(I)
IF (KF.EQ.0) GOTO 370
KC=PYCOMP(KF)
LKNT=0
C...Check if there are any decays listed for this sparticle
C...in a file
IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
IFAIL=0
CALL PYSLHA(2,KF,IFAIL)
IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
ELSEIF (I.GE.37) THEN
GOTO 370
ENDIF
C...Sfermion decays.
IF(I.LE.24) THEN
C...First check to see if sneutrino is lighter than chi10.
IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
& PMAS(KC,1).LT.PMCHI1) THEN
ELSE
CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
ENDIF
C...Gluino decays.
ELSEIF(I.EQ.25) THEN
CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
C...Neutralino decays.
ELSEIF(I.GE.26.AND.I.LE.29) THEN
CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
C...chi10 stable or chi10 -> gravitino + gamma.
IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
PMAS(KC,2)=1D-6
MDCY(KC,1)=0
MWID(KC)=0
ENDIF
C...Chargino decays.
ELSEIF(I.GE.30.AND.I.LE.31) THEN
CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
C...Gravitino is stable.
ELSEIF(I.EQ.32) THEN
MDCY(KC,1)=0
MWID(KC)=0
C...Higgs decays.
ELSEIF(I.GE.33.AND.I.LE.36) THEN
C...Calculate decays to non-SUSY particles.
CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
LKNT=0
DO 310 I1=0,100
XLAM(I1)=0D0
310 CONTINUE
DO 330 I1=1,MDCY(KC,3)
K1=MDCY(KC,2)+I1-1
IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
& IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
XLAM(I1)=WDTP(I1)
XLAM(0)=XLAM(0)+XLAM(I1)
DO 320 J1=1,3
IDLAM(I1,J1)=KFDP(K1,J1)
320 CONTINUE
LKNT=LKNT+1
330 CONTINUE
C...Add the decays to SUSY particles.
CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
ENDIF
C...Zero the branching ratios for use in loop mode
C...thanks to K. Matchev (FNAL)
DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
BRAT(IDC)=0D0
340 CONTINUE
C...Set stable particles.
IF(LKNT.EQ.0) THEN
MDCY(KC,1)=0
MWID(KC)=0
PMAS(KC,2)=1D-6
PMAS(KC,3)=1D-5
PMAS(KC,4)=0D0
C...Store branching ratios in the standard tables.
ELSE
IDC=MDCY(KC,2)+MDCY(KC,3)-1
DELM=1D6
DO 360 IL=1,LKNT
IDCSV=IDC
350 IDC=IDC+1
BRAT(IDC)=0D0
IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
& KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
BRAT(IDC)=XLAM(IL)/XLAM(0)
XMDIF=PMAS(KC,1)
IF(MDME(IDC,1).GE.1) THEN
XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
& PMAS(PYCOMP(KFDP(IDC,2)),1)
IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
& PMAS(PYCOMP(KFDP(IDC,3)),1)
ENDIF
IF(I.LE.32) THEN
IF(XMDIF.GE.0D0) THEN
DELM=MIN(DELM,XMDIF)
ELSE
WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
WRITE(MSTU(11),*) ' KF = ',KF
WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
ENDIF
ENDIF
GOTO 360
ELSEIF(IDC.EQ.IDCSV) THEN
WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
& 'channel not recognized:'
WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
GOTO 360
ELSE
GOTO 350
ENDIF
360 CONTINUE
C...Store width, cutoff and lifetime.
PMAS(KC,2)=XLAM(0)
IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
PMAS(KC,3)=PMAS(KC,2)*10D0
ELSE
PMAS(KC,3)=0.95D0*DELM
ENDIF
IF(PMAS(KC,2).NE.0D0) THEN
PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
ENDIF
C...Write decays to SLHA file
IF (IMSS(24).NE.0) THEN
IFAIL=0
CALL PYSLHA(4,KF,IFAIL)
ENDIF
ENDIF
370 CONTINUE
RETURN
END
C*********************************************************************
C...PYSLHA
C...Read/write spectrum or decay data from SLHA standard file(s).
C...P. Skands
C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
C... (KFORIG=0 : read all decay tables)
C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
C... (KFORIG=0 : read all MASS entries)
SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
CHARACTER*40 ISAVER,VISAJE
COMMON/PYINT4/MWID(500),WIDS(500,5)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
C...SUSY blocks
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
C...Local arrays, character variables and data.
COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
& AU(3,3),AD(3,3),AE(3,3)
COMMON/PYLH3C/CPRO(2),CVER(2)
C...The common block of new states (QNUMBERS / PARTICLE)
COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
C...- NQNUM : Number of QNUMBERS blocks that have been read in
C...- KQNUM(I,0) : KF of new state
C...- KQNUM(I,1) : 3 times electric charge
C...- KQNUM(I,2) : Number of spin states: (2S + 1)
C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
C...- KQNUM(I,5:9) : space available for further quantum numbers
DIMENSION MMOD(100),MSPC(100),KFDEC(100)
SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
C...MMOD: flags to set for each block read in.
C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
C...MSPC: Flags to set for each block read in.
C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
C...11: AD 12: AE 13: YU 14: YD 15: YE
C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
CHARACTER CPRO*12,CVER*12,CHNLIN*6
CHARACTER DOC*11, CHDUM*120, CHBLCK*60
CHARACTER CHINL*120,CHKF*9,CHTMP*16
INTEGER VERBOS
SAVE VERBOS
C...Date of last Change
PARAMETER (DOC='10 Jun 2010')
C...Local arrays and initial values
DIMENSION IDC(5),KFSUSY(50)
SAVE KFSUSY
DATA NQNUM /0/
DATA NDECAY /0/
DATA VERBOS /1/
DATA NHELLO /0/
DATA MLHEF /0/
DATA MLHEFD /0/
DATA KFSUSY/
&1000001,1000002,1000003,1000004,1000005,1000006,
&2000001,2000002,2000003,2000004,2000005,2000006,
&1000011,1000012,1000013,1000014,1000015,1000016,
&2000011,2000012,2000013,2000014,2000015,2000016,
&1000021,1000022,1000023,1000025,1000035,1000024,
&1000037,1000039, 25, 35, 36, 37,
& 6, 24, 45, 46,1000045, 9*0/
DATA KFDEC/100*0/
RMFUN(IP)=PMAS(PYCOMP(IP),1)
C...Shorthand for spectrum and decay table unit numbers
IMSS21=IMSS(21)
IMSS22=IMSS(22)
C...Default for LHEF input: read header information
IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
C...Hello World
IF (NHELLO.EQ.0) THEN
IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
WRITE(MSTU(11),5000) DOC
NHELLO=1
ENDIF
ENDIF
C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
C...+MUPDA).
LFN=IMSS21
IF (MUPDA.EQ.2) LFN=IMSS22
IF (MUPDA.EQ.3) LFN=IMSS(23)
IF (MUPDA.EQ.4) LFN=IMSS(24)
C...Flag that we have not yet found whatever we were asked to find.
IRETRN=1
C...Flag that we are skipping until <slha> tag found (if LHEF)
ISKIP=0
IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
IF (LFN.EQ.0) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
GOTO 9999
ENDIF
C...If reading LHEF header, start by rewinding file
IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
C...If told to read spectrum, first zero all previous information.
IF (MUPDA.EQ.1) THEN
C...Zero all block read flags
DO 100 M=1,100
MMOD(M)=0
MSPC(M)=0
100 CONTINUE
C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
DO 110 ISUSY=1,36
KC=PYCOMP(KFSUSY(ISUSY))
PMAS(KC,1)=0D0
110 CONTINUE
C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
DO 130 J=1,4
SFMIX(5,J) =0D0
SFMIX(6,J) =0D0
SFMIX(15,J)=0D0
DO 120 L=1,4
ZMIX(L,J) =0D0
ZMIXI(L,J)=0D0
IF (J.LE.2.AND.L.LE.2) THEN
UMIX(L,J) =0D0
UMIXI(L,J)=0D0
VMIX(L,J) =0D0
VMIXI(L,J)=0D0
ENDIF
120 CONTINUE
C...Zero signed masses.
SMZ(J)=0D0
IF (J.LE.2) SMW(J)=0D0
130 CONTINUE
C...If reading decays, reset PYTHIA decay counters.
ELSEIF (MUPDA.EQ.2) THEN
C...Check if DECAY for this KF already read
IF (KFORIG.NE.0) THEN
DO 140 IDEC=1,NDECAY
IF (KFORIG.EQ.KFDEC(IDEC)) THEN
IRETRN=0
RETURN
ENDIF
140 CONTINUE
ENDIF
KCC=100
NDC=0
BRSUM=0D0
DO 150 KC=1,MSTU(6)
IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
150 CONTINUE
ELSEIF (MUPDA.EQ.5) THEN
C...Zero block read flags
DO 160 M=1,100
MSPC(M)=0
160 CONTINUE
ENDIF
C............READ
C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
C...Initialize program and version strings
IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
CPRO(MUPDA)=' '
CVER(MUPDA)=' '
ENDIF
C...Initialize read loop
MERR=0
NLINE=0
CHBLCK=' '
C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
170 CHINL=' '
READ(LFN,'(A120)',END=400) CHINL
C...Count which line number we're at.
NLINE=NLINE+1
WRITE(CHNLIN,'(I6)') NLINE
C...Skip comment and empty lines without processing.
IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
C...We assume all upper case below. Rewrite CHINL to all upper case.
INL=0
IGOOD=0
180 INL=INL+1
IF (CHINL(INL:INL).NE.'#') THEN
DO 190 ICH=97,122
IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
190 CONTINUE
C...Extra safety. Chek for sensible input on line
IF (IGOOD.EQ.0) THEN
DO 200 ICH=48,90
IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
200 CONTINUE
ENDIF
IF (INL.LT.120) GOTO 180
ENDIF
IF (IGOOD.EQ.0) GOTO 170
C...If reading from LHEF file, skip until <slha> begin tag found
IF (ISKIP.NE.0) THEN
DO 205 I1=1,10
IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
205 CONTINUE
IF (ISKIP.NE.0) GOTO 170
ENDIF
C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
DO 210 I1=1,10
IF (CHINL(I1:I1+5).EQ.'</SLHA'
& .OR.CHINL(I1:I1+5).EQ.'<EVENT'
& .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
REWIND(LFN)
GOTO 400
ENDIF
210 CONTINUE
C...Check for BLOCK begin statement (spectrum).
IF (CHINL(1:5).EQ.'BLOCK') THEN
MERR=0
READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
C...Check if another of this type of block was already read.
C...(logarithmic interpolation not yet implemented, so duplicates always
C...give errors)
IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
C...Check for new particles
IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
& THEN
MSPC(19)=MSPC(19)+1
C...Read PDG code
READ(CHBLCK(9:60),*) KFQ
DO 220 MQ=1,NQNUM
IF (KQNUM(MQ,0).EQ.KFQ) THEN
MERR=17
GOTO 380
ENDIF
220 CONTINUE
IF (NHELLO.EQ.0) THEN
WRITE(MSTU(11),5000) DOC
NHELLO=1
ENDIF
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
& ' for KF =',KFQ
NQNUM=NQNUM+1
KQNUM(NQNUM,0)=KFQ
MSPC(19)=MSPC(19)+1
KCQ=PYCOMP(KFQ)
C...Only read in new codes (also OK to overwrite if KF > 3000000)
IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
IF (KCQ.EQ.0) THEN
DO 230 KCT=100,MSTU(6)
IF(KCHG(KCT,4).GT.100) KCQ=KCT
230 CONTINUE
KCQ=KCQ+1
ENDIF
KCC=KCQ
KCHG(KCQ,4)=KFQ
C...First write PDG code as name
WRITE(CHTMP,*) KFQ
WRITE(CHTMP,'(A)') CHTMP(2:10)
C...Then look for real name
IBEG=9
240 IBEG=IBEG+1
IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
250 IBEG=IBEG+1
IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
IEND=IBEG-1
260 IEND=IEND+1
IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
IF (IEND.LT.59) THEN
READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
IF (CHDUM.NE.' ') CHTMP=CHDUM
ENDIF
270 READ(CHTMP,'(A)') CHAF(KCQ,1)
MSTU(20)=0
C...Set stable for now
PMAS(KCQ,2)=1D-6
MWID(KCQ)=0
MDCY(KCQ,1)=0
MDCY(KCQ,2)=0
MDCY(KCQ,3)=0
ELSE
WRITE(MSTU(11),*)
& '* (PYSLHA:) KF =',KFQ,' already exists: ',
& CHAF(KCQ,1), '. Entry ignored.'
MERR=7
ENDIF
ENDIF
C...Finalize this line and read next.
GOTO 380
C...Check for DECAY begin statement (decays).
ELSEIF (CHINL(1:3).EQ.'DEC') THEN
MERR=0
BRSUM=0D0
CHBLCK='DECAY'
C...Read KF code and WIDTH
MPSIGN=1
READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
IF (KF.LE.0) THEN
KF=-KF
MPSIGN=-1
ENDIF
C...If this is not the KF we're looking for...
IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
C...Set block skip flag and read next line.
MERR=16
GOTO 380
ELSE
C...Check whether decay table for this particle already read in
DO 280 IDECAY=1,NDECAY
IF (KFDEC(IDECAY).EQ.KF) THEN
WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
& ' * (PYSLHA:) Ignoring DECAY table ',
& 'for KF =',KF,' on line ',CHNLIN,
& ' (duplicate)'
MERR=16
GOTO 380
ENDIF
280 CONTINUE
ENDIF
C...Determine PYTHIA KC code of particle
KCREP=0
IF(KF.LE.100) THEN
KCREP=KF
ELSE
DO 290 KCR=101,KCC
IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
290 CONTINUE
ENDIF
KC=KCREP
IF (KCREP.NE.0) THEN
C...Particle is already known. Do not overwrite low-mass SM particles,
C...since this could give problems at hadronization / hadron decay stage.
IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
C...Set block skip flag and read next line
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Ignoring DECAY table for KF =',
& KF, ' (SLHA read-in not allowed)'
MERR=16
GOTO 380
ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24)
& THEN
C...Set block skip flag and read next line
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Allowing DECAY table for KF =',
& KF, ' but this is NOT recommended.'
ENDIF
ELSE
C... Add new particle. Actually, this should not happen.
C... New particles should be added already when reading the spectrum
C... information, so go under previously stable category.
KCC=KCC+1
KC=KCC
ENDIF
IF (WIDTH.LE.0D0) THEN
C...Stable (i.e. LSP)
WRITE(MSTU(11),'(A,I9,A,A)')
& ' * (PYSLHA:) Reading SLHA stable particle KF =',
& KF,', ',CHAF(KCREP,1)(1:16)
IF (WIDTH.LT.0D0) THEN
CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
& ' zero !')
WIDTH=0D0
ENDIF
PMAS(KC,2)=1D-6
MWID(KC)=0
MDCY(KC,1)=0
C...Ignore any decay lines that may be present for this KF
MERR=16
MDCY(KC,2)=0
MDCY(KC,3)=0
C...Return ok
IRETRN=0
ENDIF
C...Finalize and start reading in decay modes.
GOTO 380
ELSEIF (MOD(MERR,10).GE.6) THEN
C...If ignore block flag set, skip directly to next line.
GOTO 170
ENDIF
C...READ SPECTRUM
IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
& THEN
READ(CHINL,*) INDX, IVAL
IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
IF (INDX.EQ.3) KCHG(KCQ,2)=0
IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
IF (INDX.EQ.4) THEN
KCHG(KCQ,3)=IVAL
IF (IVAL.EQ.1) THEN
CHTMP=CHAF(KCQ,1)
IF (CHTMP.EQ.' ') THEN
WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
ELSE
ILAST=17
300 ILAST=ILAST-1
IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
CHTMP(ILAST:ILAST)='-'
ELSE
CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
ENDIF
CHAF(KCQ,2)=CHTMP
ENDIF
ENDIF
ENDIF
ELSE
MERR=8
ENDIF
ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
C...MASS: Mass spectrum
IF (CHBLCK(1:4).EQ.'MASS') THEN
READ(CHINL,*) KF, VAL
MERR=1
KC=0
IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
C...Read in masses for almost anything
MERR=0
KC=PYCOMP(KF)
IF (KC.NE.0) THEN
C...Don't read in masses for special code particles
IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Ignoring MASS entry for KF =',
& KF, ' (KF reserved by PYTHIA)'
GOTO 170
ENDIF
C...Be careful with light SM particles / hadrons
IF (PMAS(KC,1).LE.20D0) THEN
IF (IABS(KF).LE.22) THEN
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Ignoring MASS entry for KF =',
& KF, ' (SLHA read-in not allowed)'
GOTO 170
ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Ignoring MASS entry for KF =',
& KF, ' (SLHA read-in not allowed)'
GOTO 170
ENDIF
ENDIF
MSPC(1)=MSPC(1)+1
PMAS(KC,1) = ABS(VAL)
IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Reading MASS entry for KF =',
& KF, ', pole mass =', VAL
IRETRN=0
ENDIF
C...Check Z, W and top masses
IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
& THEN
WRITE(CHTMP,8500) PMAS(PYCOMP(23),1)
CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
& //CHTMP)
ENDIF
IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
& THEN
WRITE(CHTMP,8500) PMAS(PYCOMP(24),1)
CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
& //CHTMP)
ENDIF
IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
& THEN
WRITE(CHTMP,8500) PMAS(PYCOMP(6),1)
CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
& //CHTMP//'GeV')
ENDIF
C... Signed masses
IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
IF (KF.EQ.1000022) SMZ(1)=VAL
IF (KF.EQ.1000023) SMZ(2)=VAL
IF (KF.EQ.1000025) SMZ(3)=VAL
IF (KF.EQ.1000035) SMZ(4)=VAL
IF (KF.EQ.1000024) SMW(1)=VAL
IF (KF.EQ.1000037) SMW(2)=VAL
ENDIF
ELSEIF (MUPDA.EQ.5) THEN
MERR=0
ENDIF
C... MODSEL: Model selection and global switches
ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
READ(CHINL,*) INDX, IVAL
IF (INDX.LE.200.AND.INDX.GT.0) THEN
IF (IMSS(1).EQ.0) IMSS(1)=11
MODSEL(INDX)=IVAL
MMOD(1)=MMOD(1)+1
IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
C... Switch on NMSSM
WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
IMSS(13)=MAX(1,IMSS(13))
C... Add NMSSM states if not already done
KFN=25
KCN=KFN
CHAF(KCN,1)='h_10'
CHAF(KCN,2)=' '
KFN=35
KCN=KFN
CHAF(KCN,1)='h_20'
CHAF(KCN,2)=' '
KFN=45
KCN=KFN
CHAF(KCN,1)='h_30'
CHAF(KCN,2)=' '
KFN=36
KCN=KFN
CHAF(KCN,1)='A_10'
CHAF(KCN,2)=' '
KFN=46
KCN=KFN
CHAF(KCN,1)='A_20'
CHAF(KCN,2)=' '
KFN=1000045
KCN=PYCOMP(KFN)
IF (KCN.EQ.0) THEN
DO 310 KCT=100,MSTU(6)
IF(KCHG(KCT,4).GT.100) KCN=KCT
310 CONTINUE
KCN=KCN+1
KCHG(KCN,4)=KFN
MSTU(20)=0
ENDIF
C... Set stable for now
PMAS(KCN,2)=1D-6
MWID(KCN)=0
MDCY(KCN,1)=0
MDCY(KCN,2)=0
MDCY(KCN,3)=0
CHAF(KCN,1)='~chi_50'
CHAF(KCN,2)=' '
ENDIF
ELSE
MERR=1
ENDIF
ELSEIF (MUPDA.EQ.5) THEN
C...If MUPDA = 5, skip all except MASS, return if MODSEL
MERR=8
ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
& CHBLCK(1:8).EQ.'PARTICLE') THEN
C...Don't print a warning for QNUMBERS when reading spectrum
MERR=8
C...MINPAR: Minimal model parameters
ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
READ(CHINL,*) INDX, VAL
IF (INDX.LE.100.AND.INDX.GT.0) THEN
PARMIN(INDX)=VAL
MMOD(2)=MMOD(2)+1
ELSE
MERR=1
ENDIF
IF (MMOD(3).NE.0) THEN
WRITE(MSTU(11),*)
& '* (PYSLHA:) MINPAR should come before EXTPAR !'
MERR=1
ENDIF
C...tan(beta)
IF (INDX.EQ.3) RMSS(5)=VAL
C...EXTPAR: non-minimal model parameters.
ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
IF (MMOD(1).NE.0) THEN
READ(CHINL,*) INDX, VAL
IF (INDX.LE.200.AND.INDX.GT.0) THEN
PAREXT(INDX)=VAL
MMOD(3)=MMOD(3)+1
ELSE
MERR=1
ENDIF
ELSE
WRITE(MSTU(11),*)
& '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
MERR=1
ENDIF
C...tan(beta)
IF (INDX.EQ.25) RMSS(5)=VAL
ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
READ(CHINL,*) INDX, VAL
IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
MERR=1
ELSEIF (INDX.EQ.4) THEN
PMAS(PYCOMP(23),1)=VAL
ELSEIF (INDX.EQ.6) THEN
PMAS(PYCOMP(6),1)=VAL
ENDIF
ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
$ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
$ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
$ THEN
C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
IM=0
IF (CHBLCK(5:6).EQ.'IM') IM=1
320 READ(CHINL,*) INDX1, INDX2, VAL
IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
MSPC(2)=MSPC(2)+1
ELSEIF (CHBLCK(1:1).EQ.'U') THEN
IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
MSPC(3)=MSPC(3)+1
ELSEIF (CHBLCK(1:1).EQ.'V') THEN
IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
MSPC(4)=MSPC(4)+1
ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
$ .CHBLCK(1:4).EQ.'STAU') THEN
IF (CHBLCK(1:4).EQ.'STOP') THEN
KFSM=6
ISPC=6
ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
KFSM=5
ISPC=5
ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
KFSM=15
ISPC=7
ENDIF
C...Set SFMIX element
SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
MSPC(ISPC)=MSPC(ISPC)+1
ENDIF
C...Running parameters
ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
READ(CHBLCK(8:25),*,ERR=620) Q
READ(CHINL,*) INDX, VAL
MSPC(8)=MSPC(8)+1
IF (INDX.EQ.1) THEN
RMSS(4) = VAL
ELSE
MERR=1
MSPC(8)=MSPC(8)-1
ENDIF
ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
READ(CHINL,*,ERR=630) VAL
RMSS(18)= VAL
MSPC(17)=MSPC(17)+1
C...Higgs parameters set manually or with FeynHiggs.
IMSS(4)=MAX(2,IMSS(4))
ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
& .CHBLCK(1:2).EQ.'AE') THEN
READ(CHBLCK(9:26),*,ERR=620) Q
READ(CHINL,*) INDX1, INDX2, VAL
IF (CHBLCK(2:2).EQ.'U') THEN
AU(INDX1,INDX2)=VAL
IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
MSPC(11)=MSPC(11)+1
ELSEIF (CHBLCK(2:2).EQ.'D') THEN
AD(INDX1,INDX2)=VAL
IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
MSPC(10)=MSPC(10)+1
ELSEIF (CHBLCK(2:2).EQ.'E') THEN
AE(INDX1,INDX2)=VAL
IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
MSPC(12)=MSPC(12)+1
ELSE
MERR=1
ENDIF
ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
IF (MSPC(18).EQ.0) THEN
READ(CHBLCK(9:25),*,ERR=620) Q
RMSOFT(0)=Q
ENDIF
READ(CHINL,*) INDX, VAL
RMSOFT(INDX)=VAL
MSPC(18)=MSPC(18)+1
ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
MERR=8
ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
& .CHBLCK(1:2).EQ.'YE') THEN
MERR=8
ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
READ(CHINL(1:6),*) INDX
IT=0
MIRD=0
330 IT=IT+1
IF (CHINL(IT:IT).EQ.' ') GOTO 330
C...Don't read index
IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
MIRD=1
GOTO 330
ENDIF
IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
ELSE
C... Set unrecognized block flag.
MERR=6
ENDIF
C...DECAY TABLES
C...Read in decay information
ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
C...Read new decay chanel
IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
NDC=NDC+1
C...Read in branching ratio and number of daughters for this mode.
READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
READ(CHINL(4:50),*,ERR=600) DUM, NDA
IF (NDA.LE.5) THEN
IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
& '(PYSLHA:) Decay data arrays full by KF = '
$ //CHAF(KC,1))
C...If first decay channel, set decays start point in decay table
IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
& '* (PYSLHA:) Reading DECAY table for '//
& 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
C...Set particle parameters (mass set when reading BLOCK MASS above)
PMAS(KC,2)=WIDTH
IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
WRITE(MSTU(11),'(1x,A)')
& '* Note: the Pythia gg->h/H/A cross section'//
& ' is proportional to the h/H/A->gg width'
ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
& .OR.KF.EQ.33.OR.KF.EQ.34) THEN
WRITE(MSTU(11),'(1x,A,A16)')
& '* Warning: will use DECAY table (fixed-width,'//
& ' flat PS) for ',CHAF(KC,1)(1:16)
ENDIF
PMAS(KC,3)=0D0
PMAS(KC,4)=PARU(3)*1D-12/WIDTH
MWID(KC)=2
MDCY(KC,1)=1
MDCY(KC,2)=NDC
MDCY(KC,3)=0
C...Add to list of DECAY blocks currently read
NDECAY=NDECAY+1
KFDEC(NDECAY)=KF
C...Return ok
IRETRN=0
ENDIF
C... Count up number of decay modes for this particle
MDCY(KC,3)=MDCY(KC,3)+1
C... Read in decay daughters.
READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
C... Flip sign if reading antiparticle decays (if antipartner exists)
DO 340 IDA=1,NDA
IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
& IDC(IDA)=MPSIGN*IDC(IDA)
340 CONTINUE
C...Switch on decay channel, with products ordered in decreasing ABS(KF)
MDME(NDC,1)=1
IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
BRSUM=BRSUM+ABS(BRAT(NDC))
BRAT(NDC)=ABS(BRAT(NDC))
350 IFLIP=0
DO 360 IDA=1,NDA-1
IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
ITMP=IDC(IDA)
IDC(IDA)=IDC(IDA+1)
IDC(IDA+1)=ITMP
IFLIP=IFLIP+1
ENDIF
360 CONTINUE
IF (IFLIP.GT.0) GOTO 350
C...Treat as ordinary decay, no fancy stuff.
MDME(NDC,2)=0
DO 370 IDA=1,5
IF (IDA.LE.NDA) THEN
KFDP(NDC,IDA)=IDC(IDA)
ELSE
KFDP(NDC,IDA)=0
ENDIF
370 CONTINUE
C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
C & (KFDP(NDC,J),J=1,NDA)
ELSE
CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
& CHNLIN)
MERR=11
NDC=NDC-1
ENDIF
ELSEIF(CHINL(1:1).EQ.'+') THEN
MERR=11
ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
MERR=16
ELSE
MERR=16
ENDIF
ENDIF
C... Error check.
380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
& //CHINL(1:40)
MERR=0
ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
& CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
& //CHBLCK(1:INL)//'... on line'//CHNLIN
ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
& CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
& //'... on line'//CHNLIN
ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
& /CHBLCK(1:INL)//'... on line'//CHNLIN
ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
WRITE (CHTMP,*) KF
WRITE(MSTU(11),*)
& '* (PYSLHA:) Ignoring extra MASS entry for KF='//
& CHTMP(1:9)//' on line'//CHNLIN
ENDIF
C...Iterate read loop
GOTO 170
C...Error catching
390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
& ', ignoring subsequent lines.'
WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
CHBLCK=' '
GOTO 170
C...End of read loop
400 CONTINUE
C...Set flag that KC codes have been rearranged.
MSTU(20)=0
VERBOS=0
C...Perform possible tests that new information is consistent.
IF (MUPDA.EQ.1) THEN
MSTU23=MSTU(23)
MSTU27=MSTU(27)
C...Check masses
DO 410 ISUSY=1,37
KF=KFSUSY(ISUSY)
C...Don't complain about right-handed neutrinos
IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
& +16) GOTO 410
C...Only check gravitino in GMSB scenarios
IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
KC=PYCOMP(KF)
IF (PMAS(KC,1).EQ.0D0) THEN
WRITE(CHTMP,*) KF
CALL PYERRM(9
& ,'(PYSLHA:) No mass information found for KF ='
& //CHTMP)
ENDIF
410 CONTINUE
C...Check mixing matrices (MSSM only)
IF (IMSS(13).EQ.0) THEN
IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in NMIX')
IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in UMIX')
IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in VMIX')
IF (MSPC(5).NE.4) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
IF (MSPC(6).NE.4) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
IF (MSPC(7).NE.4) CALL PYERRM(9
& ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
IF (MSPC(8).LT.1) CALL PYERRM(9
& ,'(PYSLHA:) Too few elements in HMIX')
IF (MSPC(10).EQ.0) CALL PYERRM(9
& ,'(PYSLHA:) Missing A_b trilinear coupling')
IF (MSPC(11).EQ.0) CALL PYERRM(9
& ,'(PYSLHA:) Missing A_t trilinear coupling')
IF (MSPC(12).EQ.0) CALL PYERRM(9
& ,'(PYSLHA:) Missing A_tau trilinear coupling')
IF (MSPC(17).LT.1) CALL PYERRM(9
& ,'(PYSLHA:) Missing Higgs mixing angle alpha')
ENDIF
C...Check wavefunction normalizations.
C...Sfermions
DO 420 ISPC=5,7
IF (MSPC(ISPC).EQ.4) THEN
KFSM=ISPC
IF (ISPC.EQ.7) KFSM=15
CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
& *SFMIX(KFSM,3))
IF (ABS(1D0-CHECK).GT.1D-3) THEN
KCSM=PYCOMP(KFSM)
CALL PYERRM(17
& ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
& //CHAF(KCSM,1))
ENDIF
C...Bug fix 30/09 2008: PS
C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
SFMIX(KFSM,3) = -SFMIX(KFSM,3)
SFMIX(KFSM,4) = -SFMIX(KFSM,4)
ENDIF
ENDIF
420 CONTINUE
C...Neutralinos + charginos
DO 440 J=1,4
CN1=0D0
CN2=0D0
CU1=0D0
CU2=0D0
CV1=0D0
CV2=0D0
DO 430 L=1,4
CN1=CN1+ZMIX(J,L)**2
CN2=CN2+ZMIX(L,J)**2
IF (J.LE.2.AND.L.LE.2) THEN
CU1=CU1+UMIX(J,L)**2
CU2=CU2+UMIX(L,J)**2
CV1=CV1+VMIX(J,L)**2
CV2=CV2+VMIX(L,J)**2
ENDIF
430 CONTINUE
C...NMIX normalization
IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
& .GT.1D-3).AND.IMSS(13).EQ.0) THEN
CALL PYERRM(19,
& '(PYSLHA:) NMIX: Inconsistent normalization.')
WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
ENDIF
C...UMIX, VMIX normalizations
IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
IF (J.LE.2) THEN
IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
CALL PYERRM(19
& ,'(PYSLHA:) UMIX: Inconsistent normalization.')
WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
& CU2
ENDIF
IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
CALL PYERRM(19,
& '(PYSLHA:) VMIX: Inconsistent normalization.')
WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
& CV2
ENDIF
ENDIF
ENDIF
440 CONTINUE
IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
& '* (PYSLHA:) No spectrum inconsistencies were found.'
ELSE
WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
& '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
& ,' Warning: one or more (serious)'//
& ' inconsistencies were found in the spectrum !'
& ,' Read the error messages above and check your'//
& ' input file.'
ENDIF
C...Increase precision in Higgs sector using FeynHiggs
IF (IMSS(4).EQ.3) THEN
C...FeynHiggs needs MSOFT.
IERR=0
IF (MSPC(18).EQ.0) THEN
WRITE(MSTU(11),'(1x,"*"/1x,A/)')
& '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
& ' Cannot call FeynHiggs.'
IERR=-1
ELSE
WRITE(MSTU(11),'(1x,/1x,A/)')
& '* (PYSLHA:) Now calling FeynHiggs.'
CALL PYFEYN(IERR)
IF (IERR.NE.0) IMSS(4)=2
ENDIF
ENDIF
ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
IBEG=1
IF (KFORIG.NE.0) IBEG=NDECAY
DO 490 IDECAY=IBEG,NDECAY
KF = KFDEC(IDECAY)
KC = PYCOMP(KF)
WRITE(CHKF,8300) KF
IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
$ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
$ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
$ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
$ //CHKF)
BRSUM=0D0
BROPN=0D0
DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
IF(MDME(IDA,2).GT.80) GOTO 460
KQ=KCHG(KC,1)
PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
MERR=0
DO 450 J=1,5
KP=KFDP(IDA,J)
IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
IF(KP.EQ.81) KQ=0
ELSEIF(PYCOMP(KP).EQ.0) THEN
MERR=3
ELSE
KQ=KQ-PYCHGE(KP)
KPC=PYCOMP(KP)
PMS=PMS-PMAS(KPC,1)
IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
& PMAS(KPC,3))
ENDIF
450 CONTINUE
IF(KQ.NE.0) MERR=MAX(2,MERR)
IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
& MERR=MAX(1,MERR)
IF(MERR.EQ.3) CALL PYERRM(17,
& '(PYSLHA:) Unknown particle code in decay of KF ='
$ //CHKF)
IF(MERR.EQ.2) CALL PYERRM(17,
& '(PYSLHA:) Charge not conserved in decay of KF ='
$ //CHKF)
IF(MERR.EQ.1) CALL PYERRM(7,
& '(PYSLHA:) Kinematically unallowed decay of KF ='
$ //CHKF)
BRSUM=BRSUM+BRAT(IDA)
IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
460 CONTINUE
C...Check branching ratio sum.
IF (BROPN.LE.0D0) THEN
C...If zero, set stable.
WRITE(CHTMP,8500) BROPN
CALL PYERRM(7
& ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
& CHTMP(9:16)//'. Changed to stable.')
PMAS(KC,2)=1D-6
MWID(KC)=0
C...If BR's > 1, rescale.
ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
WRITE(CHTMP,8500) BRSUM
IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
& ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
& ' ; sum was'//CHTMP(9:16)//'.')
FAC=1D0/BRSUM
DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
IF(MDME(IDA,2).GT.80) GOTO 470
BRAT(IDA)=FAC*BRAT(IDA)
470 CONTINUE
ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
C...If BR's < 1, insert dummy mode for proper cross section rescaling.
WRITE(CHTMP,8500) BRSUM
IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
& ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
& CHTMP(9:16)//'. Dummy mode will be inserted.')
C...Move table and insert dummy mode
DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
NDC=NDC+1
BRAT(NDC)=BRAT(IDA)
KFDP(NDC,1)=KFDP(IDA,1)
KFDP(NDC,2)=KFDP(IDA,2)
KFDP(NDC,3)=KFDP(IDA,3)
KFDP(NDC,4)=KFDP(IDA,4)
KFDP(NDC,5)=KFDP(IDA,5)
MDME(NDC,1)=MDME(IDA,1)
480 CONTINUE
NDC=NDC+1
BRAT(NDC)=1D0-BRSUM
KFDP(NDC,1)=0
KFDP(NDC,2)=0
KFDP(NDC,3)=0
KFDP(NDC,4)=0
KFDP(NDC,5)=0
MDME(NDC,1)=0
BRSUM=1D0
C...Update MDCY
MDCY(KC,3)=MDCY(KC,3)+1
MDCY(KC,2)=NDC-MDCY(KC,3)+1
ENDIF
490 CONTINUE
ENDIF
C...WRITE SPECTRUM ON SLHA FILE
ELSEIF(MUPDA.EQ.3) THEN
C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
MODSEL(1)=1
PARMIN(1)=RMSS(8)
PARMIN(2)=RMSS(1)
PARMIN(3)=RMSS(5)
PARMIN(4)=SIGN(1D0,RMSS(4))
PARMIN(5)=RMSS(36)
ENDIF
C...Write spectrum
WRITE(LFN,7000) 'SLHA MSSM spectrum'
WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
& // ' P. Skands.'
WRITE(LFN,7010) 'MODSEL', 'Model selection'
WRITE(LFN,7110) 1, MODSEL(1)
WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
IF (MODSEL(1).EQ.1) THEN
WRITE(LFN,7210) 1, PARMIN(1), 'm0'
WRITE(LFN,7210) 2, PARMIN(2), 'm12'
WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
WRITE(LFN,7210) 5, PARMIN(5), 'a0'
ELSEIF(MODSEL(2).EQ.2) THEN
WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
WRITE(LFN,7210) 2, PARMIN(2), 'M'
WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
WRITE(LFN,7210) 5, PARMIN(5), 'N5'
WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
ENDIF
WRITE(LFN,7000) ' '
WRITE(LFN,7010) 'MASS', 'Mass spectrum'
DO 500 I=1,36
KF=KFSUSY(I)
KC=PYCOMP(KF)
IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
KFSM=KF-KSUSY1
IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
ELSE
WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
ENDIF
500 CONTINUE
C...SUSY scale
RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
WRITE(LFN,7210) 1, RMSS(4),'mu'
WRITE(LFN,7010) 'ALPHA',' '
C WRITE(LFN,7210) 1, RMSS(18), 'alpha'
WRITE(LFN,7200) RMSS(18), 'alpha'
WRITE(LFN,7020) 'AU',RMSUSY
WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
WRITE(LFN,7020) 'AD',RMSUSY
WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
WRITE(LFN,7020) 'AE',RMSUSY
WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
WRITE(LFN,7410) 1, 1, SFMIX(6,1)
WRITE(LFN,7410) 1, 2, SFMIX(6,2)
WRITE(LFN,7410) 2, 1, SFMIX(6,3)
WRITE(LFN,7410) 2, 2, SFMIX(6,4)
WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
WRITE(LFN,7410) 1, 1, SFMIX(5,1)
WRITE(LFN,7410) 1, 2, SFMIX(5,2)
WRITE(LFN,7410) 2, 1, SFMIX(5,3)
WRITE(LFN,7410) 2, 2, SFMIX(5,4)
WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
WRITE(LFN,7410) 1, 1, SFMIX(15,1)
WRITE(LFN,7410) 1, 2, SFMIX(15,2)
WRITE(LFN,7410) 2, 1, SFMIX(15,3)
WRITE(LFN,7410) 2, 2, SFMIX(15,4)
WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
DO 520 I1=1,4
DO 510 I2=1,4
WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
510 CONTINUE
520 CONTINUE
WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
DO 540 I1=1,2
DO 530 I2=1,2
WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
530 CONTINUE
540 CONTINUE
WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
DO 560 I1=1,2
DO 550 I2=1,2
WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
550 CONTINUE
560 CONTINUE
WRITE(LFN,7010) 'SPINFO'
IF (IMSS(1).EQ.2) THEN
CPRO(1)='PYTHIA'
CVER(1)='6.4'
ELSEIF (IMSS(1).EQ.12) THEN
ISAVER=VISAJE()
CPRO(1)='ISASUSY'
CVER(1)=ISAVER(1:12)
ENDIF
WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
WRITE(LFN,7310) 2, CVER(1), 'Version number'
ENDIF
C...Print user information about spectrum
IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
& WRITE(MSTU(11),5030) CPRO(1), CVER(1)
IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
IF (MUPDA.EQ.1) THEN
WRITE(MSTU(11),5020) LFN
ELSE
WRITE(MSTU(11),5010) LFN
ENDIF
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500) 'Pole masses'
WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
$ ,(RMFUN(KSUSY2+IP),IP=1,6)
WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
$ ,(RMFUN(KSUSY2+IP),IP=11,16)
IF (IMSS(13).EQ.0) THEN
WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
$ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
$ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
& CHAF(37,1), ' ', ' ',' ',' ',
& RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
ELSEIF (IMSS(13).EQ.1) THEN
KF1=KSUSY1+21
KF2=KSUSY1+22
KF3=KSUSY1+23
KF4=KSUSY1+25
KF5=KSUSY1+35
KF6=KSUSY1+45
KF7=KSUSY1+24
KF8=KSUSY1+37
WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
& CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
& CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
& CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
& RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
& RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
& CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
& RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
& RMFUN(37)
ENDIF
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500) 'Mixing structure'
WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
& ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
& ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
& ),(SFMIX(15,J),J=3,4)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500) 'Couplings'
WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),6500)
C...DECAY TABLES writeout
C...Write decay information by Nils-Erik Bomark 3/29/2010
ELSEIF (MUPDA.EQ.4) THEN
KF = KFORIG
KC = PYCOMP(KF)
IF (KC.NE.0) THEN
WRITE(LFN,7000) ''
WRITE(LFN,7000) ' PDG Width'
WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
WRITE(LFN,7000)
& ' BR NDA ID1 ID2 ID3'
DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
NDA = 0
DO 570 J=1,5
IF (KFDP(I,J).NE.0) NDA = NDA+1
570 CONTINUE
IF (NDA.EQ.2)
& WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
& CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
& (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
IF (NDA.EQ.3)
& WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
& CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
& (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
IF (NDA.EQ.4)
& WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
& CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
& (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
IF (NDA.EQ.5)
& WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
& CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
& (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
575 CONTINUE
ENDIF
C....End of DECAY TABLES writeout
ENDIF
C...Only rewind when reading
IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
9999 RETURN
C...Serious error catching
580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
write(*,*) CHINL(1:80)
CALL PYSTOP(106)
590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
WRITE(*,*) CHINL(1:72)
CALL PYSTOP(106)
600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
WRITE(*,*) CHINL(1:80)
CALL PYSTOP(106)
610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
WRITE(*,*) CHINL(1:80)
620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
CALL PYSTOP(106)
630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
WRITE(*,*) CHINL(1:80)
CALL PYSTOP(106)
8300 FORMAT(I9)
8500 FORMAT(F16.5)
C...Formats for user information printout.
5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM '
& ,'INTERFACE',1x,17('*')/1x,'*',1x
& ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
& 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
& ,'----------------')
5400 FORMAT(1x,'*',1x,A)
5500 FORMAT(1x,'*',1x,A,':')
5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
& 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
& 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
& ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
& ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
& ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
& ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
& ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
& ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
& ,1x,F6.3,1x),'|')
6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
& ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
& ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
& ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
& ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
& ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
& ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
& 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
& ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
& 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
& ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
& ,'A_tau = ',F8.2)
6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
& ,' mu = ',F8.2)
6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
C...Format to use for comments
7000 FORMAT('# ',A)
C...Format to use for block statements
7010 FORMAT('Block',1x,A,3x,'#',1x,A)
7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Int
7110 FORMAT(1x,I4,1x,I4,3x,'#')
C...Non-Indexed Double
7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Double
7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Long Indexed Double (PDG + double)
7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Char(12)
7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
C...Single matrix
7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Double Matrix
7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
C...Write Decay Table
7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A)
7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
& '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
& '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
& '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
& '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
END
C*********************************************************************
C...PYAPPS
C...Uses approximate analytical formulae to determine the full set of
C...MSSM parameters from SUGRA input.
C...See M. Drees and S.P. Martin, hep-ph/9504124
SUBROUTINE PYAPPS
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
&' not intended for serious physics studies'
IMSS(5)=0
IMSS(8)=0
XMT=PMAS(6,1)
XMZ2=PMAS(23,1)**2
XMW2=PMAS(24,1)**2
TANB=RMSS(5)
BETA=ATAN(TANB)
XW=PARU(102)
XMG=RMSS(1)
XMG2=XMG*XMG
XM0=RMSS(8)
XM02=XM0*XM0
C...Temporary sign change for AT. Others unchanged.
AT=-RMSS(16)
RMSS(15)=RMSS(16)
RMSS(17)=RMSS(16)
SINB=TANB/SQRT(TANB**2+1D0)
COSB=SINB/TANB
DTERM=XMZ2*COS(2D0*BETA)
XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
RMSS(6)=XMEL
RMSS(7)=XMER
XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
DO 100 I=1,5,2
PMAS(PYCOMP(KSUSY1+I),1)=XMDL
PMAS(PYCOMP(KSUSY2+I),1)=XMDR
PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
100 CONTINUE
XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
IF(XARG.LT.0D0) THEN
WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
& ' FROM THE SUM RULE. '
WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
RETURN
ELSE
XARG=SQRT(XARG)
ENDIF
DO 110 I=11,15,2
PMAS(PYCOMP(KSUSY1+I),1)=XMEL
PMAS(PYCOMP(KSUSY2+I),1)=XMER
PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
110 CONTINUE
RMT=PYMRUN(6,PMAS(6,1)**2)
XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
&(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
RMB=PYMRUN(5,PMAS(6,1)**2)
XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
&(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
&SINB)**2)
RMSS(16)=-ATP
XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
&COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
XMU=SIGN(SQRT(XMU2),RMSS(4))
RMSS(4)=XMU
IF(XMA2.GT.0D0) THEN
RMSS(19)=SQRT(XMA2)
ELSE
WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
CALL PYSTOP(102)
ENDIF
ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
IF(ARG.GT.0D0) THEN
RMSS(14)=SQRT(ARG)
ELSE
WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
CALL PYSTOP(102)
ENDIF
ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
IF(ARG.GT.0D0) THEN
RMSS(13)=SQRT(ARG)
ELSE
WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
CALL PYSTOP(102)
ENDIF
ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
IF(ARG.GT.0D0) THEN
RMSS(10)=SQRT(ARG)
ELSE
RMSS(10)=-SQRT(-ARG)
ENDIF
ARG=PYRNMQ(2,-2D0*XTOP/3D0)
IF(ARG.GT.0D0) THEN
RMSS(12)=SQRT(ARG)
ELSE
RMSS(12)=-SQRT(-ARG)
ENDIF
ARG=PYRNMQ(3,-2D0*XBOT/3D0)
IF(ARG.GT.0D0) THEN
RMSS(11)=SQRT(ARG)
ELSE
RMSS(11)=-SQRT(-ARG)
ENDIF
RETURN
END
C*********************************************************************
C...PYSUGI
C...Interface to ISASUSY version 7.71.
C...Warning: this interface should not be used with earlier versions
C...of ISASUSY, since common block incompatibilities may then arise.
C...Calls SUGRA (in ISAJET) to perform RGE evolution.
C...Then converts to Gunion-Haber conventions.
SUBROUTINE PYSUGI
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Date of Change
CHARACTER DOC*11
PARAMETER (DOC='01 May 2006')
C...ISASUGRA Input:
REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
C...XISAIN contains the MSSMi inputs in natural order.
COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
$XAMIN(7)
REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
SAVE /SUGXIN/
C...ISASUGRA Output
CHARACTER*40 ISAVER,VISAJE
REAL SUPER
COMMON /SSPAR/ SUPER(72)
COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
$FBGUT,FTAGUT,FNGUT
REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
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,ASM3,
$VUMT,VDMT,ASMTP,ASMSS,M3Q
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
INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
INTEGER IALLOW
SAVE /SUGMG/,/SSPAR/
C SUPER: Filled by ISASUGRA.
C SUPER(1) = mass of ~g
C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
C ,~tau_2
C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
C SUPER(29) = Higgsino mass = - mu
C SUPER(30) = ratio v2/v1 of vev's
C SUPER(31:34) = Signed neutralino masses
C SUPER(35:50) = Neutralino mixing matrix
C SUPER(51:52) = Signed chargino masses
C SUPER(53:54) = Chargino left, right mixing angles
C SUPER(55:58) = mass of h0, H0, A0, H+
C SUPER(59) = Higgs mixing angle alpha
C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
C SUPER(66) = Gravitino mass
C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
C SUPER(70) = b-Yukawa at mA scale (not used)
C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
C GSS: Filled by ISASUGRA
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_h12 GSS(14) = M_h22 GSS(15) = M_er2
C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
C GSS(31) = log(vuq)
C MSS: Filled by ISASUGRA
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, filled by ISASUGRA if applicable.
C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
C...SPYTHIA Input/Output
INTEGER IMSS
DOUBLE PRECISION RMSS
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C...SLHA Input/Output
COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
& AU(3,3),AD(3,3),AE(3,3)
C...PYTHIA common blocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
INTEGER IMODEL
REAL M0,MHF,A0,MT
CHARACTER*20 CHMOD(5)
CHARACTER*32 FNAME
COMMON /SUGNU/ XNUSUG(18)
REAL XNUSUG
SAVE /SUGNU/
DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
& 'truly unified SUGRA', 'non-minimal GMSB'/
C...Start by checking for incompatibilities/inconsistencies:
DO 100 ICHK=2,9
IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
& ,' option not used by PYSUGI'
ENDIF
100 CONTINUE
C...ISAJET works with REAL numbers.
MZERO=REAL(RMSS(8))
MHLF=REAL(RMSS(1))
AZERO=REAL(RMSS(16))
TANB=REAL(RMSS(5))
SGNMU=REAL(RMSS(4))
MTOP=REAL(PMAS(6,1))
IMODEL=0
IF (IMSS(1).EQ.12) THEN
IMODEL=1
GOTO 130
ELSEIF(IMSS(1).EQ.13) THEN
C...Read from isajet par file in IMSS(20)
LFN=IMSS(20)
C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
IF (LFN.EQ.0) THEN
WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
GOTO 9999
ENDIF
WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
CMrenna change to allow any susy model
WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
& ' gauge couplings:'
WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
READ(LFN,*) IMODEL
IF (IMODEL.EQ.4) THEN
IAL3UN=1
IMODEL=1
ENDIF
IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
& //' sgn(mu), M_t:'
READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
IF (IMODEL.EQ.3) THEN
IMODEL=1
110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
& //' 0 to continue:'
WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
& //' generation masses'
WRITE(MSTU(11),*)
& ' NUSUG5 = GUT scale 3rd generation masses'
READ(LFN,*) INUSUG
IF (INUSUG.EQ.0) THEN
GOTO 120
ELSEIF (INUSUG.EQ.1) THEN
WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
IF (XNUSUG(3).LE.0.) THEN
WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
CALL PYSTOP(109)
END IF
ELSEIF (INUSUG.EQ.2) THEN
WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
ELSEIF (INUSUG.EQ.3) THEN
WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
READ(LFN,*) XNUSUG(7),XNUSUG(8)
ELSEIF (INUSUG.EQ.4) THEN
WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
& //' M(ur), M(el), M(er):'
READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
& XNUSUG(10),XNUSUG(9)
ELSEIF (INUSUG.EQ.5) THEN
WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
& //' M(Ll), M(Lr):'
READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
& XNUSUG(15),XNUSUG(14)
ENDIF
GOTO 110
ENDIF
ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
IMSS(11)=1
WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
& ,' sgn(mu), M_t, C_gv:'
READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
XGMIN(7)=XCMGV
XGMIN(8)=1.
C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
AMPL=2.4D18
AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
IF (IMODEL.EQ.5) THEN
IMODEL=2
WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
& ,' masses at M_mes'
WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
& ,' shifts at M_mes'
WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
& ' Y at M_mes'
WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
& ,'SU(2),SU(3)'
WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
& ,' n5_2, n5_3'
READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
$ XGMIN(13),XGMIN(14)
ENDIF
ELSE
WRITE(MSTU(11),*) 'Invalid model choice.'
GOTO 9999
ENDIF
ENDIF
120 MZERO=M0
MHLF=MHF
AZERO=A0
C TANB=REAL(RMSS(5))
C SGNMU=REAL(RMSS(4))
MTOP=MT
C...Initialize MSSM parameter array
130 DO 140 IPAR=1,72
SUPER(IPAR)=0.0
140 CONTINUE
C...Call ISASUGRA
CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
C...Check whether ISASUSY thought the model was OK.
IF (NOGOOD.NE.0) THEN
IF (NOGOOD.EQ.1) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
IF (NOGOOD.EQ.2) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give no EWSB.')
IF (NOGOOD.EQ.3) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
IF (NOGOOD.EQ.4) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
IF (NOGOOD.EQ.7) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
IF (NOGOOD.EQ.8) CALL PYERRM(26
& ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
C...Give warning, but don't stop, if LSP not ~chi_10.
IF (NOGOOD.EQ.5) CALL PYERRM(16
& ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
ENDIF
C...Warn about possible GUT scale tachyons.
IF (ITACHY.NE.0) CALL PYERRM(16,
& '(PYSUGI:) Tachyonic sleptons at GUT scale.')
C...Finalize spectrum (last iteration)
C...(Thanks to A. Raklev for pointing this out.)
C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
$ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
$ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
$ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
$ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
$ MTOP,IALLOW,1)
C...M1, M2, M3.
RMSS(1)=dble(GSS(7))
RMSS(2)=dble(GSS(8))
RMSS(3)=dble(GSS(9))
RMSOFT(1)=dble(GSS(7))
RMSOFT(2)=dble(GSS(8))
RMSOFT(3)=dble(GSS(9))
C...Mu = - Higgsino mass.
RMSS(4)=-SUPER(29)
RMSS(5)=TANB
C...Slepton and squark masses. 2 first generations.
RMSS(6)=0.5*(SUPER(18)+SUPER(20))
RMSS(7)=0.5*(SUPER(19)+SUPER(21))
RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
C...Third generation.
RMSS(10)=0.5*(SUPER(14)+SUPER(10))
RMSS(11)=SUPER(11)
RMSS(12)=SUPER(15)
RMSS(13)=SUPER(22)
RMSS(14)=SUPER(23)
C...SLHA: store exact soft spectrum in RMSOFT
RMSOFT(31)=SUPER(18)
RMSOFT(32)=SUPER(20)
RMSOFT(33)=SUPER(22)
RMSOFT(34)=SUPER(19)
RMSOFT(35)=SUPER(21)
RMSOFT(36)=SUPER(23)
RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
RMSOFT(44)=SUPER(3)
RMSOFT(45)=SUPER(9)
RMSOFT(46)=SUPER(15)
RMSOFT(47)=SUPER(5)
RMSOFT(48)=SUPER(7)
RMSOFT(49)=SUPER(11)
C...~b, ~t, and ~tau trilinear couplings and mixing angles.
RMSS(15)=SUPER(62)
RMSS(16)=SUPER(60)
RMSS(17)=SUPER(64)
RMSS(26)=SUPER(63)
RMSS(27)=SUPER(61)
RMSS(28)=SUPER(65)
C...SLHA trilinears
DO 142 K1=1,3
DO 141 K2=1,3
AE(K1,K2)=0D0
AU(K1,K2)=0D0
AD(K1,K2)=0D0
141 CONTINUE
142 CONTINUE
AE(3,3)=SUPER(64)
AU(3,3)=SUPER(60)
AD(3,3)=SUPER(62)
C...Higgs mixing angle alpha (Gunion-Haber convention).
RMSS(18)=-SUPER(59)
C...A0 mass.
RMSS(19)=SUPER(57)
C...GUT scale coupling
RMSS(20)=AGUTSS
C...Gravitino mass (for future compatibility)
RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
C...Higgs sector.
PMAS(PYCOMP(25),1)=ABS(SUPER(55))
PMAS(PYCOMP(35),1)=ABS(SUPER(56))
PMAS(PYCOMP(36),1)=ABS(SUPER(57))
PMAS(PYCOMP(37),1)=ABS(SUPER(58))
C...Gluino.
PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
C...Squarks and Sleptons.
DO 150 ILR=1,2
ILRM=ILR-1
PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
150 CONTINUE
PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
C...Neutralinos.
PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
C...Signed masses (extra minus from going to G-H convention).
SMZ(1)=-SUPER(31)
SMZ(2)=-SUPER(32)
SMZ(3)=-SUPER(33)
SMZ(4)=-SUPER(34)
C...Charginos
PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
C...Signed masses (extra minus from going to G-H convention).
SMW(1)=-SUPER(51)
SMW(2)=-SUPER(52)
C... Neutralino Mixing.
DO 160 IN=1,4
ZMIX(IN,1)= SUPER(38+4*(IN-1))
ZMIX(IN,2)= SUPER(37+4*(IN-1))
ZMIX(IN,3)=-SUPER(36+4*(IN-1))
ZMIX(IN,4)=-SUPER(35+4*(IN-1))
160 CONTINUE
C...Chargino Mixing (PYTHIA same angle as HERWIG).
THX=1D0
THY=1D0
IF (SUPER(53).GT.0) THX=-1D0
IF (SUPER(54).GT.0) THY=-1D0
UMIX(1,1) = -SIN(SUPER(53))
UMIX(1,2) = -COS(SUPER(53))
UMIX(2,1) = -THX*COS(SUPER(53))
UMIX(2,2) = THX*SIN(SUPER(53))
VMIX(1,1) = -SIN(SUPER(54))
VMIX(1,2) = -COS(SUPER(54))
VMIX(2,1) = -THY*COS(SUPER(54))
VMIX(2,2) = THY*SIN(SUPER(54))
C...Sfermion mixing (PYTHIA same angle as ISAJET)
SFMIX(5,1)=COS(SUPER(63))
SFMIX(5,2)=SIN(SUPER(63))
SFMIX(5,3)=-SIN(SUPER(63))
SFMIX(5,4)=COS(SUPER(63))
SFMIX(6,1)=COS(SUPER(61))
SFMIX(6,2)=SIN(SUPER(61))
SFMIX(6,3)=-SIN(SUPER(61))
SFMIX(6,4)=COS(SUPER(61))
SFMIX(15,1)=COS(SUPER(65))
SFMIX(15,2)=SIN(SUPER(65))
SFMIX(15,3)=-SIN(SUPER(65))
SFMIX(15,4)=COS(SUPER(65))
IF (MSTP(122).NE.0) THEN
C...Print a few lines to make the user know what's happening
ISAVER=VISAJE()
WRITE(MSTU(11),5000) DOC, ISAVER
WRITE(MSTU(11),5100)
IF (IMODEL.EQ.1) THEN
WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
& MTOP
WRITE(MSTU(11),5300)
ENDIF
WRITE(MSTU(11),5500) 'Pole masses'
WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
& ,(SUPER(IP),IP=19,25,2)
WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
& ,IP=1,2)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500) 'EW scale mixing structure'
WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
& ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
& ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
& ),(SFMIX(15,J),J=3,4)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),6450) RMSS(18)
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500) 'Couplings'
WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
WRITE(MSTU(11),5400)
ENDIF
C...Call FeynHiggs to improve Higgs sector if requested
IF (IMSS(4).EQ.3) THEN
IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
& ' (PYSUGI:) Now calling FeynHiggs.'
CALL PYFEYN(IERR)
IF (IERR.EQ.0) THEN
IMSS(4)=2
IF (MSTP(122).NE.0) THEN
WRITE(MSTU(11),5400)
WRITE(MSTU(11),5500)
& 'Corrected Higgs masses and mixing'
WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
& PMAS(37,1)
WRITE(MSTU(11),6450) RMSS(18)
WRITE(MSTU(11),5400)
ENDIF
ENDIF
ENDIF
IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
C...output by ISASUSY.
IMSS(4)=MAX(2,IMSS(4))
5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
& ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
& ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
& 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
& ,'----------------')
5400 FORMAT(1x,'*',1x,A)
5500 FORMAT(1x,'*',1x,A,':')
5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
& 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
& 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
& '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
& ,1x))
5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
& ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
& ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
& .2,1x))
5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
& ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
& ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
& ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
& ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
& ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
& ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
& ,1x,F6.3,1x),'|')
6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
& ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
& ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
& ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
& ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
& ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
& ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
& 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
& ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
& 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
& ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
& ,4x,'Alpha_GUT = ',F8.2)
6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
9999 RETURN
END
C*********************************************************************
C...PYFEYN
C...Interface to FeynHiggs for MSSM Higgs sector.
C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
C...P. Skands
SUBROUTINE PYFEYN(IERR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C...SUSY blocks
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
C...FeynHiggs variables
DOUBLE PRECISION RMHIGG(4)
DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
DOUBLE COMPLEX DMU,
& AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
& DM1, DM2, DM3
C...SLHA Common Block
COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
& AU(3,3),AD(3,3),AE(3,3)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
IERR=0
CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
IF (IERR.NE.0) THEN
CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
& //'Will not use FeynHiggs for this run.')
RETURN
ENDIF
Q=RMSOFT(0)
DMB=PMAS(5,1)
DMT=PMAS(6,1)
DMZ=PMAS(23,1)
DMW=PMAS(24,1)
DMA=PMAS(36,1)
DM1=RMSOFT(1)
DM2=RMSOFT(2)
DM3=RMSOFT(3)
DTANB=RMSS(5)
DMU=RMSS(4)
DM3SL=RMSOFT(33)
DM3SE=RMSOFT(36)
DM3SQ=RMSOFT(43)
DM3SU=RMSOFT(46)
DM3SD=RMSOFT(49)
DM2SL=RMSOFT(32)
DM2SE=RMSOFT(35)
DM2SQ=RMSOFT(42)
DM2SU=RMSOFT(45)
DM2SD=RMSOFT(48)
DM1SL=RMSOFT(31)
DM1SE=RMSOFT(34)
DM1SQ=RMSOFT(41)
DM1SU=RMSOFT(44)
DM1SD=RMSOFT(47)
AE33=AE(3,3)
AE22=AE(2,2)
AE11=AE(1,1)
AU33=AU(3,3)
AU22=AU(2,2)
AU11=AU(1,1)
AD33=AD(3,3)
AD22=AD(2,2)
AD11=AD(1,1)
CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
& DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
& DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
& DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
& AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
& DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
IF (IERR.NE.0) THEN
CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
& //' Will not use FeynHiggs for this run.')
RETURN
ENDIF
C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
SAEFF=0D0
CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
IF (IERR.NE.0) THEN
CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
& 'GSCORR. Will not use FeynHiggs for this run.')
RETURN
ENDIF
ALPHA = ASIN(DBLE(SAEFF))
R=RMSS(18)/ALPHA
IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
WRITE(MSTU(11),*) ' New Alpha:', ALPHA
ENDIF
IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
& 1.15D0*PMAS(25,1)) THEN
CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
ENDIF
RMSS(18)=ALPHA
PMAS(25,1)=RMHIGG(1)
PMAS(35,1)=RMHIGG(2)
PMAS(36,1)=RMHIGG(3)
PMAS(37,1)=RMHIGG(4)
RETURN
END
C*********************************************************************
C...PYRNMQ
C...Determines the running mass of Squarks.
FUNCTION PYRNMQ(ID,DTERM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
SAVE /PYMSSM/
C...Local variables.
DOUBLE PRECISION PI,R
DOUBLE PRECISION TOL
DOUBLE PRECISION CI(3)
EXTERNAL PYALPS
DOUBLE PRECISION PYALPS
DATA TOL/0.001D0/
DATA PI,R/3.141592654D0,.61803399D0/
DATA CI/0.47D0,0.07D0,0.02D0/
C=1D0-R
CA=CI(ID)
AG=(0.71D0)**2/4D0/PI
AG=RMSS(20)
XM0=RMSS(8)
XMG=RMSS(1)
XM02=XM0*XM0
XMG2=XMG*XMG
AS=PYALPS(XM02+6D0*XMG2)
CG=8D0/9D0*((AS/AG)**2-1D0)
BX=XM02+(CA+CG)*XMG2+DTERM
AX=MIN(50D0**2,0.5D0*BX)
CX=MAX(2000D0**2,2D0*BX)
X0=AX
X3=CX
IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
X1=BX
X2=BX+C*(CX-BX)
ELSE
X2=BX
X1=BX-C*(BX-AX)
ENDIF
AS1=PYALPS(X1)
CG=8D0/9D0*((AS1/AG)**2-1D0)
F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
AS2=PYALPS(X2)
CG=8D0/9D0*((AS2/AG)**2-1D0)
F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
IF(F2.LT.F1) THEN
X0=X1
X1=X2
X2=R*X1+C*X3
F1=F2
AS2=PYALPS(X2)
CG=8D0/9D0*((AS2/AG)**2-1D0)
F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
ELSE
X3=X2
X2=X1
X1=R*X2+C*X0
F2=F1
AS1=PYALPS(X1)
CG=8D0/9D0*((AS1/AG)**2-1D0)
F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
ENDIF
GOTO 100
ENDIF
IF(F1.LT.F2) THEN
PYRNMQ=X1
XMIN=X1
ELSE
PYRNMQ=X2
XMIN=X2
ENDIF
RETURN
END
C*********************************************************************
C...PYTHRG
C...Calculates the mass eigenstates of the third generation sfermions.
C...Created: 5-31-96
SUBROUTINE PYTHRG
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
C...Local variables.
DOUBLE PRECISION BETA
DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
DOUBLE PRECISION ATR,AMQR,AMQL
INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
INTEGER IF,I,J,II,JJ,IT,L
LOGICAL DTERM
DATA SMALL/1D-3/
DATA ID1/10,10,13/
DATA ID2/5,6,15/
DATA ID3/15,16,17/
DATA ID4/11,12,14/
DATA DTERM/.TRUE./
XMZ2=PMAS(23,1)**2
XMW2=PMAS(24,1)**2
TANB=RMSS(5)
XMU=-RMSS(4)
BETA=ATAN(TANB)
COS2B=COS(2D0*BETA)
C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
IOPT=IMSS(5)
IF(IOPT.EQ.1) THEN
CTT=DCOS(RMSS(27))
CTT2=CTT**2
STT=DSIN(RMSS(27))
STT2=STT**2
XM12=RMSS(10)**2
XM22=RMSS(12)**2
XMQL2=CTT2*XM12+STT2*XM22
XMQR2=STT2*XM12+CTT2*XM22
XMF2=PYMRUN(6,PMAS(6,1)**2)**2
ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
RMSS(16)=ATOP
C......SUBTRACT OUT D-TERM AND FERMION MASS
XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
IF(XMQL2.GE.0D0) THEN
RMSS(10)=SQRT(XMQL2)
ELSE
RMSS(10)=-SQRT(-XMQL2)
ENDIF
IF(XMQR2.GE.0D0) THEN
RMSS(12)=SQRT(XMQR2)
ELSE
RMSS(12)=-SQRT(-XMQR2)
ENDIF
C SAME FOR BOTTOM SQUARK
CTT=DCOS(RMSS(26))
CTT2=CTT**2
STT=DSIN(RMSS(26))
STT2=STT**2
XM22=RMSS(11)**2
XMF2=PYMRUN(5,PMAS(6,1)**2)**2
XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
IF(ABS(CTT).GE..9999D0) THEN
ABOT=-XMU*TANB
XMQR2=RMSS(11)**2
ELSEIF(ABS(CTT).LE.1D-4) THEN
ABOT=-XMU*TANB
XMQR2=RMSS(11)**2
ELSE
XM12=(XMQL2-STT2*XM22)/CTT2
XMQR2=STT2*XM12+CTT2*XM22
ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
ENDIF
RMSS(15)=ABOT
C......SUBTRACT OUT D-TERM AND FERMION MASS
XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
IF(XMQR2.GE.0D0) THEN
RMSS(11)=SQRT(XMQR2)
ELSE
RMSS(11)=-SQRT(-XMQR2)
ENDIF
C SAME FOR TAU SLEPTON
CTT=DCOS(RMSS(28))
CTT2=CTT**2
STT=DSIN(RMSS(28))
STT2=STT**2
XM12=RMSS(13)**2
XM22=RMSS(14)**2
XMQL2=CTT2*XM12+STT2*XM22
XMQR2=STT2*XM12+CTT2*XM22
XMFR=PMAS(15,1)
XMF2=XMFR**2
ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
RMSS(17)=ATAU
C......SUBTRACT OUT D-TERM AND FERMION MASS
XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
IF(XMQL2.GE.0D0) THEN
RMSS(13)=SQRT(XMQL2)
ELSE
RMSS(13)=-SQRT(-XMQL2)
ENDIF
IF(XMQR2.GE.0D0) THEN
RMSS(14)=SQRT(XMQR2)
ELSE
RMSS(14)=-SQRT(-XMQR2)
ENDIF
ENDIF
DO 170 L=1,3
AMQL=RMSS(ID1(L))
IF(AMQL.LT.0D0) THEN
XMQL2=-AMQL**2
ELSE
XMQL2=AMQL**2
ENDIF
ATR=RMSS(ID3(L))
AMQR=RMSS(ID4(L))
IF(AMQR.LT.0D0) THEN
XMQR2=-AMQR**2
ELSE
XMQR2=AMQR**2
ENDIF
IF=ID2(L)
XMF=PYMRUN(IF,PMAS(6,1)**2)
XMF2=XMF**2
AM2(1,1)=XMQL2+XMF2
AM2(2,2)=XMQR2+XMF2
IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
IF(DTERM) THEN
IF(L.EQ.1) THEN
AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
AM2(1,2)=XMF*(ATR+XMU*TANB)
ELSEIF(L.EQ.2) THEN
AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
AM2(1,2)=XMF*(ATR+XMU/TANB)
ELSEIF(L.EQ.3) THEN
IF(IMSS(8).EQ.1) THEN
AM2(1,1)=RMSS(6)**2
AM2(2,2)=RMSS(7)**2
AM2(1,2)=0D0
RMSS(13)=RMSS(6)
RMSS(14)=RMSS(7)
ELSE
AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
AM2(1,2)=XMF*(ATR+XMU*TANB)
ENDIF
ENDIF
ENDIF
AM2(2,1)=AM2(1,2)
DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
IF(DETM.LT.0D0) THEN
WRITE(MSTU(11),*) ID2(L),DETM,AM2
CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
ENDIF
SAME=0.5D0*(AM2(1,1)+AM2(2,2))
DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
XMF12=SAME-DIFF
XMF22=SAME+DIFF
IT=0
IF(XMF22-XMF12.GT.0D0) THEN
RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
RT(2,2) = RT(1,1)
RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
& AM2(1,2)/(XMF22-XMF12))
RT(2,1) = -RT(1,2)
ELSE
RT(1,1) = 1D0
RT(2,2) = RT(1,1)
RT(1,2) = 0D0
RT(2,1) = -RT(1,2)
ENDIF
100 CONTINUE
IT=IT+1
DO 140 I=1,2
DO 130 JJ=1,2
DI(I,JJ)=0D0
DO 120 II=1,2
DO 110 J=1,2
DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
IF(DI(1,1).GT.DI(2,2)) THEN
WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
WRITE(MSTU(11),*) AM2
WRITE(MSTU(11),*) DI
WRITE(MSTU(11),*) RT
DI(1,1)=-RT(2,1)
DI(2,2)=RT(1,2)
DI(1,2)=-RT(2,2)
DI(2,1)=RT(1,1)
DO 160 I=1,2
DO 150 J=1,2
RT(I,J)=DI(I,J)
150 CONTINUE
160 CONTINUE
GOTO 100
ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
& ' OFF DIAGONAL ELEMENTS '
WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
WRITE(MSTU(11),*) DI
WRITE(MSTU(11),*) ' ROTATION = ',RT
C...STOP
ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
& ' NEGATIVE MASSES '
CALL PYSTOP(111)
ENDIF
PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
SFMIX(IF,1)=RT(1,1)
SFMIX(IF,2)=RT(1,2)
SFMIX(IF,3)=RT(2,1)
SFMIX(IF,4)=RT(2,2)
170 CONTINUE
C.....TAU SNEUTRINO MASS...L=3
XARG=AM2(1,1)+XMW2*COS2B
IF(XARG.LT.0D0) THEN
WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
& ' FROM THE SUM RULE. '
WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
RETURN
ELSE
PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
ENDIF
RETURN
END
C*********************************************************************
C...PYINOM
C...Finds the mass eigenstates and mixing matrices for neutralinos
C...and charginos.
SUBROUTINE PYINOM
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
C...Local variables.
DOUBLE PRECISION XMW,XMZ,XM(4)
DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
DOUBLE PRECISION COSW,SINW
DOUBLE PRECISION XMU
DOUBLE PRECISION TANB,COSB,SINB
DOUBLE PRECISION XM1,XM2,XM3,BETA
DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
DOUBLE PRECISION PYALPS,PYALEM
DOUBLE PRECISION PYRNM3
COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
DATA KFNCHI/1000022,1000023,1000025,1000035/
IOPT=IMSS(2)
IF(IMSS(1).EQ.2) THEN
IOPT=1
ENDIF
C...M1, M2, AND M3 ARE INDEPENDENT
IF(IOPT.EQ.0) THEN
XM1=RMSS(1)
XM2=RMSS(2)
XM3=RMSS(3)
ELSEIF(IOPT.GE.1) THEN
Q2=PMAS(23,1)**2
AEM=PYALEM(Q2)
A2=AEM/PARU(102)
A1=AEM/(1D0-PARU(102))
XM1=RMSS(1)
XM2=RMSS(2)
IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
IF(IOPT.EQ.1) THEN
XM2=XM1*A2/A1*3D0/5D0
RMSS(2)=XM2
ELSEIF(IOPT.EQ.3) THEN
XM1=XM2*5D0/3D0*A1/A2
RMSS(1)=XM1
ENDIF
XM3=PYRNM3(XM2/A2)
RMSS(3)=XM3
IF(XM3.LE.0D0) THEN
WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
CALL PYSTOP(105)
ENDIF
ENDIF
C...GLUINO MASS
IF(IMSS(3).EQ.1) THEN
PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
ELSE
AQ=0D0
DO 110 I=1,4
DO 100 ILR=1,2
RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
& +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
100 CONTINUE
110 CONTINUE
DO 130 I=5,6
DO 120 ILR=1,2
RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
RM2=PMAS(I,1)**2/XM3**2
ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
IF(ARG.GE.0D0) THEN
X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
AX0=ABS(X0)
X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
AX1=ABS(X1)
IF(X0.EQ.1D0) THEN
AT=-1D0
BT=0.25D0
ELSEIF(X0.EQ.0D0) THEN
AT=0D0
BT=-0.25D0
ELSE
AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
& 0.5D0*X0**2*LOG(AX0)
BT=(-1D0-2D0*X0)/4D0
ENDIF
IF(X1.EQ.1D0) THEN
AT=-1D0+AT
BT=0.25D0+BT
ELSEIF(X1.EQ.0D0) THEN
AT=0D0+AT
BT=-0.25D0+BT
ELSE
AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
& X1**2*LOG(AX1)+AT
BT=(-1D0-2D0*X1)/4D0+BT
ENDIF
AQ=AQ+AT+BT
ELSE
X0=0.5D0*(1D0+RM2-RM1)
Y0=-0.5D0*SQRT(-ARG)
AMGX0=SQRT(X0**2+Y0**2)
AM1X0=SQRT((1D0-X0)**2+Y0**2)
ARGX0=ATAN2(-X0,-Y0)
AR1X0=ATAN2(1D0-X0,Y0)
X1=X0
Y1=-Y0
AMGX1=AMGX0
AM1X1=AM1X0
ARGX1=ATAN2(-X1,-Y1)
AR1X1=ATAN2(1D0-X1,Y1)
AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
& +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
& +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
AQ=AQ+AT+BT
ENDIF
120 CONTINUE
130 CONTINUE
PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
& /(2D0*PARU(2))*(15D0+AQ))
ENDIF
C...NEUTRALINO MASSES
DO 150 I=1,4
DO 140 J=1,4
AI(I,J)=0D0
140 CONTINUE
150 CONTINUE
XMZ=PMAS(23,1)/100D0
XMW=PMAS(24,1)/100D0
XMU=RMSS(4)/100D0
SINW=SQRT(PARU(102))
COSW=SQRT(1D0-PARU(102))
TANB=RMSS(5)
BETA=ATAN(TANB)
COSB=COS(BETA)
SINB=TANB*COSB
XM2=XM2/100D0
XM1=XM1/100D0
C... Definitions:
C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
AR(1,1) = XM1*COS(RMSS(30))
AI(1,1) = XM1*SIN(RMSS(30))
AR(2,2) = XM2*COS(RMSS(31))
AI(2,2) = XM2*SIN(RMSS(31))
AR(3,3) = 0D0
AR(4,4) = 0D0
AR(1,2) = 0D0
AR(2,1) = 0D0
AR(1,3) = -XMZ*SINW*COSB
AR(3,1) = AR(1,3)
AR(1,4) = XMZ*SINW*SINB
AR(4,1) = AR(1,4)
AR(2,3) = XMZ*COSW*COSB
AR(3,2) = AR(2,3)
AR(2,4) = -XMZ*COSW*SINB
AR(4,2) = AR(2,4)
AR(3,4) = -XMU*COS(RMSS(33))
AI(3,4) = -XMU*SIN(RMSS(33))
AR(4,3) = -XMU*COS(RMSS(33))
AI(4,3) = -XMU*SIN(RMSS(33))
C CALL PYEIG4(AR,WR,ZR)
CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
& 'PROBLEM WITH PYEICG IN PYINOM ')
DO 160 I=1,4
INDEX(I)=I
XM(I)=ABS(WR(I))
160 CONTINUE
DO 180 I=2,4
K=I
DO 170 J=I-1,1,-1
IF(XM(K).LT.XM(J)) THEN
ITMP=INDEX(J)
XTMP=XM(J)
INDEX(J)=INDEX(K)
XM(J)=XM(K)
INDEX(K)=ITMP
XM(K)=XTMP
K=K-1
ELSE
GOTO 180
ENDIF
170 CONTINUE
180 CONTINUE
DO 210 I=1,4
K=INDEX(I)
SMZ(I)=WR(K)*100D0
PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
S=0D0
DO 190 J=1,4
S=S+ZR(J,K)**2+ZI(J,K)**2
190 CONTINUE
DO 200 J=1,4
ZMIX(I,J)=ZR(J,K)/SQRT(S)
ZMIXI(I,J)=ZI(J,K)/SQRT(S)
IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
200 CONTINUE
210 CONTINUE
C...CHARGINO MASSES
C.....Find eigenvectors of X X^*
DO I=1,4
DO J=1,4
AR(I,J)=0D0
AI(I,J)=0D0
ENDDO
ENDDO
AI(1,1) = 0D0
AI(2,2) = 0D0
AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
&XMU*COS(RMSS(33))*SINB)
AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
&XMU*SIN(RMSS(33))*SINB)
AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
&XMU*COS(RMSS(33))*SINB)
AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
&XMU*SIN(RMSS(33))*SINB)
CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
& 'PROBLEM WITH PYEICG IN PYINOM ')
INDEX(1)=1
INDEX(2)=2
IF(WR(2).LT.WR(1)) THEN
INDEX(1)=2
INDEX(2)=1
ENDIF
DO 240 I=1,2
K=INDEX(I)
SMW(I)=SQRT(WR(K))*100D0
S=0D0
DO 220 J=1,2
S=S+ZR(J,K)**2+ZI(J,K)**2
220 CONTINUE
DO 230 J=1,2
UMIX(I,J)=ZR(J,K)/SQRT(S)
UMIXI(I,J)=-ZI(J,K)/SQRT(S)
IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
230 CONTINUE
240 CONTINUE
C...Force chargino mass > neutralino mass
IFRC=0
IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
CALL PYERRM(8,'(PYINOM:) '//
& 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
IFRC=1
ENDIF
PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
C.....Find eigenvectors of X^* X
DO I=1,4
DO J=1,4
AR(I,J)=0D0
AI(I,J)=0D0
ZR(I,J)=0D0
ZI(I,J)=0D0
ENDDO
ENDDO
AI(1,1) = 0D0
AI(2,2) = 0D0
AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
&XMU*COS(RMSS(33))*COSB)
AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
&XMU*SIN(RMSS(33))*COSB)
AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
&XMU*COS(RMSS(33))*COSB)
AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
&XMU*SIN(RMSS(33))*COSB)
CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
& 'PROBLEM WITH PYEICG IN PYINOM ')
INDEX(1)=1
INDEX(2)=2
IF(WR(2).LT.WR(1)) THEN
INDEX(1)=2
INDEX(2)=1
ENDIF
SIMAG=0D0
DO 270 I=1,2
K=INDEX(I)
S=0D0
DO 250 J=1,2
S=S+ZR(J,K)**2+ZI(J,K)**2
SIMAG=SIMAG+ZI(J,K)**2
250 CONTINUE
DO 260 J=1,2
VMIX(I,J)=ZR(J,K)/SQRT(S)
VMIXI(I,J)=-ZI(J,K)/SQRT(S)
IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
260 CONTINUE
270 CONTINUE
C.....Simplify if no phases
IF(SIMAG.LT.1D-6) THEN
AR(1,1) = XM2*COS(RMSS(31))
AR(2,2) = XMU*COS(RMSS(33))
AR(1,2) = SQRT(2D0)*XMW*SINB
AR(2,1) = SQRT(2D0)*XMW*COSB
IKNT=0
300 CONTINUE
DO I=1,2
DO J=1,2
ZR(I,J)=0D0
ENDDO
ENDDO
DO I=1,2
DO J=1,2
DO K=1,2
DO L=1,2
ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
ENDDO
ENDDO
ENDDO
ENDDO
VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
IKNT=IKNT+1
GOTO 300
ENDIF
C.....Must deal with phases
ELSE
CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
IKNT=0
310 CONTINUE
DO I=1,2
DO J=1,2
CAI(I,J)=CMPLX(0D0,0D0)
ENDDO
ENDDO
DO I=1,2
DO J=1,2
DO K=1,2
DO L=1,2
CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
& CMPLX(VMIX(J,L),VMIXI(J,L))
ENDDO
ENDDO
ENDDO
ENDDO
CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
TEMPR=VMIX(1,1)
TEMPI=VMIXI(1,1)
VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
TEMPR=VMIX(1,2)
TEMPI=VMIXI(1,2)
VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
TEMPR=VMIX(2,1)
TEMPI=VMIXI(2,1)
VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
TEMPR=VMIX(2,2)
TEMPI=VMIXI(2,2)
VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
& ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
IKNT=IKNT+1
GOTO 310
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYRNM3
C...Calculates the running of M3, the SU(3) gluino mass parameter.
FUNCTION PYRNM3(RGUT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION R
DOUBLE PRECISION TOL
EXTERNAL PYALPS
DOUBLE PRECISION PYALPS
DATA TOL/0.001D0/
DATA R/0.61803399D0/
C=1D0-R
BX=RGUT*PYALPS(RGUT**2)
AX=MIN(50D0,BX*0.5D0)
CX=MAX(2000D0,2D0*BX)
X0=AX
X3=CX
IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
X1=BX
X2=BX+C*(CX-BX)
ELSE
X2=BX
X1=BX-C*(BX-AX)
ENDIF
AS1=PYALPS(X1**2)
F1=ABS(X1-RGUT*AS1)
AS2=PYALPS(X2**2)
F2=ABS(X2-RGUT*AS2)
100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
IF(F2.LT.F1) THEN
X0=X1
X1=X2
X2=R*X1+C*X3
F1=F2
AS2=PYALPS(X2**2)
F2=ABS(X2-RGUT*AS2)
ELSE
X3=X2
X2=X1
X1=R*X2+C*X0
F2=F1
AS1=PYALPS(X1**2)
F1=ABS(X1-RGUT*AS1)
ENDIF
GOTO 100
ENDIF
IF(F1.LT.F2) THEN
PYRNM3=X1
XMIN=X1
ELSE
PYRNM3=X2
XMIN=X2
ENDIF
RETURN
END
C*********************************************************************
C...PYEIG4
C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
C...Specific application: mixing in neutralino sector.
SUBROUTINE PYEIG4(A,W,Z)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Arrays: in call and local.
DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
C...Coefficients of fourth-degree equation from matrix.
C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
B2=0D0
DO 110 I=1,3
DO 100 J=I+1,4
B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
100 CONTINUE
110 CONTINUE
B1=0D0
B0=0D0
DO 120 I=1,4
I1=MOD(I,4)+1
I2=MOD(I+1,4)+1
I3=MOD(I+2,4)+1
B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
& A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
& A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
B0=B0+(-1D0)**(I+1)*A(1,I)*(
& A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
& A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
& A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
120 CONTINUE
C...Coefficients of third-degree equation needed for
C...separation into two second-degree equations.
C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
C2=-B2
C1=B1*B3-4D0*B0
C0=-B1**2-B0*B3**2+4D0*B0*B2
CQ=C1/3D0-C2**2/9D0
CR=C1*C2/6D0-C0/2D0-C2**3/27D0
CQR=CQ**3+CR**2
C...Cases with one or three real roots.
IF(CQR.GE.0D0) THEN
S1=(CR+SQRT(CQR))**(1D0/3D0)
S2=(CR-SQRT(CQR))**(1D0/3D0)
U=S1+S2-C2/3D0
ELSE
SABS=SQRT(-CQ)
THE=ACOS(CR/SABS**3)/3D0
SRE=SABS*COS(THE)
U=2D0*SRE-C2/3D0
ENDIF
C...Find and solve two second-degree equations.
P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
Q1=U/2D0+SQRT(U**2/4D0-B0)
Q2=U/2D0-SQRT(U**2/4D0-B0)
IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
QSAV=Q1
Q1=Q2
Q2=QSAV
ENDIF
X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
C...Order eigenvalues in asceding mass.
W(1)=X(1)
DO 150 I1=2,4
DO 130 I2=I1-1,1,-1
IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
W(I2+1)=W(I2)
130 CONTINUE
140 W(I2+1)=X(I1)
150 CONTINUE
C...Find equation system for eigenvectors.
DO 250 I=1,4
DO 170 J1=1,4
D(J1,J1)=A(J1,J1)-W(I)
DO 160 J2=J1+1,4
D(J1,J2)=A(J1,J2)
D(J2,J1)=A(J2,J1)
160 CONTINUE
170 CONTINUE
C...Find largest element in matrix.
DAMAX=0D0
DO 190 J1=1,4
DO 180 J2=1,4
IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
JA=J1
JB=J2
DAMAX=ABS(D(J1,J2))
180 CONTINUE
190 CONTINUE
C...Subtract others by multiple of row selected above.
DAMAX=0D0
DO 210 J3=JA+1,JA+3
J1=J3-4*((J3-1)/4)
RL=D(J1,JB)/D(JA,JB)
DO 200 J2=1,4
D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
JC=J1
JD=J2
DAMAX=ABS(D(J1,J2))
200 CONTINUE
210 CONTINUE
C...Do one more subtraction of a row.
DAMAX=0D0
DO 230 J3=JC+1,JC+3
J1=J3-4*((J3-1)/4)
IF(J1.EQ.JA) GOTO 230
RL=D(J1,JD)/D(JC,JD)
DO 220 J2=1,4
IF(J2.EQ.JB) GOTO 220
D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
JE=J1
DAMAX=ABS(D(J1,J2))
220 CONTINUE
230 CONTINUE
C...Construct unnormalized eigenvector.
JF1=JD+1-4*(JD/4)
JF2=JD+2-4*((JD+1)/4)
IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
E(JF1)=-D(JE,JF2)
E(JF2)=D(JE,JF1)
E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
& D(JA,JB)
C...Normalize and fill in final array.
EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
SGN=(-1D0)**INT(PYR(0)+0.5D0)
DO 240 J=1,4
Z(I,J)=SGN*E(J)/EA
240 CONTINUE
250 CONTINUE
RETURN
END
C*********************************************************************
C...PYHGGM
C...Determines the Higgs boson mass spectrum using several inputs.
SUBROUTINE PYHGGM(ALPHA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
C...Local variables.
DOUBLE PRECISION AT,AB,XMU,TANB
DOUBLE PRECISION ALPHA
INTEGER IHOPT
DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
IHOPT=IMSS(4)
IF(IHOPT.EQ.2) THEN
ALPHA=RMSS(18)
RETURN
ENDIF
AT=RMSS(16)
AB=RMSS(15)
DMGL=RMSS(3)
XMU=RMSS(4)
TANB=RMSS(5)
DMA=RMSS(19)
DTANB=TANB
DMQ=RMSS(10)
DMUR=RMSS(12)
DMDR=RMSS(11)
DMTOP=PMAS(6,1)
DMC=PMAS(PYCOMP(KSUSY1+37),1)
DAU=AT
DAD=AB
DMU=XMU
RMSS(40)=0D0
RMSS(41)=0D0
IF(IHOPT.EQ.0) THEN
CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
& DMHCH,DSA,DCA,DTANBA)
ELSEIF(IHOPT.EQ.1) THEN
CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
& DMHCH,DSA,DCA,DTANBA)
CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
& DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
& DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
RMSS(40)=DDT
RMSS(41)=DDB
DMH=DMHP
DHM=DHMP
DMA=DAMP
IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
WRITE(MSTU(11),*) ' STOP1 MASSES = ',
& PMAS(PYCOMP(1000006),1),DSTOP2
ENDIF
IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
WRITE(MSTU(11),*) ' STOP2 MASSES = ',
& PMAS(PYCOMP(2000006),1),DSTOP1
ENDIF
IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
& PMAS(PYCOMP(1000005),1),DSBOT2
ENDIF
IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
& PMAS(PYCOMP(2000005),1),DSBOT1
ENDIF
ELSEIF (IHOPT.EQ.3) THEN
c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
C...Currently only available for SLHA spectrum read-in.
IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
& //' spectrum, change IMSS(1) or IMSS(4) option.')
ENDIF
ALPHA=RMSS(18)
RETURN
ENDIF
ALPHA=ACOS(DCA)
PMAS(25,1)=DMH
PMAS(35,1)=DHM
PMAS(36,1)=DMA
PMAS(37,1)=DMHCH
RETURN
END
C*********************************************************************
C...PYSUBH
C...This routine computes the renormalization group improved
C...values of Higgs masses and couplings in the MSSM.
C...Program based on the work by M. Carena, J.R. Espinosa,
c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
C...All masses in GeV units. MA is the CP-odd Higgs mass,
C...MTOP is the physical top mass, MQ and MUR are the soft
C...supersymmetry breaking mass parameters of left handed
C...and right handed stops respectively, AU and AD are the
C...stop and sbottom trilinear soft breaking terms,
C...respectively, and MU is the supersymmetric
C...Higgs mass parameter. We use the conventions from
C...the physics report of Haber and Kane: left right
C...stop mixing term proportional to (AU - MU/TANB)
C...We use as input TANB defined at the scale MTOP
C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
C...where MH and HM are the lightest and heaviest CP-even
C...Higgs masses, MHCH is the charged Higgs mass and
C...ALPHA is the Higgs mixing angle
C...TANBA is the angle TANB at the CP-odd Higgs mass scale
C...Range of validity:
C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
C...are the sbottom mass eigenvalues, respectively. This
C...range automatically excludes the existence of tachyons.
C...For the charged Higgs mass computation, the method is
C...valid if
C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
C...where M_SUSY**2 is the average of the squared stop mass
C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
C...masses have been assumed to be of order of the stop ones
C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
&XMHCH,SA,CA,TANBA)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYHTRI/HHH(7)
SAVE /PYDAT1/,/PYDAT2/
C...Local variables.
DOUBLE PRECISION PYALEM,PYALPS
DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
DOUBLE PRECISION XMHCH,SA,CA
DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
DOUBLE PRECISION Q02
DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
XMZ = PMAS(23,1)
Q02=XMZ**2
AEM=PYALEM(Q02)
ALP1=AEM/(1D0-PARU(102))
ALP2=AEM/PARU(102)
ALPH3Z=PYALPS(Q02)
ALP1 = 0.0101D0
ALP2 = 0.0337D0
ALPH3Z = 0.12D0
V = 174.1D0
PI = PARU(1)
TANBA = TANB
TANBT = TANB
C...MBOTTOM(MTOP) = 3. GEV
XMB = PYMRUN(5,XMTOP**2)
ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
&LOG(XMTOP**2/XMZ**2))
C...RMTOP= RUNNING TOP QUARK MASS
RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
T = LOG(XMS**2/XMTOP**2)
SINB = TANB/((1D0 + TANB**2)**0.5D0)
COSB = SINB/TANB
C...IF(MA.LE.XMTOP) TANBA = TANBT
IF(XMA.GT.XMTOP)
&TANBA = TANBT*(1D0-3D0/32D0/PI**2*
&(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
&LOG(XMA**2/XMTOP**2))
SINBT = TANBT/SQRT(1D0 + TANBT**2)
COSBT = 1D0/SQRT(1D0 + TANBT**2)
C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
G1 = SQRT(ALP1*4D0*PI)
G2 = SQRT(ALP2*4D0*PI)
G3 = SQRT(ALP3*4D0*PI)
HU = RMTOP/V/SINBT
HD = XMB/V/COSBT
HU2=HU*HU
HD2=HD*HD
HU4=HU2*HU2
HD4=HD2*HD2
AU2=AU**2
AD2=AD**2
XMS2=XMS**2
XMS3=XMS**3
XMS4=XMS2*XMS2
XMU2=XMU*XMU
PI2=PI*PI
XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
&+ 3D0*(AU + AD)**2/XMS2)/6D0
XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
&+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
&- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
&-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
&- 16D0*G3**2) *T/16D0/PI2)
XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
&+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
&- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
&-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
&- 16D0*G3**2) *T/16D0/PI2)
XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
&(HU2 + HD2)*T/16D0/PI2)
&+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
&- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
&+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
&XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
&- 16D0*G3**2) *T/16D0/PI2)
&+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
&XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
&- 16D0*G3**2) *T/16D0/PI2)
XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
&-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
&- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
&+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
&XMS4)*
&(1+ (6D0*HU2 -2D0* HD2
&- 16D0*G3**2) *T/16D0/PI2)
&+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
&XMS4)*
&(1+ (6D0*HD2 -2D0* HU2/2D0
&- 16D0*G3**2) *T/16D0/PI2)
XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
&(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
&-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
&(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
&(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
&+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
&(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
&(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
&+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
&(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
HHH(1)=XLAM1
HHH(2)=XLAM2
HHH(3)=XLAM3
HHH(4)=XLAM4
HHH(5)=XLAM5
HHH(6)=XLAM6
HHH(7)=XLAM7
TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
&2D0* XLAM6*SINBT*COSBT
&+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
&+ XLAM5*COSBT**2)
DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
&XLAM6*COSBT**2
&+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
&2D0* XLAM6* COSBT*SINBT
&+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
&+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
&((XLAM1* COSBT**2 +2D0*
&XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
&(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
&*SINBT**2
&+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
&+ XLAM4) + XLAM6*COSBT**2
&+ XLAM7* SINBT**2))
XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
XHM = SQRT(XHM2)
XMH = SQRT(XMH2)
XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
XMHCH = SQRT(XMHCH2)
SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
&((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
&XLAM6* COSBT*SINBT
&+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
&- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
&+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
&SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
&XLAM6*COSBT**2 + XLAM7* SINBT**2) -
&XMA**2*SINBT*COSBT))/2D0**0.5D0/
&SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
&(((TRM2**2 - 4D0* DETM2)**0.5D0) -
&((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
&XLAM6* COSBT*SINBT
&+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
&- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
&+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
SA = -SINALP
CA = -COSALP
100 CONTINUE
RETURN
END
C*********************************************************************
C...PYPOLE
C...This subroutine computes the CP-even higgs and CP-odd pole
c...Higgs masses and mixing angles.
C...Program based on the work by M. Carena, M. Quiros
C...and C.E.M. Wagner, "Effective potential methods and
C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
C...AT,AB,MU
C...where MCHI is the largest chargino mass, MA is the running
C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
C...expectaion values at the scale MTOP, MQ is the third generation
C...left handed squark mass parameter, MUR is the third generation
C...right handed stop mass parameter, MDR is the third generation
C...right handed sbottom mass parameter, MTOP is the pole top quark
C...mass; AT,AB are the soft supersymmetry breaking trilinear
C...couplings of the stop and sbottoms, respectively, and MU is the
C...supersymmetric mass parameter
C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
C...Higgses whose pole mass is computed. If IHIGGS=0 only running
C...masses are given, what makes the running of the program
c...much faster and it is quite generally a good approximation
c...(for a theoretical discussion see ref. above). If IHIGGS=1,
C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
c...and if IHIGGS=3, then h,H,A polarizations are computed
C...Output: MH and MHP which are the lightest CP-even Higgs running
C...and pole masses, respectively; HM and HMP are the heaviest CP-even
C...Higgs running and pole masses, repectively; SA and CA are the
C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
C...the value of TANB at the CP-odd Higgs mass scale
C...This subroutine makes use of CERN library subroutine
C...integration package, which makes the computation of the
C...pole Higgs masses somewhat faster. We thank P. Janot for this
C...improvement. Those who are not able to call the CERN
C...libraries, please use the subroutine SUBHPOLE2.F, which
C...although somewhat slower, gives identical results
SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
&XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Parameters.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
&SSBOT2(2),B(2,2),COUPB(2,2),
&HCOUPT(2,2),HCOUPB(2,2),
&ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
DELTA(1,1) = 1D0
DELTA(2,2) = 1D0
DELTA(1,2) = 0D0
DELTA(2,1) = 0D0
V = 174.1D0
XMZ=91.18D0
PI=PARU(1)
RXMT=PYMRUN(6,XMT**2)
CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
&XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
SINB = TANB/(TANB**2+1D0)**0.5D0
COSB = 1D0/(TANB**2+1D0)**0.5D0
COS2B = SINB**2 - COSB**2
SINBPA = SINB*CA + COSB*SA
COSBPA = COSB*CA - SINB*SA
RMBOT = PYMRUN(5,XMT**2)
XMQ2 = XMQ**2
XMUR2 = XMUR**2
IF(XMUR.LT.0D0) XMUR2=-XMUR2
XMDR2 = XMDR**2
XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
IF(XMST11.LT.0D0) GOTO 500
IF(XMST22.LT.0D0) GOTO 500
XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
IF(XMSB11.LT.0D0) GOTO 500
IF(XMSB22.LT.0D0) GOTO 500
C WMST11 = RXMT**2 + XMQ2
C WMST22 = RXMT**2 + XMUR2
XMST12 = RXMT*(AT - XMU/TANB)
XMSB12 = RMBOT*(AB - XMU*TANB)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...STOP EIGENVALUES CALCULATION
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
STOP12 = 0.5D0*(XMST11+XMST22) +
&0.5D0*((XMST11+XMST22)**2 -
&4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
STOP22 = 0.5D0*(XMST11+XMST22) -
&0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
&XMST12**2))**0.5D0
IF(STOP22.LT.0D0) GOTO 500
SSTOP2(1) = STOP12
SSTOP2(2) = STOP22
STOP1 = STOP12**0.5D0
STOP2 = STOP22**0.5D0
C STOP1W = STOP1
C STOP2W = STOP2
IF(XMST12.EQ.0D0) XST11 = 1D0
IF(XMST12.EQ.0D0) XST12 = 0D0
IF(XMST12.EQ.0D0) XST21 = 0D0
IF(XMST12.EQ.0D0) XST22 = 1D0
IF(XMST12.EQ.0D0) GOTO 110
100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
110 T(1,1) = XST11
T(2,2) = XST22
T(1,2) = XST12
T(2,1) = XST21
SBOT12 = 0.5D0*(XMSB11+XMSB22) +
&0.5D0*((XMSB11+XMSB22)**2 -
&4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
SBOT22 = 0.5D0*(XMSB11+XMSB22) -
&0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
&XMSB12**2))**0.5D0
IF(SBOT22.LT.0D0) GOTO 500
SBOT1 = SBOT12**0.5D0
SBOT2 = SBOT22**0.5D0
SSBOT2(1) = SBOT12
SSBOT2(2) = SBOT22
IF(XMSB12.EQ.0D0) XSB11 = 1D0
IF(XMSB12.EQ.0D0) XSB12 = 0D0
IF(XMSB12.EQ.0D0) XSB21 = 0D0
IF(XMSB12.EQ.0D0) XSB22 = 1D0
IF(XMSB12.EQ.0D0) GOTO 130
120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
130 B(1,1) = XSB11
B(2,2) = XSB22
B(1,2) = XSB12
B(2,1) = XSB21
SINT = 0.2320D0
SQR = DSQRT(2D0)
VP = 174.1D0*SQR
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...STARTING OF LIGHT HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
IF(IHIGGS.EQ.0) GOTO 490
DO 150 I = 1,2
DO 140 J = 1,2
COUPT(I,J) =
& SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
& (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
& -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
& -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
& T(1,J)*T(2,I))
140 CONTINUE
150 CONTINUE
DO 170 I = 1,2
DO 160 J = 1,2
COUPB(I,J) =
& -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
& (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
& +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
& +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
& B(1,J)*B(2,I))
160 CONTINUE
170 CONTINUE
PRUN = XMH
EPS = 1D-4*PRUN
ITER = 0
180 ITER = ITER + 1
DO 230 I3 = 1,3
PR(I3)=PRUN+(I3-2)*EPS/2
P2=PR(I3)**2
POLT = 0D0
DO 200 I = 1,2
DO 190 J = 1,2
POLT = POLT + COUPT(I,J)**2*3D0*
& PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
190 CONTINUE
200 CONTINUE
POLB = 0D0
DO 220 I = 1,2
DO 210 J = 1,2
POLB = POLB + COUPB(I,J)**2*3D0*
& PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
210 CONTINUE
220 CONTINUE
C RXMT2 = RXMT**2
XMT2=XMT**2
POLTT =
& 3D0*RXMT**2/8D0/PI**2/ V **2*
& CA**2/SINB**2 *
& (-2D0*XMT**2+0.5D0*P2)*
& PYFINT(P2,XMT2,XMT2)
POL = POLT + POLB + POLTT
POLAR(I3) = P2 - XMH**2 - POL
230 CONTINUE
DERIV = (POLAR(3)-POLAR(1))/EPS
DRUN = - POLAR(2)/DERIV
PRUN = PRUN + DRUN
P2 = PRUN**2
IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
GOTO 180
240 CONTINUE
XMHP = DSQRT(P2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...END OF LIGHT HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
250 IF(IHIGGS.EQ.1) GOTO 490
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C... STARTING OF HEAVY HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
DO 270 I = 1,2
DO 260 J = 1,2
HCOUPT(I,J) =
& -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
& (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
& -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
& -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
& T(1,J)*T(2,I))
260 CONTINUE
270 CONTINUE
DO 290 I = 1,2
DO 280 J = 1,2
HCOUPB(I,J) =
& SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
& (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
& -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
& -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
& B(1,J)*B(2,I))
HCOUPB(I,J)=0D0
280 CONTINUE
290 CONTINUE
PRUN = HM
EPS = 1D-4*PRUN
ITER = 0
300 ITER = ITER + 1
DO 350 I3 = 1,3
PR(I3)=PRUN+(I3-2)*EPS/2
HP2=PR(I3)**2
HPOLT = 0D0
DO 320 I = 1,2
DO 310 J = 1,2
HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
& PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
310 CONTINUE
320 CONTINUE
HPOLB = 0D0
DO 340 I = 1,2
DO 330 J = 1,2
HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
& PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
330 CONTINUE
340 CONTINUE
C RXMT2 = RXMT**2
XMT2 = XMT**2
HPOLTT =
& 3D0*RXMT**2/8D0/PI**2/ V **2*
& SA**2/SINB**2 *
& (-2D0*XMT**2+0.5D0*HP2)*
& PYFINT(HP2,XMT2,XMT2)
HPOL = HPOLT + HPOLB + HPOLTT
POLAR(I3) =HP2-HM**2-HPOL
350 CONTINUE
DERIV = (POLAR(3)-POLAR(1))/EPS
DRUN = - POLAR(2)/DERIV
PRUN = PRUN + DRUN
HP2 = PRUN**2
IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
GOTO 300
360 CONTINUE
370 CONTINUE
HMP = HP2**0.5D0
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C... END OF HEAVY HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
IF(IHIGGS.EQ.2) GOTO 490
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...BEGINNING OF PSEUDOSCALAR HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
DO 390 I = 1,2
DO 380 J = 1,2
ACOUPT(I,J) =
& -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
& (T(1,I)*T(2,J) -T(1,J)*T(2,I))
380 CONTINUE
390 CONTINUE
DO 410 I = 1,2
DO 400 J = 1,2
ACOUPB(I,J) =
& RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
& (B(1,I)*B(2,J) -B(1,J)*B(2,I))
400 CONTINUE
410 CONTINUE
PRUN = XMA
EPS = 1D-4*PRUN
ITER = 0
420 ITER = ITER + 1
DO 470 I3 = 1,3
PR(I3)=PRUN+(I3-2)*EPS/2
AP2=PR(I3)**2
APOLT = 0D0
DO 440 I = 1,2
DO 430 J = 1,2
APOLT = APOLT + ACOUPT(I,J)**2*3D0*
& PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
430 CONTINUE
440 CONTINUE
APOLB = 0D0
DO 460 I = 1,2
DO 450 J = 1,2
APOLB = APOLB + ACOUPB(I,J)**2*3D0*
& PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
450 CONTINUE
460 CONTINUE
C RXMT2 = RXMT**2
XMT2=XMT**2
APOLTT =
& 3D0*RXMT**2/8D0/PI**2/ V **2*
& COSB**2/SINB**2 *
& (-0.5D0*AP2)*
& PYFINT(AP2,XMT2,XMT2)
APOL = APOLT + APOLB + APOLTT
POLAR(I3) = AP2 - XMA**2 -APOL
470 CONTINUE
DERIV = (POLAR(3)-POLAR(1))/EPS
DRUN = - POLAR(2)/DERIV
PRUN = PRUN + DRUN
AP2 = PRUN**2
IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
GOTO 420
480 CONTINUE
AMP = DSQRT(AP2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...END OF PSEUDOSCALAR HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
IF(IHIGGS.EQ.3) GOTO 490
490 CONTINUE
RETURN
500 CONTINUE
WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
CALL PYSTOP(107)
END
C*********************************************************************
C...PYRGHM
C...Auxiliary to PYPOLE.
SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
* MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
DIMENSION VH(2,2),M2(2,2),M2P(2,2)
C...Parameters.
INTEGER MSTU,MSTJ
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
MZ = 91.18D0
PI = PARU(1)
V = 174.1D0
ALPHA1 = 0.0101D0
ALPHA2 = 0.0337D0
ALPHA3Z = 0.12D0
TANBA = TANB
TANBT = TANB
C MBOTTOM(MTOP) = 3. GEV
MB = PYMRUN(5,MTOP**2)
ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
*LOG(MTOP**2/MZ**2))
C RMTOP= RUNNING TOP QUARK MASS
RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
TD = LOG((MD**2 + MTOP**2)/MTOP**2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C NEW DEFINITION, TGLU.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
TGLU = LOG(MGLU**2/MTOP**2)
SINB = TANB/DSQRT(1D0 + TANB**2)
COSB = SINB/TANB
IF(MA.GT.MTOP)
*TANBA = TANB*(1D0-3D0/32D0/PI**2*
*(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
*LOG(MA**2/MTOP**2))
IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
SINB = TANBT/SQRT(1D0 + TANBT**2)
COSB = 1D0/DSQRT(1D0 + TANBT**2)
G1 = SQRT(ALPHA1*4D0*PI)
G2 = SQRT(ALPHA2*4D0*PI)
G3 = SQRT(ALPHA3*4D0*PI)
HU = RMTOP/V/SINB
HD = MB/V/COSB
CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
*SBOT1,SBOT2,DELTAMT,DELTAMB)
IF(MQ.GT.MUR) TP = TQ - TU
IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
IF(MQ.GT.MUR) TDP = TU
IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
IF(MQ.GT.MD) TPD = TQ - TD
IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
IF(MQ.GT.MD) TDPD = TD
IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
* HD**2*(G1**2/3D0+G2**2)*TPD
IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
* HU**2*(-G1**2/3D0+G2**2)*TP
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
C TWO STOPS.
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
DLAMBDAP2 = 0D0
IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
ENDIF
IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
ENDIF
IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
ENDIF
IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
ENDIF
IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
ENDIF
IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
ENDIF
ENDIF
DLAMBDA3 = 0D0
DLAMBDA4 = 0D0
IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
*(G2**2-G1**2/3D0)*TPD
IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
*1D0/16D0/PI**2*G1**2*HU**2*TP
IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
* 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
*HD**2*TPD
LAMBDA1 = ((G1**2 + G2**2)/4D0)*
* (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
*+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
*+ (3D0*HD**2/2D0 + HU**2/2D0
*- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
*+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
*- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
*(TP + TDP)/8D0/PI**2)
*+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
*+ (3D0*HU**2/2D0 + HD**2/2D0
*- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
*+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
*- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
*(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
LAMBDA4 = (- G2**2/2D0)*(1D0
*-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
*-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
LAMBDA5 = 0D0
LAMBDA6 = 0D0
LAMBDA7 = 0D0
M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
*COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
*COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
*COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
M2(2,1) = M2(1,2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
IF(MCHI.GT.MSSUSY) GOTO 100
IF(MCHI.LT.MTOP) MCHI=MTOP
TCHAR=LOG(MSSUSY**2/MCHI**2)
DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
*+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
DELTAM112=2D0*DELTAL12*V**2*COSB**2
DELTAM222=2D0*DELTAL12*V**2*SINB**2
DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
M2(1,1)=M2(1,1)+DELTAM112
M2(2,2)=M2(2,2)+DELTAM222
M2(1,2)=M2(1,2)+DELTAM122
M2(2,1)=M2(2,1)+DELTAM122
100 CONTINUE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC END OF CHARGINOS/NEUTRALINOS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
DO 120 I = 1,2
DO 110 J = 1,2
M2P(I,J) = M2(I,J) + VH(I,J)
110 CONTINUE
120 CONTINUE
TRM2P = M2P(1,1) + M2P(2,2)
DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
HMP = DSQRT(HM2P)
MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
MCH=DSQRT(MCH2)
IF(MH2P.LT.0.) GOTO 130
MHP = SQRT(MH2P)
SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
IF(COS2ALPHA.GE.0.) THEN
ALPHA = ASIN(SIN2ALPHA)/2D0
ELSE
ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
ENDIF
SA = SIN(ALPHA)
CA = COS(ALPHA)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
130 CONTINUE
RETURN
END
C*********************************************************************
C...PYGFXX
C...Auxiliary to PYRGHM.
SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
* STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
C...Commonblocks.
INTEGER MSTU,MSTJ,KCHG
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYDAT1/,/PYDAT2/
G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
* + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
MQ2 = MQ**2
MUR2 = MUR**2
MD2 = MD**2
TANBA = TANB
SINBA = TANBA/DSQRT(TANBA**2+1D0)
COSBA = SINBA/TANBA
SINB = TANB/DSQRT(TANB**2+1D0)
COSB = SINB/TANB
PI = PARU(1)
MZ = PMAS(23,1)
MW = PMAS(24,1)
SW = 1D0-MW**2/MZ**2
V = 174.1D0
ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
G2 = DSQRT(0.0336D0*4D0*PI)
G1 = DSQRT(0.0101D0*4D0*PI)
IF(MQ.GT.MUR) MST = MQ
IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
MSUSYT = DSQRT(MST**2 + MTOP**2)
IF(MQ.GT.MD) MSB = MQ
IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
MB = PYMRUN(5,MSB**2)
MSUSYB = DSQRT(MSB**2 + MB**2)
TT = LOG(MSUSYT**2/MTOP**2)
TB = LOG(MSUSYB**2/MTOP**2)
RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
HT = RMTOP/(V*SINB)
HTST = RMTOP/V
HB = MB/V/COSB
G32 = ALPHA3*4D0*PI
BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
AL2 = 3D0/8D0/PI**2*HT**2
C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
C ALST = 3./8./PI**2*HTST**2
AL1 = 3D0/8D0/PI**2*HB**2
AL(1,1) = AL1
AL(1,2) = (AL2+AL1)/2D0
AL(2,1) = (AL2+AL1)/2D0
AL(2,2) = AL2
IF(MA.GT.MTOP) THEN
VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
* LOG(MTOP**2/MA**2))
H1I = VI* COSBA
H2I = VI*SINBA
H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
ELSE
VI = V
H1I = VI*COSB
H2I = VI*SINB
H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
ENDIF
TANBST = H2T/H1T
SINBT = TANBST/DSQRT(1D0+TANBST**2)
TANBSB = H2B/H1B
SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
COSBB = SINBB/TANBSB
DELTAMT = 0D0
DELTAMB = 0D0
MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
MTOP2 = DSQRT(MTOP4)
MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
* /(1D0+DELTAMB)**4
MBOT2 = DSQRT(MBOT4)
STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
* +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
* +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
* MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
* +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
* - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
* MQ2 - MUR2)**2*0.25D0
* + MTOP2*(AT-XMU/TANBST)**2)
IF(STOP22.LT.0.) GOTO 120
SBOT12 = (MQ2 + MD2)*.5D0
* - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
* + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
* MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
SBOT22 = (MQ2 + MD2)*.5D0
* - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
* - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
* MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
IF(SBOT22.LT.0.) SBOT22 = 10000D0
STOP1 = DSQRT(STOP12)
STOP2 = DSQRT(STOP22)
SBOT1 = DSQRT(SBOT12)
SBOT2 = DSQRT(SBOT22)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
C INDUCED CORRECTIONS.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
X=SBOT1
Y=SBOT2
Z=XMGL
IF(X.EQ.Y) X = X - 0.00001D0
IF(X.EQ.Z) X = X - 0.00002D0
IF(Y.EQ.Z) Y = Y - 0.00003D0
T1=T(X,Y,Z)
X=STOP1
Y=STOP2
Z=XMU
IF(X.EQ.Y) X = X - 0.00001D0
IF(X.EQ.Z) X = X - 0.00002D0
IF(Y.EQ.Z) Y = Y - 0.00003D0
T2=T(X,Y,Z)
DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
* + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
X=STOP1
Y=STOP2
Z=XMGL
IF(X.EQ.Y) X = X - 0.00001D0
IF(X.EQ.Z) X = X - 0.00002D0
IF(Y.EQ.Z) Y = Y - 0.00003D0
T3=T(X,Y,Z)
DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
MTOP2 = DSQRT(MTOP4)
MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
* /(1D0+DELTAMB)**4
MBOT2 = DSQRT(MBOT4)
STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
* +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
* +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
* MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
* +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
* - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
* MQ2 - MUR2)**2*0.25D0
* + MTOP2*(AT-XMU/TANBST)**2)
IF(STOP22.LT.0.) GOTO 120
SBOT12 = (MQ2 + MD2)*.5D0
* - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
* + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
* MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
SBOT22 = (MQ2 + MD2)*.5D0
* - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
* - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
* MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
IF(SBOT22.LT.0.) GOTO 120
STOP1 = DSQRT(STOP12)
STOP2 = DSQRT(STOP22)
SBOT1 = DSQRT(SBOT12)
SBOT2 = DSQRT(SBOT22)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC D-TERMS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
STW=SW
F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
* LOG(STOP1/STOP2)
* +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
* + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
* LOG(SBOT1/SBOT2)
* +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
* - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
* (-.5D0*LOG(STOP12/STOP22)
* +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
* G(STOP12,STOP22))
F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
* (.5D0*LOG(SBOT12/SBOT22)
* +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
* G(SBOT12,SBOT22))
VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
* (MQ2+MBOT2)/(MD2+MBOT2))
* + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
* LOG(SBOT1**2/SBOT2**2)) +
* MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
* (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
VH3T(1,1) =
* MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
* -STOP2**2))**2*G(STOP12,STOP22)
VH3B(1,1)=VH3B(1,1)+
* MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
VH3T(1,1) = VH3T(1,1) +
* MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
* (MQ2+MTOP2)/(MUR2+MTOP2))
* + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
* LOG(STOP1**2/STOP2**2)) +
* MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
* (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
VH3B(2,2) =
* MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
* -SBOT2**2))**2*G(SBOT12,SBOT22)
VH3T(2,2)=VH3T(2,2)+
* MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
VH3T(1,2) = -
* MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
* (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
* (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
VH3B(1,2) =
* - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
* (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
* (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
VH3T(1,2)=VH3T(1,2) +
*MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
VH3B(1,2)=VH3B(1,2) +
*MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
VH3T(2,1) = VH3T(1,2)
VH3B(2,1) = VH3B(1,2)
C TQ = LOG((MQ2 + MTOP2)/MTOP2)
C TU = LOG((MUR2+MTOP2)/MTOP2)
C TQD = LOG((MQ2 + MB**2)/MB**2)
C TD = LOG((MD2+MB**2)/MB**2)
DO 110 I = 1,2
DO 100 J = 1,2
VH(I,J) =
* 6D0/(8D0*PI**2*(H1T**2+H2T**2))
* *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
* 6D0/(8D0*PI**2*(H1B**2+H2B**2))
* *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
100 CONTINUE
110 CONTINUE
GOTO 150
120 DO 140 I =1,2
DO 130 J = 1,2
VH(I,J) = -1D15
130 CONTINUE
140 CONTINUE
150 RETURN
END
C*********************************************************************
C...PYFINT
C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
FUNCTION PYFINT(A,B,C)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
COMMON/PYINTS/XXM(20)
SAVE/PYINTS/
C...Local variables.
EXTERNAL PYFISB
DOUBLE PRECISION PYFISB
XXM(1)=A
XXM(2)=B
XXM(3)=C
XLO=0D0
XHI=1D0
PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
RETURN
END
C*********************************************************************
C...PYFISB
C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
FUNCTION PYFISB(X)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
COMMON/PYINTS/XXM(20)
SAVE/PYINTS/
PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
&(X*(XXM(2)-XXM(3))+XXM(3)))
RETURN
END
C*********************************************************************
C...PYSFDC
C...Calculates decays of sfermions.
SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
C...Local variables.
COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
INTEGER KFIN,KCIN
DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
DOUBLE PRECISION PYLAMF,XL
DOUBLE PRECISION TANW,XW,AEM,C1,AS
DOUBLE PRECISION AL,AR,BL,BR
DOUBLE PRECISION CH1,CH2,CH3,CH4
DOUBLE PRECISION XMBOT,XMTOP
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3)
INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
DOUBLE PRECISION SR2
DOUBLE PRECISION CBETA,SBETA
DOUBLE PRECISION CW
DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
DOUBLE PRECISION COSA,SINA,TANB
DOUBLE PRECISION PYALEM,PI,PYALPS,EI
DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
INTEGER IG,KF1,KF2
INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
DATA IGG/23,25,35,36/
DATA PI/3.141592654D0/
DATA SR2/1.4142136D0/
DATA KFNCHI/1000022,1000023,1000025,1000035/
DATA KFCCHI/1000024,1000037/
C...COUNT THE NUMBER OF DECAY MODES
LKNT=0
C...NO NU_R DECAYS
IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
&KFIN.EQ.KSUSY2+16) RETURN
XMW=PMAS(24,1)
XMW2=XMW**2
XMZ=PMAS(23,1)
XW=PARU(102)
TANW = SQRT(XW/(1D0-XW))
CW=SQRT(1D0-XW)
DO 110 I=1,4
DO 100 J=1,4
ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
100 CONTINUE
110 CONTINUE
DO 130 I=1,2
DO 120 J=1,2
VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
120 CONTINUE
130 CONTINUE
C...KCIN
KCIN=PYCOMP(KFIN)
C...ILR is 1 for left and 2 for right.
ILR=KFIN/KSUSY1
C...IFL is matching non-SUSY flavour.
IFL=MOD(KFIN,KSUSY1)
C...IDU is weak isospin, 1 for down and 2 for up.
IDU=2-MOD(IFL,2)
XMI=PMAS(KCIN,1)
XMI2=XMI**2
AEM=PYALEM(XMI2)
AS =PYALPS(XMI2)
C1=AEM/XW
XMI3=XMI**3
EI=KCHG(IFL,1)/3D0
XMBOT=PYMRUN(5,XMI2)
XMTOP=PYMRUN(6,XMI2)
TANB=RMSS(5)
BETA=ATAN(TANB)
ALFA=RMSS(18)
CBETA=COS(BETA)
SBETA=TANB*CBETA
SINA=SIN(ALFA)
COSA=COS(ALFA)
XMU=-RMSS(4)
ATRIT=RMSS(16)
ATRIB=RMSS(15)
ATRIL=RMSS(17)
C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
IF(IMSS(11).EQ.1) THEN
XMP=RMSS(29)
IDG=39+KSUSY1
XMGR=PMAS(PYCOMP(IDG),1)
XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
IF(IFL.EQ.5) THEN
XMF=XMBOT
ELSEIF(IFL.EQ.6) THEN
XMF=XMTOP
ELSE
XMF=PMAS(IFL,1)
ENDIF
IF(XMI.GT.XMGR+XMF) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=IFL
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
ENDIF
ENDIF
C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
C...CHARGED DECAYS:
DO 140 IX=1,2
C...DI -> U CHI1-,CHI2-
IF(IDU.EQ.1) THEN
XMFP=PMAS(IFL+1,1)
XMF =PMAS(IFL,1)
C...UI -> D CHI1+,CHI2+
ELSE
XMFP=PMAS(IFL-1,1)
XMF =PMAS(IFL,1)
ENDIF
XMJ=SMW(IX)
AXMJ=ABS(XMJ)
IF(XMI.GE.AXMJ+XMFP) THEN
XMA2=XMJ**2
XMB2=XMFP**2
IF(IDU.EQ.2) THEN
IF(IFL.EQ.6) THEN
XMFP=XMBOT
XMF =XMTOP
ELSEIF(IFL.LT.6) THEN
XMF=0D0
XMFP=0D0
ENDIF
CBL=VMIXC(IX,1)
CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
CAR=0D0
ELSE
IF(IFL.EQ.5) THEN
XMF =XMBOT
XMFP=XMTOP
ELSEIF(IFL.LT.5) THEN
XMF=0D0
XMFP=0D0
ENDIF
CBL=UMIXC(IX,1)
CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
CAR=0D0
ENDIF
CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
CAL=CALP
CBL=CBLP
CAR=CARP
CBR=CBRP
C...F1 -> F` CHI
IF(ILR.EQ.1) THEN
CA=CAL
CB=CBL
C...F2 -> F` CHI
ELSE
CA=CAR
CB=CBR
ENDIF
LKNT=LKNT+1
XL=PYLAMF(XMI2,XMA2,XMB2)
C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
IDLAM(LKNT,3)=0
IF(IDU.EQ.1) THEN
IDLAM(LKNT,1)=-KFCCHI(IX)
IDLAM(LKNT,2)=IFL+1
ELSE
IDLAM(LKNT,1)=KFCCHI(IX)
IDLAM(LKNT,2)=IFL-1
ENDIF
ENDIF
140 CONTINUE
C...NEUTRAL DECAYS
DO 150 IX=1,4
C...DI -> D CHI10
XMF=PMAS(IFL,1)
XMJ=SMZ(IX)
AXMJ=ABS(XMJ)
IF(XMI.GE.AXMJ+XMF) THEN
XMA2=XMJ**2
XMB2=XMF**2
IF(IDU.EQ.1) THEN
IF(IFL.EQ.5) THEN
XMF=XMBOT
ELSEIF(IFL.LT.5) THEN
XMF=0D0
ENDIF
CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
CAR=-2D0*EI*TANW*ZMIXC(IX,1)
CBR=CAL
ELSE
IF(IFL.EQ.6) THEN
XMF=XMTOP
ELSEIF(IFL.LT.5) THEN
XMF=0D0
ENDIF
CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
CAR=-2D0*EI*TANW*ZMIXC(IX,1)
CBR=CAL
ENDIF
CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
CAL=CALP
CBL=CBLP
CAR=CARP
CBR=CBRP
C...F1 -> F CHI
IF(ILR.EQ.1) THEN
CA=CAL
CB=CBL
C...F2 -> F CHI
ELSE
CA=CAR
CB=CBR
ENDIF
LKNT=LKNT+1
XL=PYLAMF(XMI2,XMA2,XMB2)
C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=IFL
IDLAM(LKNT,3)=0
ENDIF
150 CONTINUE
C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
C...IG=23,25,35,36
DO 160 II=1,4
IG=IGG(II)
IF(ILR.EQ.1) GOTO 160
XMB=PMAS(IG,1)
XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
IF(XMI.LT.XMSF1+XMB) GOTO 160
IF(IG.EQ.23) THEN
BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
BR=EI*XW/CW
BLR=0D0
ELSEIF(IG.EQ.25) THEN
IF(IFL.EQ.5) THEN
XMF=XMBOT
ELSEIF(IFL.EQ.6) THEN
XMF=XMTOP
ELSEIF(IFL.LT.5) THEN
XMF=0D0
ELSE
XMF=PMAS(IFL,1)
ENDIF
IF(IDU.EQ.2) THEN
GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
& XMF**2/XMW*COSA/SBETA
GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
& XMF**2/XMW*COSA/SBETA
ELSE
GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
& XMF**2/XMW*(-SINA)/CBETA
GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
& XMF**2/XMW*(-SINA)/CBETA
ENDIF
IF(IFL.EQ.5) THEN
AT=ATRIB
ELSEIF(IFL.EQ.6) THEN
AT=ATRIT
ELSEIF(IFL.EQ.15) THEN
AT=ATRIL
ELSE
AT=0D0
ENDIF
C.........need to complexify
IF(IDU.EQ.2) THEN
GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
& AT*COSA)
ELSE
GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
& AT*SINA)
ENDIF
BL=GHLL
BR=GHRR
BLR=-GHLR
ELSEIF(IG.EQ.35) THEN
IF(IFL.EQ.5) THEN
XMF=XMBOT
ELSEIF(IFL.EQ.6) THEN
XMF=XMTOP
ELSEIF(IFL.LT.5) THEN
XMF=0D0
ELSE
XMF=PMAS(IFL,1)
ENDIF
IF(IDU.EQ.2) THEN
GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
& XMF**2/XMW*SINA/SBETA
GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
& XMF**2/XMW*SINA/SBETA
ELSE
GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
& XMF**2/XMW*COSA/CBETA
GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
& XMF**2/XMW*COSA/CBETA
ENDIF
IF(IFL.EQ.5) THEN
AT=ATRIB
ELSEIF(IFL.EQ.6) THEN
AT=ATRIT
ELSEIF(IFL.EQ.15) THEN
AT=ATRIL
ELSE
AT=0D0
ENDIF
C.........Need to complexify
IF(IDU.EQ.2) THEN
GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
& AT*SINA)
ELSE
GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
& AT*COSA)
ENDIF
BL=GHLL
BR=GHRR
BLR=GHLR
ELSEIF(IG.EQ.36) THEN
GHLL=0D0
GHRR=0D0
IF(IFL.EQ.5) THEN
XMF=XMBOT
ELSEIF(IFL.EQ.6) THEN
XMF=XMTOP
ELSEIF(IFL.LT.5) THEN
XMF=0D0
ELSE
XMF=PMAS(IFL,1)
ENDIF
IF(IFL.EQ.5) THEN
AT=ATRIB
ELSEIF(IFL.EQ.6) THEN
AT=ATRIT
ELSEIF(IFL.EQ.15) THEN
AT=ATRIL
ELSE
AT=0D0
ENDIF
C.........Need to complexify
IF(IDU.EQ.2) THEN
GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
ELSE
GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
ENDIF
BL=GHLL
BR=GHRR
BLR=GHLR
ENDIF
AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
& SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
& (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
LKNT=LKNT+1
IF(IG.EQ.23) THEN
XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
ELSE
XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
ENDIF
IDLAM(LKNT,3)=0
IDLAM(LKNT,1)=KFIN-KSUSY1
IDLAM(LKNT,2)=IG
160 CONTINUE
C...SF -> SF' + W
XMB=PMAS(24,1)
IF(MOD(IFL,2).EQ.0) THEN
KF1=KSUSY1+IFL-1
ELSE
KF1=KSUSY1+IFL+1
ENDIF
KF2=KF1+KSUSY1
XMSF1=PMAS(PYCOMP(KF1),1)
XMSF2=PMAS(PYCOMP(KF2),1)
IF(XMI.GT.XMB+XMSF1) THEN
IF(MOD(IFL,2).EQ.0) THEN
IF(ILR.EQ.1) THEN
AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
ELSE
AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
ENDIF
ELSE
IF(ILR.EQ.1) THEN
AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
ELSE
AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
ENDIF
ENDIF
XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
LKNT=LKNT+1
XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
IDLAM(LKNT,3)=0
IDLAM(LKNT,1)=KF1
IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
ENDIF
IF(XMI.GT.XMB+XMSF2) THEN
IF(MOD(IFL,2).EQ.0) THEN
IF(ILR.EQ.1) THEN
AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
ELSE
AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
ENDIF
ELSE
IF(ILR.EQ.1) THEN
AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
ELSE
AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
ENDIF
ENDIF
XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
LKNT=LKNT+1
XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
IDLAM(LKNT,3)=0
IDLAM(LKNT,1)=KF2
IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
ENDIF
C...SF -> SF' + HC
XMB=PMAS(37,1)
IF(MOD(IFL,2).EQ.0) THEN
KF1=KSUSY1+IFL-1
ELSE
KF1=KSUSY1+IFL+1
ENDIF
KF2=KF1+KSUSY1
XMSF1=PMAS(PYCOMP(KF1),1)
XMSF2=PMAS(PYCOMP(KF2),1)
IF(XMI.GT.XMB+XMSF1) THEN
XMF=0D0
XMFP=0D0
AT=0D0
AB=0D0
IF(MOD(IFL,2).EQ.0) THEN
C...T1-> B1 HC
IF(ILR.EQ.1) THEN
CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
C...T2-> B1 HC
ELSE
CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
ENDIF
IF(IFL.EQ.6) THEN
XMF=XMTOP
XMFP=XMBOT
AT=ATRIT
AB=ATRIB
ENDIF
ELSE
C...B1 -> T1 HC
IF(ILR.EQ.1) THEN
CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
C...B2-> T1 HC
ELSE
CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
ENDIF
IF(IFL.EQ.5) THEN
XMF=XMTOP
XMFP=XMBOT
AT=ATRIT
AB=ATRIB
ENDIF
ENDIF
XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
LKNT=LKNT+1
C.......Need to complexify
AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
& CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
& CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
IDLAM(LKNT,3)=0
IDLAM(LKNT,1)=KF1
IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
ENDIF
IF(XMI.GT.XMB+XMSF2) THEN
XMF=0D0
XMFP=0D0
AT=0D0
AB=0D0
IF(MOD(IFL,2).EQ.0) THEN
C...T1-> B2 HC
IF(ILR.EQ.1) THEN
CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
C...T2-> B2 HC
ELSE
CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
ENDIF
IF(IFL.EQ.6) THEN
XMF=XMTOP
XMFP=XMBOT
AT=ATRIT
AB=ATRIB
ENDIF
ELSE
C...B1 -> T2 HC
IF(ILR.EQ.1) THEN
CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
C...B2-> T2 HC
ELSE
CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
ENDIF
IF(IFL.EQ.5) THEN
XMF=XMTOP
XMFP=XMBOT
AT=ATRIT
AB=ATRIB
ENDIF
ENDIF
XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
LKNT=LKNT+1
C.......Need to complexify
AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
& CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
& CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
IDLAM(LKNT,3)=0
IDLAM(LKNT,1)=KF2
IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
ENDIF
C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
IF(IFL.LE.6) THEN
XMFP=0D0
XMF=0D0
IF(IFL.EQ.6) XMF=PMAS(6,1)
IF(IFL.EQ.5) XMF=PMAS(5,1)
XMJ=PMAS(PYCOMP(KSUSY1+21),1)
AXMJ=ABS(XMJ)
IF(XMI.GE.AXMJ+XMF) THEN
AL=-SFMIX(IFL,3)
BL=SFMIX(IFL,1)
AR=-SFMIX(IFL,4)
BR=SFMIX(IFL,2)
C...F1 -> F CHI
IF(ILR.EQ.1) THEN
XCA=AL
XCB=BL
C...F2 -> F CHI
ELSE
XCA=AR
XCB=BR
ENDIF
LKNT=LKNT+1
XMA2=XMJ**2
XMB2=XMF**2
XL=PYLAMF(XMI2,XMA2,XMB2)
XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
& (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=IFL
IDLAM(LKNT,3)=0
ENDIF
ENDIF
C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
&PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
C...M*M = C1**2 * G**2/(16PI**2)
C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
LKNT=LKNT+1
XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
IDLAM(LKNT,1)=KSUSY1+22
IDLAM(LKNT,2)=4
IDLAM(LKNT,3)=0
ENDIF
C...R-violating sfermion decays (SKANDS).
CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
IKNT=LKNT
XLAM(0)=0D0
DO 170 I=1,IKNT
IF(XLAM(I).LT.0D0) XLAM(I)=0D0
XLAM(0)=XLAM(0)+XLAM(I)
170 CONTINUE
IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
RETURN
END
C*********************************************************************
C...PYGLUI
C...Calculates gluino decay modes.
SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
CC &SFMIX(16,4),
C COMMON/PYINTS/XXM(20)
COMPLEX*16 CXC
COMMON/PYINTC/XXC(10),CXC(8)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
C...Local variables
COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
DOUBLE PRECISION PYLAMF,XL
DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
DOUBLE PRECISION CA,CB,AL,AR,BL,BR
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3)
INTEGER LKNT,IX,ILR,I,IKNT,IFL
DOUBLE PRECISION SR2
DOUBLE PRECISION GAM
DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
EXTERNAL PYGAUS,PYXXZ6
DOUBLE PRECISION PYGAUS,PYXXZ6
DOUBLE PRECISION PREC
INTEGER KFNCHI(4),KFCCHI(2)
DATA PI/3.141592654D0/
DATA SR2/1.4142136D0/
DATA PREC/1D-2/
DATA KFNCHI/1000022,1000023,1000025,1000035/
DATA KFCCHI/1000024,1000037/
C...COUNT THE NUMBER OF DECAY MODES
LKNT=0
IF(KFIN.NE.KSUSY1+21) RETURN
KCIN=PYCOMP(KFIN)
XW=PARU(102)
TANW = SQRT(XW/(1D0-XW))
XMI=PMAS(KCIN,1)
AXMI=ABS(XMI)
XMI2=XMI**2
AEM=PYALEM(XMI2)
AS =PYALPS(XMI2)
C1=AEM/XW
XMI3=AXMI**3
XMI=SIGN(XMI,RMSS(3))
C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
IF(IMSS(11).EQ.1) THEN
XMP=RMSS(29)
IDG=39+KSUSY1
XMGR=PMAS(PYCOMP(IDG),1)
XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
IF(AXMI.GT.XMGR) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=21
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC
ENDIF
ENDIF
C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
DO 110 IFL=1,6
DO 100 ILR=1,2
XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
AXMJ=ABS(XMJ)
XMF=PMAS(IFL,1)
IF(AXMI.GE.AXMJ+XMF) THEN
C...Minus sign difference from gluino-quark-squark feynman rules
AL=SFMIX(IFL,1)
BL=-SFMIX(IFL,3)
AR=SFMIX(IFL,2)
BR=-SFMIX(IFL,4)
C...F1 -> F CHI
IF(ILR.EQ.1) THEN
CA=AL
CB=BL
C...F2 -> F CHI
ELSE
CA=AR
CB=BR
ENDIF
LKNT=LKNT+1
XMA2=XMJ**2
XMB2=XMF**2
XL=PYLAMF(XMI2,XMA2,XMB2)
XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
& (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
IDLAM(LKNT,1)=ILR*KSUSY1+IFL
IDLAM(LKNT,2)=-IFL
IDLAM(LKNT,3)=0
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=0
ENDIF
100 CONTINUE
110 CONTINUE
C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
C...GLUINO -> NI Q QBAR
DO 170 IX=1,4
XMJ=SMZ(IX)
AXMJ=ABS(XMJ)
IF(AXMI.GE.AXMJ) THEN
DO 120 I=1,4
ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
120 CONTINUE
OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
ORPP=DCONJG(OLPP)
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
IA=1
XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
XXC(7)=XXC(5)
XXC(8)=XXC(6)
XXC(9)=1D6
XXC(10)=0D0
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
CXC(1)=0D0
CXC(2)=-GLIJ
CXC(3)=0D0
CXC(4)=DCONJG(GLIJ)
CXC(5)=0D0
CXC(6)=GRIJ
CXC(7)=0D0
CXC(8)=-DCONJG(GRIJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-1
ENDIF
IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-3
ENDIF
130 CONTINUE
IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
GOTO 140
ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
ENDIF
CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
LKNT=LKNT+1
XLAM(LKNT)=GAM
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=5
IDLAM(LKNT,3)=-5
PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
ENDIF
C...U-TYPE QUARKS
140 CONTINUE
IA=2
XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
XXC(7)=XXC(5)
XXC(8)=XXC(6)
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
CXC(2)=-GLIJ
CXC(4)=DCONJG(GLIJ)
CXC(6)=GRIJ
CXC(8)=-DCONJG(GRIJ)
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=2
IDLAM(LKNT,3)=-2
ENDIF
IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=4
IDLAM(LKNT,3)=-4
ENDIF
150 CONTINUE
C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
XMF=PMAS(6,1)
IF(AXMI.GE.AXMJ+2D0*XMF) THEN
PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
GOTO 160
ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
ENDIF
CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
LKNT=LKNT+1
XLAM(LKNT)=GAM
IDLAM(LKNT,1)=KFNCHI(IX)
IDLAM(LKNT,2)=6
IDLAM(LKNT,3)=-6
PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
ENDIF
160 CONTINUE
ENDIF
170 CONTINUE
C...GLUINO -> CI Q QBAR'
DO 210 IX=1,2
XMJ=SMW(IX)
AXMJ=ABS(XMJ)
IF(AXMI.GE.AXMJ) THEN
DO 180 I=1,2
VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
180 CONTINUE
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
XXC(9)=1D6
XXC(10)=0D0
OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
ORPP=DCONJG(OLPP)
CXC(1)=DCMPLX(0D0,0D0)
CXC(3)=DCMPLX(0D0,0D0)
CXC(5)=DCMPLX(0D0,0D0)
CXC(7)=DCMPLX(0D0,0D0)
CXC(2)=UMIXC(IX,1)*OLPP/SR2
CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
CXC(6)=DCMPLX(0D0,0D0)
CXC(8)=DCMPLX(0D0,0D0)
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(IX)
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-2
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ENDIF
IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(IX)
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-4
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ENDIF
190 CONTINUE
XMF=PMAS(6,1)
XMFP=PMAS(5,1)
IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
$ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
CALL PYTBBC(IX,100,XMI,GAM)
LKNT=LKNT+1
XLAM(LKNT)=GAM
IDLAM(LKNT,1)=KFCCHI(IX)
IDLAM(LKNT,2)=5
IDLAM(LKNT,3)=-6
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
ENDIF
200 CONTINUE
ENDIF
210 CONTINUE
C...R-parity violating (3-body) decays.
CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
IKNT=LKNT
XLAM(0)=0D0
DO 220 I=1,IKNT
IF(XLAM(I).LT.0D0) XLAM(I)=0D0
XLAM(0)=XLAM(0)+XLAM(I)
220 CONTINUE
IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
RETURN
END
C*********************************************************************
C...PYTBBN
C...Calculates the three-body decay of gluinos into
C...neutralinos and third generation fermions.
SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
C...Local variables.
EXTERNAL PYSIMP,PYLAMF
DOUBLE PRECISION PYSIMP,PYLAMF
INTEGER LIN,NN
DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
DOUBLE PRECISION XLN1,XLN2,B1,B2
DOUBLE PRECISION E,XMGLU,GAM
DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
SAVE HRB,HLB,FLB,FRB
DOUBLE PRECISION ALPHAW,ALPHAS
DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
SAVE HLT,HRT,FLT,FRT
DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
SAVE AMN,AN,ZN
DOUBLE PRECISION AMBOT,SINC,COSC
DOUBLE PRECISION AMTOP,SINA,COSA
DOUBLE PRECISION SINW,COSW,TANW
DOUBLE PRECISION ROT1(4,4)
LOGICAL IFIRST
SAVE IFIRST
DATA IFIRST/.TRUE./
TANB=RMSS(5)
SINB=TANB/SQRT(1D0+TANB**2)
COSB=SINB/TANB
XW=PARU(102)
SINW=SQRT(XW)
COSW=SQRT(1D0-XW)
TANW=SINW/COSW
AMW=PMAS(24,1)
COSC=SFMIX(5,1)
SINC=SFMIX(5,3)
COSA=SFMIX(6,1)
SINA=SFMIX(6,3)
AMBOT=PYMRUN(5,XMGLU**2)
AMTOP=PYMRUN(6,XMGLU**2)
W2=SQRT(2D0)
FAKT1=AMBOT/W2/AMW/COSB
FAKT2=AMTOP/W2/AMW/SINB
IF(IFIRST) THEN
DO 110 II=1,4
AMN(II)=SMZ(II)
DO 100 J=1,4
ROT1(II,J)=0D0
AN(II,J)=0D0
100 CONTINUE
110 CONTINUE
ROT1(1,1)=COSW
ROT1(1,2)=-SINW
ROT1(2,1)=-ROT1(1,2)
ROT1(2,2)=ROT1(1,1)
ROT1(3,3)=COSB
ROT1(3,4)=SINB
ROT1(4,3)=-ROT1(3,4)
ROT1(4,4)=ROT1(3,3)
DO 140 II=1,4
DO 130 J=1,4
DO 120 JJ=1,4
AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
120 CONTINUE
130 CONTINUE
140 CONTINUE
DO 150 J=1,4
ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
& XW)*AN(J,2)/COSW
HRT(J)=ZN(1)*COSA-ZN(3)*SINA
HLT(J)=ZN(1)*COSA+ZN(2)*SINA
FLT(J)=ZN(3)*COSA+ZN(1)*SINA
FRT(J)=ZN(2)*COSA-ZN(1)*SINA
C FLU(J)=ZN(3)
C FRU(J)=ZN(2)
ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
HRB(J)=ZN(1)*COSC-ZN(3)*SINC
HLB(J)=ZN(1)*COSC+ZN(2)*SINC
FLB(J)=ZN(3)*COSC+ZN(1)*SINC
FRB(J)=ZN(2)*COSC-ZN(1)*SINC
C FLD(J)=ZN(3)
C FRD(J)=ZN(2)
150 CONTINUE
C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
IFIRST=.FALSE.
ENDIF
IF(NINT(3D0*E).EQ.2) THEN
HL=HLT(I)
HR=HRT(I)
FL=FLT(I)
FR=FRT(I)
COSD=SFMIX(6,1)
SIND=SFMIX(6,3)
XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
XM=PMAS(6,1)
ELSE
HL=HLB(I)
HR=HRB(I)
FL=FLB(I)
FR=FRB(I)
COSD=SFMIX(5,1)
SIND=SFMIX(5,3)
XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
XM=PMAS(5,1)
ENDIF
COSD2=COSD*COSD
SIND2=SIND*SIND
COS2D=COSD2-SIND2
SIN2D=SIND*COSD*2D0
HL2=HL*HL
HR2=HR*HR
FL2=FL*FL
FR2=FR*FR
FF=FL*FR
HH=HL*HR
HFL=HL*FL
HFR=HR*FR
HRFL=HR*FL
HLFR=HL*FR
XM2=XM*XM
XMG=XMGLU
XMG2=XMG*XMG
ALPHAW=PYALEM(XMG2)
ALPHAS=PYALPS(XMG2)
XMR=AMN(I)
XMR2=XMR*XMR
XMQ4=XMG*XM2*XMR
XM24=(XMG2+XM2)*(XM2+XMR2)
SMIN=4D0*XM2
SMAX=(XMG-ABS(XMR))**2
XMQA=XMG2+2D0*XM2+XMR2
DO 170 LIN=1,NN-1
SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
GRS=SBAR-XMQA
W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
W=DSQRT(W)
XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
& +2D0*(FF*SIND2-HH*COSD2))*W
G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
& +4D0*HFL*XM*XMR)*XLN1
& +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
& +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
& -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
& +8D0*HFL*XMQ4*SIN2D)*B1
G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
& +4D0*HFR*XMR*XM)*XLN2
& +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
& +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
& +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
& -8D0*HFR*XMQ4*SIN2D)*B2
G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
& +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
& -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
& +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
& -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
& (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
& +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
G(5)=(2D0*(HH*COSD2-FF*SIND2)
& *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
& +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
& +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
& *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
& +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
& +COS2D*XM*(SBAR+XMG2-XMR2))
& +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
& *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
& +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
& -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
& -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
& -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
SUMME(LIN)=0D0
DO 160 J=0,6
SUMME(LIN)=SUMME(LIN)+G(J)
160 CONTINUE
170 CONTINUE
SUMME(0)=0D0
SUMME(NN)=0D0
GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
&/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
RETURN
END
C*********************************************************************
C...PYTBBC
C...Calculates the three-body decay of gluinos into
C...charginos and third generation fermions.
SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
C...Local variables.
EXTERNAL PYSIMP,PYLAMF
DOUBLE PRECISION PYSIMP,PYLAMF
INTEGER I,NN,LIN
DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
DOUBLE PRECISION SUMME(0:100),A(4,8)
DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
DOUBLE PRECISION XMGLU,GAM
DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
&DDD(2),EEE(2),FFF(2)
SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
DOUBLE PRECISION ALPHAW,ALPHAS
DOUBLE PRECISION AMC(2)
SAVE AMC
DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
SAVE AMSB,AMST
LOGICAL IFIRST
SAVE IFIRST
DATA IFIRST/.TRUE./
TANB=RMSS(5)
SINB=TANB/SQRT(1D0+TANB**2)
COSB=SINB/TANB
XW=PARU(102)
AMW=PMAS(24,1)
COSC=SFMIX(5,1)
SINC=SFMIX(5,3)
COSA=SFMIX(6,1)
SINA=SFMIX(6,3)
AMBOT=PYMRUN(5,XMGLU**2)
AMTOP=PYMRUN(6,XMGLU**2)
W2=SQRT(2D0)
AMW=PMAS(24,1)
FAKT1=AMBOT/W2/AMW/COSB
FAKT2=AMTOP/W2/AMW/SINB
IF(IFIRST) THEN
AMC(1)=SMW(1)
AMC(2)=SMW(2)
DO 100 JJ=1,2
CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
100 CONTINUE
AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
IFIRST=.FALSE.
ENDIF
ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
COS2A=COSA**2-SINA**2
SIN2A=SINA*COSA*2D0
COS2C=COSC**2-SINC**2
SIN2C=SINC*COSC*2D0
XMG=XMGLU
XMT=PMAS(6,1)
XMB=PMAS(5,1)
XMR=AMC(I)
XMG2=XMG*XMG
ALPHAW=PYALEM(XMG2)
ALPHAS=PYALPS(XMG2)
XMT2=XMT*XMT
XMB2=XMB*XMB
XMR2=XMR*XMR
XMQ2=XMG2+XMT2+XMB2+XMR2
XMQ4=XMG*XMT*XMB*XMR
XMQ3=XMG2*XMR2+XMT2*XMB2
XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
XMST(1)=AMST(1)*AMST(1)
XMST(2)=AMST(1)*AMST(1)
XMST(3)=AMST(2)*AMST(2)
XMST(4)=AMST(2)*AMST(2)
XMSB(1)=AMSB(1)*AMSB(1)
XMSB(2)=AMSB(2)*AMSB(2)
XMSB(3)=AMSB(1)*AMSB(1)
XMSB(4)=AMSB(2)*AMSB(2)
A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
SMAX=(XMG-ABS(XMR))**2
SMIN=(XMB+XMT)**2+0.1D0
DO 120 LIN=0,NN-1
SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
GRS=SBAR-XMQ2
W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
W=DSQRT(W)/2D0/SBAR
ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
& +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
& +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
& -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
& +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
& +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
& *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
SUMME(LIN)=SUMME(LIN)-ULR(2)*W
& +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
& -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
& +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
& +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
& -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
& +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
& *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
SUMME(LIN)=SUMME(LIN)-VLR(1)*W
& +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
& +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
& +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
& -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
& +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
& +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
& *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
SUMME(LIN)=SUMME(LIN)-VLR(2)*W
& +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
& -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
& +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
& +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
& -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
& +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
& *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
& *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
& *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
& +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
& *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
& *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
& +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
DO 110 J=1,4
SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
& +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
& +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
& +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
& -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
& -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
& *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
& -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
& +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
& +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
& -A(J,6)*(XMG2+XMR2-SBAR)
& -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
& *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
& /(GRS+XMSB(J)+XMST(J))
110 CONTINUE
120 CONTINUE
SUMME(NN)=0D0
GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
&/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
RETURN
END
C*********************************************************************
C...PYNJDC
C...Calculates decay widths for the neutralinos (admixtures of
C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
C...Input: KCIN = KF code for particle
C...Output: XLAM = widths
C... IDLAM = KF codes for decay particles
C... IKNT = number of decay channels defined
C...AUTHOR: STEPHEN MRENNA
C...Last change:
C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
C...when CHIGAMMA .NE. 0
C...10 FEB 96: Calculate this decay for small tan(beta)
SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
c &SFMIX(16,4)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C COMMON/PYINTS/XXM(20)
COMPLEX*16 CXC
COMMON/PYINTC/XXC(10),CXC(8)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
C...Local variables.
COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
INTEGER KFIN
DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
&XMZ,XMZ2,AXMJ,AXMI
DOUBLE PRECISION S12MIN,S12MAX
DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
DOUBLE PRECISION PYLAMF,XL
DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
DOUBLE PRECISION PYX2XH,PYX2XG
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3)
INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
INTEGER ITH(3),KF1,KF2
INTEGER ITHC
DOUBLE PRECISION DH(3),EH(3)
DOUBLE PRECISION SR2
DOUBLE PRECISION CBETA,SBETA
DOUBLE PRECISION GAMCON,XMT1,XMT2
DOUBLE PRECISION PYALEM,PI,PYALPS
DOUBLE PRECISION RAT1,RAT2
DOUBLE PRECISION T3T,FCOL
DOUBLE PRECISION ALFA,BETA,TANB
DOUBLE PRECISION PYXXGA
EXTERNAL PYGAUS,PYXXZ6
DOUBLE PRECISION PYGAUS,PYXXZ6
DOUBLE PRECISION PREC
INTEGER KFNCHI(4),KFCCHI(2)
DATA ITH/25,35,36/
DATA ITHC/37/
DATA PREC/1D-2/
DATA PI/3.141592654D0/
DATA SR2/1.4142136D0/
DATA KFNCHI/1000022,1000023,1000025,1000035/
DATA KFCCHI/1000024,1000037/
C...COUNT THE NUMBER OF DECAY MODES
LKNT=0
XMW=PMAS(24,1)
XMW2=XMW**2
XMZ=PMAS(23,1)
XMZ2=XMZ**2
XW=1D0-XMW2/XMZ2
XW1=1D0-XW
TANW = SQRT(XW/XW1)
C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
IX=1
IF(KFIN.EQ.KFNCHI(2)) IX=2
IF(KFIN.EQ.KFNCHI(3)) IX=3
IF(KFIN.EQ.KFNCHI(4)) IX=4
XMI=SMZ(IX)
XMI2=XMI**2
AXMI=ABS(XMI)
AEM=PYALEM(XMI2)
AS =PYALPS(XMI2)
C1=AEM/XW
XMI3=ABS(XMI**3)
TANB=RMSS(5)
BETA=ATAN(TANB)
ALFA=RMSS(18)
CBETA=COS(BETA)
SBETA=TANB*CBETA
CALFA=COS(ALFA)
SALFA=SIN(ALFA)
DO 110 I=1,4
DO 100 J=1,4
ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
100 CONTINUE
110 CONTINUE
DO 130 I=1,2
DO 120 J=1,2
VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
120 CONTINUE
130 CONTINUE
C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
C...FORCE CHI0_2 -> CHI0_1 + GAMMA
IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
XMJ=SMZ(1)
AXMJ=ABS(XMJ)
LKNT=LKNT+1
GAMCON=AEM**3/8D0/PI/XMW2/XW
XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
IDLAM(LKNT,1)=KSUSY1+22
IDLAM(LKNT,2)=22
IDLAM(LKNT,3)=0
WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
GOTO 340
ENDIF
C...GRAVITINO DECAY MODES
IF(IMSS(11).EQ.1) THEN
XMP=RMSS(29)
IDG=39+KSUSY1
XMGR=PMAS(PYCOMP(IDG),1)
SINW=SQRT(XW)
COSW=SQRT(1D0-XW)
XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=22
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
ENDIF
IF(AXMI.GT.XMGR+XMZ) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=23
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
$ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
& (1D0-XMZ2/XMI2)**4
ENDIF
IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=25
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
$ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
ENDIF
IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=35
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
$ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
ENDIF
IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=36
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
$ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
ENDIF
IF(IX.EQ.1) GOTO 300
ENDIF
DO 220 IJ=1,IX-1
XMJ=SMZ(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
C...CHI0_I -> CHI0_J + GAMMA
IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
& (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=22
IDLAM(LKNT,3)=0
GAMCON=AEM**3/8D0/PI/XMW2/XW
XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
ENDIF
ENDIF
C...CHI0_I -> CHI0_J + Z0
IF(AXMI.GE.AXMJ+XMZ) THEN
LKNT=LKNT+1
OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
& ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
ORPP=-DCONJG(OLPP)
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=23
IDLAM(LKNT,3)=0
ELSEIF(AXMI.GE.AXMJ) THEN
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(9)=XMZ
XXC(10)=PMAS(23,2)
OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
& ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
ORPP=DCONJG(OLPP)
C...CHARGED LEPTONS
FID=11
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
& DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
CXC(2)=-GLIJ
CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
CXC(4)=DCONJG(GLIJ)
CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
CXC(6)=GRIJ
CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
CXC(8)=-DCONJG(GRIJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
IF(XXC(6).LT.AXMI ) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=FID
IDLAM(LKNT,3)=-FID
IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=13
IDLAM(LKNT,3)=-13
ENDIF
ENDIF
140 CONTINUE
IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
ELSE
XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
ENDIF
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
IF(XXC(6).LT.AXMI ) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=15
IDLAM(LKNT,3)=-15
ENDIF
C...NEUTRINOS
150 CONTINUE
FID=12
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
& DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
CXC(2)=-GLIJ
CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
CXC(4)=DCONJG(GLIJ)
CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
CXC(6)=GRIJ
CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
CXC(8)=-DCONJG(GRIJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
IF( XXC(6).LT.AXMI ) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=12
IDLAM(LKNT,3)=-12
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=14
IDLAM(LKNT,3)=-14
160 CONTINUE
IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
& THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
ELSE
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
ENDIF
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=16
IDLAM(LKNT,3)=-16
C...D-TYPE QUARKS
170 CONTINUE
FID=1
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
& DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
CXC(2)=-GLIJ
CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
CXC(4)=DCONJG(GLIJ)
CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
CXC(6)=GRIJ
CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
CXC(8)=-DCONJG(GRIJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
IF( XXC(6).LT.AXMI ) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-1
IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-3
ENDIF
ENDIF
180 CONTINUE
IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
ELSE
XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
ENDIF
IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=5
IDLAM(LKNT,3)=-5
ENDIF
C...U-TYPE QUARKS
190 CONTINUE
FID=2
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
& DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
CXC(2)=-GLIJ
CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
CXC(4)=DCONJG(GLIJ)
CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
CXC(6)=GRIJ
CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
CXC(8)=-DCONJG(GRIJ)
IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=2
IDLAM(LKNT,3)=-2
IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=4
IDLAM(LKNT,3)=-4
ENDIF
ENDIF
200 CONTINUE
ENDIF
C...CHI0_I -> CHI0_J + H0_K
EH(1)=SIN(ALFA)
EH(2)=COS(ALFA)
EH(3)=-SIN(BETA)
DH(1)=COS(ALFA)
DH(2)=-SIN(ALFA)
DH(3)=COS(BETA)
QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
& DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
& TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
& DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
& ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
& TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
& ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
DO 210 IH=1,3
XMH=PMAS(ITH(IH),1)
XMH2=XMH**2
IF(AXMI.GE.AXMJ+XMH) THEN
LKNT=LKNT+1
XL=PYLAMF(XMI2,XMJ2,XMH2)
F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
F12K=F21K
C...SIGN OF MASSES I,J
XMK=XMJ
IF(IH.EQ.3) XMK=-XMK
GX2=ABS(F21K)**2+ABS(F12K)**2
GLR=DBLE(F21K*DCONJG(F12K))
XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=ITH(IH)
IDLAM(LKNT,3)=0
ENDIF
210 CONTINUE
220 CONTINUE
C...CHI0_I -> CHI+_J + W-
DO 260 IJ=1,2
XMJ=SMW(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
IF(AXMI.GE.AXMJ+XMW) THEN
LKNT=LKNT+1
CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
& DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
& ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=-24
IDLAM(LKNT,3)=0
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-KFCCHI(IJ)
IDLAM(LKNT,2)=24
IDLAM(LKNT,3)=0
ELSEIF(AXMI.GE.AXMJ) THEN
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
RT2I = 1D0/SQRT(2D0)
CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
& DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
& ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
CXC(5)=DCMPLX(0D0,0D0)
CXC(7)=DCMPLX(0D0,0D0)
IA=11
JA=12
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
EJ=KCHG(JA,1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
& TANW+ZMIXC(IX,2)*T3J)*RT2I
CXC(4)=-DCONJG(UMIXC(IJ,1))*(
& ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
CXC(6)=DCMPLX(0D0,0D0)
CXC(8)=DCMPLX(0D0,0D0)
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
XXC(9)=PMAS(24,1)
XXC(10)=PMAS(24,2)
IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=11
IDLAM(LKNT,3)=-12
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=13
IDLAM(LKNT,3)=-14
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ENDIF
ENDIF
230 CONTINUE
IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
ELSE
XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
ENDIF
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ENDIF
IF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=15
IDLAM(LKNT,3)=-16
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ENDIF
C...NOW, DO THE QUARKS
240 CONTINUE
IA=1
JA=2
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
EJ=KCHG(JA,1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
& TANW+ZMIXC(IX,2)*T3J)
CXC(4)=-DCONJG(UMIXC(IJ,1))*(
& ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ENDIF
IF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-2
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-4
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ENDIF
ENDIF
250 CONTINUE
ENDIF
260 CONTINUE
270 CONTINUE
C...CHI0_I -> CHI+_I + H-
DO 280 IJ=1,2
XMJ=SMW(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
XMHP=PMAS(ITHC,1)
IF(AXMI.GE.AXMJ+XMHP) THEN
LKNT=LKNT+1
OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
& ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
& (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
& UMIXC(IJ,2)/SR2)
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=-ITHC
IDLAM(LKNT,3)=0
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
ELSE
ENDIF
280 CONTINUE
C...2-BODY DECAYS TO FERMION SFERMION
DO 290 J=1,16
IF(J.GE.7.AND.J.LE.10) GOTO 290
KF1=KSUSY1+J
KF2=KSUSY2+J
XMSF1=PMAS(PYCOMP(KF1),1)
XMSF2=PMAS(PYCOMP(KF2),1)
XMF=PMAS(J,1)
IF(J.LE.6) THEN
FCOL=3D0
ELSE
FCOL=1D0
ENDIF
EI=KCHG(J,1)/3D0
T3T=SIGN(1D0,EI)
IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
IF(MOD(J,2).EQ.0) THEN
CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
CAR=-2D0*EI*TANW*ZMIXC(IX,1)
CBR=CAL
ELSE
CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
CAR=-2D0*EI*TANW*ZMIXC(IX,1)
CBR=CAL
ENDIF
C...D~ D_L
IF(AXMI.GE.XMF+XMSF1) THEN
LKNT=LKNT+1
XMA2=XMSF1**2
XMB2=XMF**2
XL=PYLAMF(XMI2,XMA2,XMB2)
CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
IDLAM(LKNT,1)=KF1
IDLAM(LKNT,2)=-J
IDLAM(LKNT,3)=0
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=0
ENDIF
C...D~ D_R
IF(AXMI.GE.XMF+XMSF2) THEN
LKNT=LKNT+1
XMA2=XMSF2**2
XMB2=XMF**2
CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
XL=PYLAMF(XMI2,XMA2,XMB2)
XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
IDLAM(LKNT,1)=KF2
IDLAM(LKNT,2)=-J
IDLAM(LKNT,3)=0
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=0
ENDIF
290 CONTINUE
300 CONTINUE
C...3-BODY DECAY TO Q Q~ GLUINO
XMJ=PMAS(PYCOMP(KSUSY1+21),1)
IF(AXMI.GE.XMJ) THEN
RT2I = 1D0/SQRT(2D0)
OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
ORPP=DCONJG(OLPP)
AXMJ=ABS(XMJ)
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
FID=1
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
XXC(7)=XXC(5)
XXC(8)=XXC(6)
XXC(9)=1D6
XXC(10)=0D0
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
CXC(1)=0D0
CXC(2)=-GLIJ
CXC(3)=0D0
CXC(4)=DCONJG(GLIJ)
CXC(5)=0D0
CXC(6)=GRIJ
CXC(7)=0D0
CXC(8)=-DCONJG(GRIJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
CMRENNA.This statement must be here to define S12MAX
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
C...ALL QUARKS BUT T
IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-1
IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-3
ENDIF
ENDIF
310 CONTINUE
IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
ELSE
XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
ENDIF
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=5
IDLAM(LKNT,3)=-5
ENDIF
C...U-TYPE QUARKS
320 CONTINUE
FID=2
XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
XXC(7)=XXC(5)
XXC(8)=XXC(6)
EI=KCHG(FID,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
CXC(2)=-GLIJ
CXC(4)=DCONJG(GLIJ)
CXC(6)=GRIJ
CXC(8)=-DCONJG(GRIJ)
IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=2
IDLAM(LKNT,3)=-2
IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=4
IDLAM(LKNT,3)=-4
ENDIF
ENDIF
330 CONTINUE
ENDIF
C...R-violating decay modes (SKANDS).
CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
340 IKNT=LKNT
XLAM(0)=0D0
DO 350 I=1,IKNT
IF(XLAM(I).LT.0D0) XLAM(I)=0D0
XLAM(0)=XLAM(0)+XLAM(I)
350 CONTINUE
IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
RETURN
END
C*********************************************************************
C...PYCJDC
C...Calculate decay widths for the charginos (admixtures of
C...charged Wino and charged Higgsino.
C...Input: KCIN = KF code for particle
C...Output: XLAM = widths
C... IDLAM = KF codes for decay particles
C... IKNT = number of decay channels defined
C...AUTHOR: STEPHEN MRENNA
C...Last change:
C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
C...when CHIENU .NE. 0
SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
CC &SFMIX(16,4),
C COMMON/PYINTS/XXM(20)
COMPLEX*16 CXC
COMMON/PYINTC/XXC(10),CXC(8)
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
C...Local variables
COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
INTEGER KFIN,KCIN
DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
&XMZ,XMZ2,AXMJ,AXMI
DOUBLE PRECISION S12MIN,S12MAX
DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
DOUBLE PRECISION PYLAMF,XL
DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
DOUBLE PRECISION PYX2XH,PYX2XG
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3)
INTEGER LKNT,IX,IH,J,IJ,I,IKNT
INTEGER ITH(3)
INTEGER ITHC
DOUBLE PRECISION ETAH(3),DH(3),EH(3)
DOUBLE PRECISION SR2
DOUBLE PRECISION CBETA,SBETA,TANB
DOUBLE PRECISION PYALEM,PI,PYALPS
DOUBLE PRECISION FCOL
INTEGER KF1,KF2,ISF
INTEGER KFNCHI(4),KFCCHI(2)
DOUBLE PRECISION TEMP
EXTERNAL PYGAUS,PYXXZ6
DOUBLE PRECISION PYGAUS,PYXXZ6
DOUBLE PRECISION PREC
DATA ITH/25,35,36/
DATA ITHC/37/
DATA ETAH/1D0,1D0,-1D0/
DATA SR2/1.4142136D0/
DATA PI/3.141592654D0/
DATA PREC/1D-2/
DATA KFNCHI/1000022,1000023,1000025,1000035/
DATA KFCCHI/1000024,1000037/
C...COUNT THE NUMBER OF DECAY MODES
LKNT=0
XMW=PMAS(24,1)
XMW2=XMW**2
XMZ=PMAS(23,1)
XMZ2=XMZ**2
XW=1D0-XMW2/XMZ2
XW1=1D0-XW
TANW = SQRT(XW/XW1)
C...1 OR 2 DEPENDING ON CHARGINO TYPE
IX=1
IF(KFIN.EQ.KFCCHI(2)) IX=2
KCIN=PYCOMP(KFIN)
XMI=SMW(IX)
XMI2=XMI**2
AXMI=ABS(XMI)
AEM=PYALEM(XMI2)
AS =PYALPS(XMI2)
C1=AEM/XW
XMI3=ABS(XMI**3)
TANB=RMSS(5)
BETA=ATAN(TANB)
CBETA=COS(BETA)
SBETA=TANB*CBETA
ALFA=RMSS(18)
DO 110 I=1,2
DO 100 J=1,2
VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
100 CONTINUE
110 CONTINUE
C...GRAVITINO DECAY MODES
IF(IMSS(11).EQ.1) THEN
XMP=RMSS(29)
IDG=39+KSUSY1
XMGR=PMAS(PYCOMP(IDG),1)
C SINW=SQRT(XW)
C COSW=SQRT(1D0-XW)
XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
IF(AXMI.GT.XMGR+XMW) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=24
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(
& .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
& .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
& (1D0-XMW2/XMI2)**4
ENDIF
IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
LKNT=LKNT+1
IDLAM(LKNT,1)=IDG
IDLAM(LKNT,2)=37
IDLAM(LKNT,3)=0
XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
& (ABS(UMIXC(IX,2))*SBETA)**2))
& *(1D0-PMAS(37,1)**2/XMI2)**4
ENDIF
ENDIF
C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
IF(IX.EQ.1) GOTO 170
XMJ=SMW(1)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
C...CHI_2+ -> CHI_1+ + Z0
IF(AXMI.GE.AXMJ+XMZ) THEN
LKNT=LKNT+1
IJ=1
OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
& VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
& UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=23
IDLAM(LKNT,3)=0
C...CHARGED LEPTONS
ELSEIF(AXMI.GE.AXMJ) THEN
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
IA=11
JA=12
EI=KCHG(IABS(IA),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=1D6
XXC(9)=PMAS(23,1)
XXC(10)=PMAS(23,2)
IJ=1
OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
& VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
& UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
CXC(2)=DCMPLX(0D0,0D0)
CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
CXC(5)=-DCMPLX(EI/XW1)*ORPP
CXC(6)=DCMPLX(0D0,0D0)
CXC(7)=-DCMPLX(EI/XW1)*OLPP
CXC(8)=DCMPLX(0D0,0D0)
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=11
IDLAM(LKNT,3)=-11
IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=13
IDLAM(LKNT,3)=-13
ENDIF
IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=15
IDLAM(LKNT,3)=-15
ENDIF
ENDIF
C...NEUTRINOS
120 CONTINUE
IA=12
JA=11
EI=KCHG(IABS(IA),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=1D6
CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
CXC(5)=-DCMPLX(EI/XW1)*ORPP
CXC(7)=-DCMPLX(EI/XW1)*OLPP
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=12
IDLAM(LKNT,3)=-12
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=14
IDLAM(LKNT,3)=-14
ENDIF
IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
ELSE
XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
ENDIF
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
LKNT=LKNT+1
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=16
IDLAM(LKNT,3)=-16
ENDIF
C...D-TYPE QUARKS
130 CONTINUE
IA=1
JA=2
EI=KCHG(IABS(IA),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=1D6
CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
CXC(2)=DCMPLX(0D0,0D0)
CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
CXC(5)=-DCMPLX(EI/XW1)*ORPP
CXC(6)=DCMPLX(0D0,0D0)
CXC(7)=-DCMPLX(EI/XW1)*OLPP
CXC(8)=DCMPLX(0D0,0D0)
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=1
IDLAM(LKNT,3)=-1
IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=3
IDLAM(LKNT,3)=-3
ENDIF
ENDIF
IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
ELSE
XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
ENDIF
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
LKNT=LKNT+1
XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=5
IDLAM(LKNT,3)=-5
ENDIF
C...U-TYPE QUARKS
140 CONTINUE
IA=2
JA=1
EI=KCHG(IABS(IA),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=1D6
CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
CXC(2)=DCMPLX(0D0,0D0)
CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
CXC(5)=-DCMPLX(EI/XW1)*ORPP
CXC(6)=DCMPLX(0D0,0D0)
CXC(7)=-DCMPLX(EI/XW1)*OLPP
CXC(8)=DCMPLX(0D0,0D0)
IF( XXC(5).LT.AXMI ) THEN
XXC(5)=1D6
ENDIF
XXC(7)=XXC(5)
XXC(8)=XXC(6)
IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=2
IDLAM(LKNT,3)=-2
IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=4
IDLAM(LKNT,3)=-4
ENDIF
ENDIF
150 CONTINUE
ENDIF
C...CHI_2+ -> CHI_1+ + H0_K
EH(2)=COS(ALFA)
EH(1)=SIN(ALFA)
EH(3)=-SBETA
DH(2)=-SIN(ALFA)
DH(1)=COS(ALFA)
DH(3)=COS(BETA)
DO 160 IH=1,3
XMH=PMAS(ITH(IH),1)
XMH2=XMH**2
C...NO 3-BODY OPTION
IF(AXMI.GE.AXMJ+XMH) THEN
LKNT=LKNT+1
XL=PYLAMF(XMI2,XMJ2,XMH2)
OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
& VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
& DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
XMK=XMJ*ETAH(IH)
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
IDLAM(LKNT,1)=KFCCHI(1)
IDLAM(LKNT,2)=ITH(IH)
IDLAM(LKNT,3)=0
ENDIF
160 CONTINUE
C...CHI1 JUMPS TO HERE
170 CONTINUE
C...CHI+_I -> CHI0_J + W+
DO 220 IJ=1,4
XMJ=SMZ(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
IF(AXMI.GE.AXMJ+XMW) THEN
LKNT=LKNT+1
DO 180 I=1,4
ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
180 CONTINUE
CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
& DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
& ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=24
IDLAM(LKNT,3)=0
C...LEPTONS
ELSEIF(AXMI.GE.AXMJ) THEN
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
DO 190 I=1,4
ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
190 CONTINUE
CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
& DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
& ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
CXC(5)=DCMPLX(0D0,0D0)
CXC(7)=DCMPLX(0D0,0D0)
IA=11
JA=12
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
EJ=KCHG(JA,1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
& TANW+ZMIXC(IJ,2)*T3J)/SR2
CXC(4)=-DCONJG(UMIXC(IX,1))*(
& ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
CXC(6)=DCMPLX(0D0,0D0)
CXC(8)=DCMPLX(0D0,0D0)
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
XXC(9)=PMAS(24,1)
XXC(10)=PMAS(24,2)
CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
C...--> 1/(16PI)/M**3*(AEM/XW)**2
IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
LKNT=LKNT+1
TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=-11
IDLAM(LKNT,3)=12
C...ONLY DECAY CHI+1 -> E+ NU_E
IF( IMSS(12).NE. 0 ) GOTO 260
IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=-13
IDLAM(LKNT,3)=14
ENDIF
ENDIF
IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
LKNT=LKNT+1
IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
ELSE
XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
ENDIF
XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=-15
IDLAM(LKNT,3)=16
ENDIF
C...NOW, DO THE QUARKS
200 CONTINUE
IA=1
JA=2
EI=KCHG(IA,1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
EJ=KCHG(JA,1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
& TANW+ZMIXC(IJ,2)*T3J)
CXC(4)=-DCONJG(UMIXC(IX,1))*(
& ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ENDIF
IF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=-1
IDLAM(LKNT,3)=2
IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=-3
IDLAM(LKNT,3)=4
ENDIF
ENDIF
210 CONTINUE
ENDIF
220 CONTINUE
C...CHI+_I -> CHI0_J + H+
DO 230 IJ=1,4
XMJ=SMZ(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
XMHP=PMAS(ITHC,1)
IF(AXMI.GE.AXMJ+XMHP) THEN
LKNT=LKNT+1
OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
& ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
& (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
& UMIXC(IX,2)/SR2)
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=ITHC
IDLAM(LKNT,3)=0
ELSE
ENDIF
230 CONTINUE
C...2-BODY DECAYS TO FERMION SFERMION
DO 240 J=1,16
IF(J.GE.7.AND.J.LE.10) GOTO 240
IF(MOD(J,2).EQ.0) THEN
KF1=KSUSY1+J-1
ELSE
KF1=KSUSY1+J+1
ENDIF
KF2=KF1+KSUSY1
XMSF1=PMAS(PYCOMP(KF1),1)
XMSF2=PMAS(PYCOMP(KF2),1)
XMF=PMAS(J,1)
IF(J.LE.6) THEN
FCOL=3D0
ELSE
FCOL=1D0
ENDIF
C...U~ D_L
IF(MOD(J,2).EQ.0) THEN
XMFP=PMAS(J-1,1)
CAL=UMIXC(IX,1)
CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
CBR=0D0
ISF=J-1
ELSE
XMFP=PMAS(J+1,1)
CAL=VMIXC(IX,1)
CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
CBR=0D0
CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
ISF=J+1
ENDIF
C...~U_L D
IF(AXMI.GE.XMF+XMSF1) THEN
LKNT=LKNT+1
XMA2=XMSF1**2
XMB2=XMF**2
XL=PYLAMF(XMI2,XMA2,XMB2)
CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
IDLAM(LKNT,3)=0
IF(MOD(J,2).EQ.0) THEN
IDLAM(LKNT,1)=-KF1
IDLAM(LKNT,2)=J
ELSE
IDLAM(LKNT,1)=KF1
IDLAM(LKNT,2)=-J
ENDIF
ENDIF
C...U~ D_R
IF(AXMI.GE.XMF+XMSF2) THEN
LKNT=LKNT+1
XMA2=XMSF2**2
XMB2=XMF**2
CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
XL=PYLAMF(XMI2,XMA2,XMB2)
XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
& (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
IDLAM(LKNT,3)=0
IF(MOD(J,2).EQ.0) THEN
IDLAM(LKNT,1)=-KF2
IDLAM(LKNT,2)=J
ELSE
IDLAM(LKNT,1)=KF2
IDLAM(LKNT,2)=-J
ENDIF
ENDIF
240 CONTINUE
C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
C...A 2-BODY -- 2-BODY CHAIN
XMJ=PMAS(PYCOMP(KSUSY1+21),1)
IF(AXMI.GE.XMJ) THEN
AXMJ=ABS(XMJ)
S12MIN=0D0
S12MAX=(AXMI-AXMJ)**2
XXC(1)=0D0
XXC(2)=XMJ
XXC(3)=0D0
XXC(4)=XMI
XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
XXC(9)=1D6
XXC(10)=0D0
OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
ORPP=DCONJG(OLPP)
CXC(1)=DCMPLX(0D0,0D0)
CXC(3)=DCMPLX(0D0,0D0)
CXC(5)=DCMPLX(0D0,0D0)
CXC(7)=DCMPLX(0D0,0D0)
CXC(2)=UMIXC(IX,1)*OLPP/SR2
CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
CXC(6)=DCMPLX(0D0,0D0)
CXC(8)=DCMPLX(0D0,0D0)
IF(XXC(5).LT.AXMI) THEN
XXC(5)=1D6
ELSEIF(XXC(6).LT.AXMI) THEN
XXC(6)=1D6
ENDIF
XXC(7)=XXC(6)
XXC(8)=XXC(5)
IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
& PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=-1
IDLAM(LKNT,3)=2
IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
LKNT=LKNT+1
XLAM(LKNT)=XLAM(LKNT-1)
IDLAM(LKNT,1)=KSUSY1+21
IDLAM(LKNT,2)=-3
IDLAM(LKNT,3)=4
ENDIF
ENDIF
250 CONTINUE
ENDIF
C...R-violating decay modes (SKANDS).
CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
260 IKNT=LKNT
XLAM(0)=0D0
DO 270 I=1,IKNT
XLAM(0)=XLAM(0)+XLAM(I)
IF(XLAM(I).LT.0D0) THEN
WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
& (IDLAM(I,J),J=1,3)
XLAM(I)=0D0
ENDIF
270 CONTINUE
IF(XLAM(0).EQ.0D0) THEN
XLAM(0)=1D-6
WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
WRITE(MSTU(11),*) LKNT
WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
ENDIF
RETURN
END
C*********************************************************************
C...PYXXZ6
C...Used in the calculation of inoi -> inoj + f + ~f.
FUNCTION PYXXZ6(X)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
C COMMON/PYINTS/XXM(20)
COMPLEX*16 CXC
COMMON/PYINTC/XXC(10),CXC(8)
SAVE /PYDAT1/,/PYINTC/
C...Local variables.
COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
DOUBLE PRECISION PYXXZ6,X
DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
DOUBLE PRECISION SIJ
DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
DOUBLE PRECISION OL2
DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
INTEGER I
C...Statement functions.
C...Integral from x to y of (t-a)(b-t) dt.
TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
&LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
&(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
C...Integral from x to y of (t-a)/(b-t) dt.
UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
C...Integral from x to y of 1/(t-a) dt.
TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
XM12=XXC(1)**2
XM22=XXC(2)**2
XM32=XXC(3)**2
S=XXC(4)**2
S13=X
S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
&( (X-XM22-S)**2 -4D0*XM22*S ) )
S23MIN=(S23AVE-S23DEL)
S23MAX=(S23AVE+S23DEL)
XMSD1=XXC(5)**2
XMSD2=XXC(7)**2
XMSU1=XXC(6)**2
XMSU2=XXC(8)**2
XMV=XXC(9)
XMG=XXC(10)
QLLS=CXC(1)
QLLU=CXC(2)
QLRS=CXC(3)
QLRT=CXC(4)
QRLS=CXC(5)
QRLT=CXC(6)
QRRS=CXC(7)
QRRU=CXC(8)
WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
SIJ=2D0*XXC(2)*XXC(4)*S13
IF(XMV.LE.1000D0) THEN
OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
& +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
IF(XXC(5).LE.10000D0) THEN
WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
& TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
& .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
& DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
& .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
& *(S13-XMV**2)/WPROP2
ELSE
WFL1=0D0
ENDIF
IF(XXC(6).LE.10000D0) THEN
WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
& TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
& .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
& DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
& .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
& *(S13-XMV**2)/WPROP2
ELSE
WFL2=0D0
ENDIF
ELSE
WW=0D0
WFL1=0D0
WFL2=0D0
ENDIF
IF(XXC(5).LE.10000D0) THEN
WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
& +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
& - 2D0*DBLE(QLRT*DCONJG(QLLU))*
& SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
ELSE
WF1=0D0
ENDIF
IF(XXC(6).LE.10000D0) THEN
WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
& +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
& - 2D0*DBLE(QRLT*DCONJG(QRRU))*
& SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
ELSE
WF2=0D0
ENDIF
PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
IF(PYXXZ6.LT.0D0) THEN
WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
WRITE(MSTU(11),*) (XXC(I),I=1,5)
WRITE(MSTU(11),*) (XXC(I),I=6,10)
WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
WRITE(MSTU(11),*) S23MIN,S23MAX
PYXXZ6=0D0
ENDIF
RETURN
END
C*********************************************************************
C...PYXXGA
C...Calculates chi0_i -> chi0_j + gamma.
FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
DOUBLE PRECISION F1,F2
F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
RETURN
END
C*********************************************************************
C...PYX2XG
C...Calculates the decay rate for ino -> ino + gauge boson.
FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
DOUBLE PRECISION XL,PYLAMF,C1
DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
XMI2=XM1**2
XMI3=ABS(XM1**3)
XMJ2=XM2**2
XMV2=XM3**2
XL=PYLAMF(XMI2,XMJ2,XMV2)
PYX2XG=C1/8D0/XMI3*SQRT(XL)
&*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
&12D0*GLR*XM1*XM2*XMV2)
RETURN
END
C*********************************************************************
C...PYX2XH
C...Calculates the decay rate for ino -> ino + H.
FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
DOUBLE PRECISION XL,PYLAMF,C1
DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
XMI2=XM1**2
XMI3=ABS(XM1**3)
XMJ2=XM2**2
XMV2=XM3**2
XL=PYLAMF(XMI2,XMJ2,XMV2)
PYX2XH=C1/8D0/XMI3*SQRT(XL)
&*(GX2*(XMI2+XMJ2-XMV2)+
&4D0*GLR*XM1*XM2)
RETURN
END
C*********************************************************************
C...PYHEXT
C...Calculates the non-standard decay modes of the Higgs boson.
C...
C...Author: Stephen Mrenna
C...Last Update: April 2001
C......Allow complex values for Z,U, and V
SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
C...Local variables.
COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
COMPLEX*16 QIJ,RIJ,F21K,F12K
INTEGER KFIN
DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
DOUBLE PRECISION XMI2,XMI3,XMJ2
DOUBLE PRECISION PYLAMF,XL,CF,EI
INTEGER IDU,IFL
DOUBLE PRECISION TANW,XW,AEM,C1,AS
DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3)
INTEGER LKNT,IH,J,IJ,I,IKNT,IK
INTEGER ITH(4)
INTEGER KFNCHI(4),KFCCHI(2)
DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
DOUBLE PRECISION SR2
DOUBLE PRECISION BETA,ALFA
DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
DOUBLE PRECISION PYALEM
DOUBLE PRECISION AL,AR,ALR
DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
DOUBLE PRECISION XMJL,XMJR,XM1,XM2
DATA ITH/25,35,36,37/
DATA ETAH/1D0,1D0,-1D0/
DATA SR2/1.4142136D0/
DATA KFNCHI/1000022,1000023,1000025,1000035/
DATA KFCCHI/1000024,1000037/
C...COUNT THE NUMBER OF DECAY MODES
LKNT=IKNT
XMW=PMAS(24,1)
XMW2=XMW**2
XMZ=PMAS(23,1)
XW=PARU(102)
TANW = SQRT(XW/(1D0-XW))
CW=SQRT(1D0-XW)
C...1 - 4 DEPENDING ON Higgs species.
IH=1
IF(KFIN.EQ.ITH(2)) IH=2
IF(KFIN.EQ.ITH(3)) IH=3
IF(KFIN.EQ.ITH(4)) IH=4
XMI=PMAS(KFIN,1)
XMI2=XMI**2
AXMI=ABS(XMI)
AEM=PYALEM(XMI2)
C1=AEM/XW
XMI3=ABS(XMI**3)
TANB=RMSS(5)
BETA=ATAN(TANB)
CBETA=COS(BETA)
SBETA=TANB*CBETA
ALFA=RMSS(18)
COSA=COS(ALFA)
SINA=SIN(ALFA)
ATRIT=RMSS(16)
ATRIB=RMSS(15)
ATRIL=RMSS(17)
XMUZ=-RMSS(4)
DO 110 I=1,4
DO 100 J=1,4
ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
100 CONTINUE
110 CONTINUE
DO 130 I=1,2
DO 120 J=1,2
VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
120 CONTINUE
130 CONTINUE
IF(IH.EQ.4) GOTO 220
C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
C...H0_K -> CHI0_I + CHI0_J
EH(2)=SINA
EH(1)=COSA
EH(3)=CBETA
DH(2)=COSA
DH(1)=-SINA
DH(3)=SBETA
DO 150 IJ=1,4
XMJ=SMZ(IJ)
AXMJ=ABS(XMJ)
DO 140 IK=1,IJ
XMK=SMZ(IK)
AXMK=ABS(XMK)
IF(AXMI.GE.AXMJ+AXMK) THEN
LKNT=LKNT+1
QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
& ZMIXC(IJ,3)*ZMIXC(IK,2)-
& TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
& ZMIXC(IJ,3)*ZMIXC(IK,1))
RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
& ZMIXC(IJ,4)*ZMIXC(IK,2)-
& TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
& ZMIXC(IJ,4)*ZMIXC(IK,1))
F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
C...SIGN OF MASSES I,J
XML=XMK*ETAH(IH)
GX2=ABS(F12K)**2+ABS(F21K)**2
GLR=DBLE(F12K*DCONJG(F21K))
XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=KFNCHI(IK)
IDLAM(LKNT,3)=0
ENDIF
140 CONTINUE
150 CONTINUE
C...H0_K -> CHI+_I CHI-_J
DO 170 IJ=1,2
XMJ=SMW(IJ)
AXMJ=ABS(XMJ)
DO 160 IK=1,2
XMK=SMW(IK)
AXMK=ABS(XMK)
IF(AXMI.GE.AXMJ+AXMK) THEN
LKNT=LKNT+1
OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
& VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
& VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XML=XMK*ETAH(IH)
XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
IDLAM(LKNT,1)=KFCCHI(IJ)
IDLAM(LKNT,2)=-KFCCHI(IK)
IDLAM(LKNT,3)=0
ENDIF
160 CONTINUE
170 CONTINUE
C...HIGGS TO SFERMION SFERMION
DO 200 IFL=1,16
IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
IJ=KSUSY1+IFL
XMJL=PMAS(PYCOMP(IJ),1)
XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
XMJ=XMJL
XMJ2=XMJ**2
XL=PYLAMF(XMI2,XMJ2,XMJ2)
XMF=PMAS(IFL,1)
EI=KCHG(IFL,1)/3D0
IDU=2-MOD(IFL,2)
IF(IH.EQ.1) THEN
IF(IDU.EQ.1) THEN
GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
& XMF**2/XMW*SINA/CBETA
GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
& XMF**2/XMW*SINA/CBETA
IF(IFL.EQ.5) THEN
GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
& ATRIB*SINA)
ELSEIF(IFL.EQ.15) THEN
GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
& ATRIL*SINA)
ELSE
GHLR=0D0
ENDIF
ELSE
GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
& XMF**2/XMW*COSA/SBETA
GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
& XMF**2/XMW*COSA/SBETA
IF(IFL.EQ.6) THEN
GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
& ATRIT*COSA)
ELSE
GHLR=0D0
ENDIF
ENDIF
ELSEIF(IH.EQ.2) THEN
IF(IDU.EQ.1) THEN
GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
& XMF**2/XMW*COSA/CBETA
GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
& XMF**2/XMW*COSA/CBETA
IF(IFL.EQ.5) THEN
GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
& ATRIB*COSA)
ELSEIF(IFL.EQ.15) THEN
GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
& ATRIL*COSA)
ELSE
GHLR=0D0
ENDIF
ELSE
GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
& XMF**2/XMW*SINA/SBETA
GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
& XMF**2/XMW*SINA/SBETA
IF(IFL.EQ.6) THEN
GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
& ATRIT*SINA)
ELSE
GHLR=0D0
ENDIF
ENDIF
ELSEIF(IH.EQ.3) THEN
GHLL=0D0
GHRR=0D0
GHLR=0D0
IF(IDU.EQ.1) THEN
IF(IFL.EQ.5) THEN
GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
ELSEIF(IFL.EQ.15) THEN
GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
ENDIF
ELSE
IF(IFL.EQ.6) THEN
GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
ENDIF
ENDIF
ENDIF
IF(IH.EQ.3) GOTO 180
AL=SFMIX(IFL,1)**2
AR=SFMIX(IFL,2)**2
ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
IF(IFL.LE.6) THEN
CF=3D0
ELSE
CF=1D0
ENDIF
IF(AXMI.GE.2D0*XMJ) THEN
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GHLL*AL+GHRR*AR
& +2D0*GHLR*ALR)**2
IDLAM(LKNT,1)=IJ
IDLAM(LKNT,2)=-IJ
IDLAM(LKNT,3)=0
ENDIF
IF(AXMI.GE.2D0*XMJR) THEN
LKNT=LKNT+1
AL=SFMIX(IFL,3)**2
AR=SFMIX(IFL,4)**2
ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
XMJ=XMJR
XMJ2=XMJ**2
XL=PYLAMF(XMI2,XMJ2,XMJ2)
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GHLL*AL+GHRR*AR
& +2D0*GHLR*ALR)**2
IDLAM(LKNT,1)=IJ+KSUSY1
IDLAM(LKNT,2)=-(IJ+KSUSY1)
IDLAM(LKNT,3)=0
ENDIF
180 CONTINUE
IF(AXMI.GE.XMJL+XMJR) THEN
LKNT=LKNT+1
AL=SFMIX(IFL,1)*SFMIX(IFL,3)
AR=SFMIX(IFL,2)*SFMIX(IFL,4)
ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
XMJ=XMJR
XMJ2=XMJ**2
XL=PYLAMF(XMI2,XMJ2,XMJL**2)
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GHLL*AL+GHRR*AR)**2
IDLAM(LKNT,1)=IJ
IDLAM(LKNT,2)=-(IJ+KSUSY1)
IDLAM(LKNT,3)=0
LKNT=LKNT+1
IDLAM(LKNT,1)=-IJ
IDLAM(LKNT,2)=IJ+KSUSY1
IDLAM(LKNT,3)=0
XLAM(LKNT)=XLAM(LKNT-1)
ENDIF
ENDIF
190 CONTINUE
200 CONTINUE
210 CONTINUE
GOTO 270
220 CONTINUE
C...H+ -> CHI+_I + CHI0_J
DO 240 IJ=1,4
XMJ=SMZ(IJ)
AXMJ=ABS(XMJ)
XMJ2=XMJ**2
DO 230 IK=1,2
XMK=SMW(IK)
AXMK=ABS(XMK)
IF(AXMI.GE.AXMJ+AXMK) THEN
LKNT=LKNT+1
OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
& ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
& (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
GX2=ABS(OLPP)**2+ABS(ORPP)**2
GLR=DBLE(OLPP*DCONJG(ORPP))
XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
IDLAM(LKNT,1)=KFNCHI(IJ)
IDLAM(LKNT,2)=KFCCHI(IK)
IDLAM(LKNT,3)=0
ENDIF
230 CONTINUE
240 CONTINUE
GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
AL=0D0
AR=0D0
CF=3D0
C...H+ -> T_1 B_1~
XM1=PMAS(PYCOMP(KSUSY1+6),1)
XM2=PMAS(PYCOMP(KSUSY1+5),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
IDLAM(LKNT,1)=KSUSY1+6
IDLAM(LKNT,2)=-(KSUSY1+5)
IDLAM(LKNT,3)=0
ENDIF
C...H+ -> T_2 B_1~
XM1=PMAS(PYCOMP(KSUSY2+6),1)
XM2=PMAS(PYCOMP(KSUSY1+5),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
IDLAM(LKNT,1)=KSUSY2+6
IDLAM(LKNT,2)=-(KSUSY1+5)
IDLAM(LKNT,3)=0
ENDIF
C...H+ -> T_1 B_2~
XM1=PMAS(PYCOMP(KSUSY1+6),1)
XM2=PMAS(PYCOMP(KSUSY2+5),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
IDLAM(LKNT,1)=KSUSY1+6
IDLAM(LKNT,2)=-(KSUSY2+5)
IDLAM(LKNT,3)=0
ENDIF
C...H+ -> T_2 B_2~
XM1=PMAS(PYCOMP(KSUSY2+6),1)
XM2=PMAS(PYCOMP(KSUSY2+5),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
& (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
IDLAM(LKNT,1)=KSUSY2+6
IDLAM(LKNT,2)=-(KSUSY2+5)
IDLAM(LKNT,3)=0
ENDIF
C...H+ -> UL DL~
GL=-XMW/SR2*SIN(2D0*BETA)
DO 250 IJ=1,3,2
XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
IDLAM(LKNT,1)=-(KSUSY1+IJ)
IDLAM(LKNT,2)=KSUSY1+IJ+1
IDLAM(LKNT,3)=0
ENDIF
250 CONTINUE
C...H+ -> EL~ NUL
CF=1D0
DO 260 IJ=11,13,2
XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
IDLAM(LKNT,1)=-(KSUSY1+IJ)
IDLAM(LKNT,2)=KSUSY1+IJ+1
IDLAM(LKNT,3)=0
ENDIF
260 CONTINUE
C...H+ -> TAU1 NUTAUL
XM1=PMAS(PYCOMP(KSUSY1+15),1)
XM2=PMAS(PYCOMP(KSUSY1+16),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
IDLAM(LKNT,1)=-(KSUSY1+15)
IDLAM(LKNT,2)= KSUSY1+16
IDLAM(LKNT,3)=0
ENDIF
C...H+ -> TAU2 NUTAUL
XM1=PMAS(PYCOMP(KSUSY2+15),1)
XM2=PMAS(PYCOMP(KSUSY1+16),1)
IF(XMI.GE.XM1+XM2) THEN
XL=PYLAMF(XMI2,XM1**2,XM2**2)
LKNT=LKNT+1
XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
IDLAM(LKNT,1)=-(KSUSY2+15)
IDLAM(LKNT,2)= KSUSY1+16
IDLAM(LKNT,3)=0
ENDIF
270 CONTINUE
IKNT=LKNT
XLAM(0)=0D0
DO 280 I=1,IKNT
IF(XLAM(I).LE.0D0) XLAM(I)=0D0
XLAM(0)=XLAM(0)+XLAM(I)
280 CONTINUE
IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
RETURN
END
C*********************************************************************
C...PYH2XX
C...Calculates the decay rate for a Higgs to an ino pair.
FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYDAT1/
C...Local variables.
DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
DOUBLE PRECISION XL,PYLAMF,C1
DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
XMI2=XM1**2
XMI3=ABS(XM1**3)
XMJ2=XM2**2
XMK2=XM3**2
XL=PYLAMF(XMI2,XMJ2,XMK2)
PYH2XX=C1/4D0/XMI3*SQRT(XL)
&*(GX2*(XMI2-XMJ2-XMK2)-
&4D0*GLR*XM3*XM2)
IF(PYH2XX.LT.0D0) PYH2XX=0D0
RETURN
END
C*********************************************************************
C...PYGAUS
C...Integration by adaptive Gaussian quadrature.
C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
FUNCTION PYGAUS(F, A, B, EPS)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local declarations.
EXTERNAL F
DOUBLE PRECISION F,W(12), X(12)
DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
C...The Gaussian quadrature algorithm.
H = 0D0
IF(B .EQ. A) GOTO 140
CONST = 5D-3 / ABS(B-A)
BB = A
100 CONTINUE
AA = BB
BB = B
110 CONTINUE
C1 = 0.5D0*(BB+AA)
C2 = 0.5D0*(BB-AA)
S8 = 0D0
DO 120 I = 1, 4
U = C2*X(I)
S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
120 CONTINUE
S16 = 0D0
DO 130 I = 5, 12
U = C2*X(I)
S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
130 CONTINUE
S16 = C2*S16
IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
H = H + S16
IF(BB .NE. B) GOTO 100
ELSE
BB = C1
IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
H = 0D0
CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
GOTO 140
ENDIF
140 CONTINUE
PYGAUS = H
RETURN
END
C*********************************************************************
C...PYGAU2
C...Integration by adaptive Gaussian quadrature.
C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
C...Carbon copy of PYGAUS, but avoids having to use it recursively.
FUNCTION PYGAU2(F, A, B, EPS)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local declarations.
EXTERNAL F
DOUBLE PRECISION F,W(12), X(12)
DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
C...The Gaussian quadrature algorithm.
H = 0D0
IF(B .EQ. A) GOTO 140
CONST = 5D-3 / ABS(B-A)
BB = A
100 CONTINUE
AA = BB
BB = B
110 CONTINUE
C1 = 0.5D0*(BB+AA)
C2 = 0.5D0*(BB-AA)
S8 = 0D0
DO 120 I = 1, 4
U = C2*X(I)
S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
120 CONTINUE
S16 = 0D0
DO 130 I = 5, 12
U = C2*X(I)
S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
130 CONTINUE
S16 = C2*S16
IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
H = H + S16
IF(BB .NE. B) GOTO 100
ELSE
BB = C1
IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
H = 0D0
CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
GOTO 140
ENDIF
140 CONTINUE
PYGAU2 = H
RETURN
END
C*********************************************************************
C...PYSIMP
C...Simpson formula for an integral.
FUNCTION PYSIMP(Y,X0,X1,N)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION Y,X0,X1,H,S
DIMENSION Y(0:N)
S=0D0
H=(X1-X0)/N
DO 100 I=0,N-2,2
S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
100 CONTINUE
PYSIMP=S*H/3D0
RETURN
END
C*********************************************************************
C...PYLAMF
C...The standard lambda function.
FUNCTION PYLAMF(X,Y,Z)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Local variables.
DOUBLE PRECISION PYLAMF,X,Y,Z
PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
IF(PYLAMF.LT.0D0) PYLAMF=0D0
RETURN
END
C*********************************************************************
C...PYTBDY
C...Generates 3-body decays of gauginos.
SUBROUTINE PYTBDY(IDIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/
C...Local variables.
DOUBLE PRECISION XM(5)
COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
DOUBLE PRECISION CPHI1,SPHI1
DOUBLE PRECISION S23DEL,EPS
DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
DOUBLE PRECISION F1,F2,X0,X1,X2,X3
INTEGER INOID(4)
DATA INOID/22,23,25,35/
DATA EPS/1D-6/
ID=IDIN
ISKIP=1
XM(1)=P(N+1,5)
XM(2)=P(N+2,5)
XM(3)=P(N+3,5)
XM(5)=P(ID,5)
C...GENERATE S12
S12MIN=(XM(1)+XM(2))**2
S12MAX=(XM(5)-XM(3))**2
YJACO1=S12MAX-S12MIN
C...Initialize some parameters
XW=PARU(102)
XW1=1D0-XW
TANW=SQRT(XW/XW1)
IZID1=0
IWID1=0
IZID2=0
IWID2=0
IA=K(N+2,2)
JA=K(N+3,2)
C...Mrenna: check that we are indeed decaying a SUSY particle
IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
ELSE
DO 100 I1=1,4
IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
100 CONTINUE
IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
ZM12=XM(5)**2
ZM22=XM(1)**2
EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
ENDIF
IF(MSTP(47).EQ.0) THEN
ISKIP=0
ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
ISKIP=0
ELSEIF(IZID1*IZID2.NE.0) THEN
SQMZ=PMAS(23,1)**2
GMMZ=PMAS(23,1)*PMAS(23,2)
DO 110 I=1,4
ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
110 CONTINUE
OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
& ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
ORPP=DCONJG(OLPP)
XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
XLR2=XLL2
XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
XRL2=XRR2
GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
& DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
XM1M2=SMZ(IZID1)*SMZ(IZID2)
QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
QLLU=-GLIJ
QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
QLRT=DCONJG(GLIJ)
QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
QRLT=GRIJ
QRRS=DCMPLX((EI*XW)/XW1)*ORPP
QRRU=-DCONJG(GRIJ)
ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
IF(IZID1.NE.0) THEN
XM1M2=SMZ(IZID1)*SMW(IWID2)
IZID1=IWID2
IZID2=IZID1
ELSE
XM1M2=SMZ(IZID2)*SMW(IWID1)
IZID1=IWID1
ENDIF
RT2I = 1D0/SQRT(2D0)
SQMZ=PMAS(24,1)**2
GMMZ=PMAS(24,1)*PMAS(24,2)
DO 120 I=1,2
VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
120 CONTINUE
DO 130 I=1,4
ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
130 CONTINUE
QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
& DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
& ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
EJ=KCHG(IABS(JA),1)/3D0
T3J=SIGN(1D0,EJ+1D-6)/2D0
QRLS=DCMPLX(0D0,0D0)
QRLT=QRLS
QRRS=QRLS
QRRU=QRLS
XRR2=1D6**2
XRL2=XRR2
XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
IF(MOD(IA,2).EQ.0) THEN
QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
& TANW+ZMIXC(IZID2,2)*T3I)
QLRT=-DCONJG(UMIXC(IZID1,1))*(
& ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
ELSE
QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
& TANW+ZMIXC(IZID2,2)*T3J)
QLRT=-DCONJG(UMIXC(IZID1,1))*(
& ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
ENDIF
ELSEIF(IWID1*IWID2.NE.0) THEN
IZID1=IWID1
IZID2=IWID2
XM1M2=SMW(IWID1)*SMW(IWID2)
SQMZ=PMAS(23,1)**2
GMMZ=PMAS(23,1)*PMAS(23,2)
DO 140 I=1,2
VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
140 CONTINUE
OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
& VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
& UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
QRLS=-DCMPLX(EI/XW1)*ORPP
QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
QRRS=-DCMPLX(EI/XW1)*OLPP
QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
IF(MOD(IA,2).EQ.0) THEN
XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
ELSE
XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
ENDIF
ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
&THEN
ISKIP=0
ELSE
ISKIP=0
ENDIF
IF(ISKIP.NE.0) THEN
WTMAX=0D0
DO 160 KT=1,100
S12=S12MIN+YJACO1*(KT-1)/99
S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
& *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
S23DF1=(S12-XM(2)**2-XM(1)**2)**2
& -(2D0*XM(1)*XM(2))**2
S23DF2=(S12-XM(3)**2-XM(5)**2)**2
& -(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
S23DEL=S23DEL/EPS
S23MIN=S23AVE-S23DEL
S23MAX=S23AVE+S23DEL
YJACO2=S23MAX-S23MIN
TH=S12
DO 150 KS=1,100
S23=S23MIN+YJACO2*(KS-1)/99
SH=S23
UH=ZM12+ZM22-SH-TH
WU2 = (UH-ZM12)*(UH-ZM22)
WT2 = (TH-ZM12)*(TH-ZM22)
WS2 = XM1M2*SH
PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
& (ABS(QRL)**2+ABS(QLR)**2)*WT2+
& 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
IF(WT0.GT.WTMAX) WTMAX=WT0
150 CONTINUE
160 CONTINUE
WTMAX=WTMAX*1.05D0
ENDIF
C...FIND S12*
AX=S12MIN
CX=S12MAX
BX=S12MIN+0.5D0*YJACO1
X0=AX
X3=CX
IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
X1=BX
X2=BX+C*(CX-BX)
ELSE
X2=BX
X1=BX-C*(BX-AX)
ENDIF
C...SOLVE FOR F1 AND F2
S23DF1=(X1-XM(2)**2-XM(1)**2)**2
&-(2D0*XM(1)*XM(2))**2
S23DF2=(X1-XM(3)**2-XM(5)**2)**2
&-(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
F1=-2D0*S23DEL/EPS
S23DF1=(X2-XM(2)**2-XM(1)**2)**2
&-(2D0*XM(1)*XM(2))**2
S23DF2=(X2-XM(3)**2-XM(5)**2)**2
&-(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
F2=-2D0*S23DEL/EPS
170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
IF(F2.LE.F1)THEN
X0=X1
X1=X2
X2=R*X1+C*X3
F1=F2
S23DF1=(X2-XM(2)**2-XM(1)**2)**2
& -(2D0*XM(1)*XM(2))**2
S23DF2=(X2-XM(3)**2-XM(5)**2)**2
& -(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
F2=-2D0*S23DEL/EPS
ELSE
X3=X2
X2=X1
X1=R*X2+C*X0
F2=F1
S23DF1=(X1-XM(2)**2-XM(1)**2)**2
& -(2D0*XM(1)*XM(2))**2
S23DF2=(X1-XM(3)**2-XM(5)**2)**2
& -(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
F1=-2D0*S23DEL/EPS
ENDIF
GOTO 170
ENDIF
C...WE WANT THE MAXIMUM, NOT THE MINIMUM
IF(F1.LT.F2)THEN
GOLDEN=-F1
XMIN=X1
ELSE
GOLDEN=-F2
XMIN=X2
ENDIF
IKNT=0
180 S12=S12MIN+PYR(0)*YJACO1
IKNT=IKNT+1
C...GENERATE S23
S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
&*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
S23DF1=(S12-XM(2)**2-XM(1)**2)**2
&-(2D0*XM(1)*XM(2))**2
S23DF2=(S12-XM(3)**2-XM(5)**2)**2
&-(2D0*XM(3)*XM(5))**2
S23DF1=S23DF1*EPS
S23DF2=S23DF2*EPS
S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
S23DEL=S23DEL/EPS
S23MIN=S23AVE-S23DEL
S23MAX=S23AVE+S23DEL
YJACO2=S23MAX-S23MIN
S23=S23MIN+PYR(0)*YJACO2
C...CHECK THE SAMPLING
IF(IKNT.GT.100) THEN
WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
GOTO 190
ENDIF
IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
IF(ISKIP.EQ.0) GOTO 190
SH=S23
TH=S12
UH=ZM12+ZM22-SH-TH
WU2 = (UH-ZM12)*(UH-ZM22)
WT2 = (TH-ZM12)*(TH-ZM22)
WS2 = XM1M2*SH
PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
c &/DCMPLX(TH-XML2)
c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
&(ABS(QRL)**2+ABS(QLR)**2)*WT2+
&2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
IF(WT.LT.PYR(0)*WTMAX) GOTO 180
IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
D2=XM(5)-D1-D3
P1=SQRT(D1*D1-XM(1)**2)
P2=SQRT(D2*D2-XM(2)**2)
P3=SQRT(D3*D3-XM(3)**2)
CTHE1=2D0*PYR(0)-1D0
ANG1=2D0*PYR(0)*PARU(1)
CPHI1=COS(ANG1)
SPHI1=SIN(ANG1)
ARG=1D0-CTHE1**2
IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
STHE1=SQRT(ARG)
P(N+1,1)=P1*STHE1*CPHI1
P(N+1,2)=P1*STHE1*SPHI1
P(N+1,3)=P1*CTHE1
P(N+1,4)=D1
C...GET CPHI3
ANG3=2D0*PYR(0)*PARU(1)
CPHI3=COS(ANG3)
SPHI3=SIN(ANG3)
CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
ARG=1D0-CTHE3**2
IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
STHE3=SQRT(ARG)
P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
&+P3*STHE3*SPHI3*SPHI1
&+P3*CTHE3*STHE1*CPHI1
P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
&-P3*STHE3*SPHI3*CPHI1
&+P3*CTHE3*STHE1*SPHI1
P(N+3,3)=P3*STHE3*CPHI3*STHE1
&+P3*CTHE3*CTHE1
P(N+3,4)=D3
DO 200 I=1,3
P(N+2,I)=-P(N+1,I)-P(N+3,I)
200 CONTINUE
P(N+2,4)=D2
RETURN
END
C*********************************************************************
C...PYTECM
C...Finds the s-hat dependent eigenvalues of the inverse propagator
C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
C...phase space generation. Extended to include techni-a meson, and
C...to return the width.
SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
C...Local variables.
DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
&AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
&FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
INTEGER i,j,ierr
SH=SMIN
SHR=SQRT(SH)
AEM=PYALEM(SH)
SINW=MIN(SQRT(PARU(102)),1D0)
COSW=SQRT(1D0-SINW**2)
TANW=SINW/COSW
CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
QUPD=2D0*RTCM(2)-1D0
ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
FWR=FAR/(2D0*SINW)
FWX=-FWR/RTCM(47)
DO 110 I=1,5
DO 100 J=1,5
AT(I,J)=0D0
100 CONTINUE
110 CONTINUE
C...NC
IF(IOPT.EQ.1) THEN
AR(1,1) = SH
AR(2,2) = SH-PMAS(23,1)**2
AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
AR(1,2) = 0D0
AR(2,1) = 0D0
AR(1,3) = SH*FAR
AR(3,1) = AR(1,3)
AR(1,4) = SH*FAO
AR(4,1) = AR(1,4)
AR(2,3) = SH*FZR
AR(3,2) = AR(2,3)
AR(2,4) = SH*FZO
AR(4,2) = AR(2,4)
AR(3,4) = 0D0
AR(4,3) = 0D0
AR(2,5) = SH*FZX
AR(5,2) = AR(2,5)
AR(1,5) = 0D0
AR(5,1) = AR(1,5)
AR(3,5) = 0D0
AR(5,3) = AR(3,5)
AR(4,5) = 0D0
AR(5,4) = AR(4,5)
CALL PYWIDT(23,SH,WDTP,WDTE)
AT(2,2) = WDTP(0)*SHR
CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
AT(3,3) = WDTP(0)*SHR
CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
AT(4,4) = WDTP(0)*SHR
CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
AT(5,5) = WDTP(0)*SHR
IDIM=5
C...CC
ELSE
AR(1,1) = SH-PMAS(24,1)**2
AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
AR(1,2) = SH*FWR
AR(2,1) = AR(1,2)
AR(1,3) = SH*FWX
AR(3,1) = AR(1,3)
AR(2,3) = 0D0
AR(3,2) = 0D0
CALL PYWIDT(24,SH,WDTP,WDTE)
AT(1,1) = WDTP(0)*SHR
CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
AT(2,2) = WDTP(0)*SHR
CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
AT(3,3) = WDTP(0)*SHR
IDIM=3
ENDIF
CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
IMIN=1
SXMN=1D20
DO 120 I=1,IDIM
WX(I)=SQRT(ABS(SH-WR(I)))
WR(I)=ABS(WR(I))
IF(WR(I).LT.SXMN) THEN
SXMN=WR(I)
IMIN=I
ENDIF
120 CONTINUE
SMOU=WX(IMIN)**2
WIDO=WI(IMIN)/SHR
RETURN
END
C*********************************************************************
C...PYXDIN
C...Universal Extra Dimensions Model (UED)
C...Initialize the xd masses and widths
C...M. ELKACIMI 4/03/2006
C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
SUBROUTINE PYXDIN
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
C...UED Pythia common
COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...SAVE statements
SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
C...Print out some info about the UED model
WRITE(MSTU(11),7000)
& ' ',
& '********** PYXDIN: initialization of UED ******************',
& ' ',
& 'Universal Extra Dimensions (UED) switched on ',
& ' ',
& 'This implementation is courtesy of',
& ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
& ' see [hep-ph/0602198] (Les Houches 2005) ',
& ' ',
& 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
& 'Dobrescu), with gravity-mediated decay widths calculated in',
& '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
& 'radiative corrections to the KK masses from [hep/ph0204342]',
& '(Cheng, Matchev, Schmaltz).'
WRITE(MSTU(11),7000)
& ' ',
& 'SM particles can propagate into one small extra dimension ',
& 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
& 'graviton is further allowed to propagate into N = IUED(4)',
& 'large (eV^-1) extra dimensions.'
WRITE(MSTU(11),7000)
& ' ',
& 'The switches and parameters for UED are:',
& ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
& ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
& ' IUED(3): (D=5) number of quark flavours',
& ' IUED(4): (D=6) number of large extra dimensions into',
& ' which the graviton propagates',
& ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
& ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
& ' ',
& ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
& ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
& ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
& ' when IUED(5)=0',
& ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
WRITE(MSTU(11),7000)
& ' ',
& 'N.B.: the Higgs mass is also a free parameter of the UED ',
& 'model, but is set through pmas(25,1).',
& ' '
C...Hardcoded switch, required by current implementation
CALL PYGIVE('MSTP(42)=0')
C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
C...Calculated the radiative corrections to the KK particle masses
CALL PYUEDC
C...Initialize the graviton mass
C...only if the KK particles decays gravitationally
IF(IUED(2).EQ.1) CALL PYGRAM(0)
WRITE(MSTU(11),7000)
& '********** PYXDIN: UED initialization completed ***********'
C...Format to use for comments
7000 FORMAT(' * ',A)
RETURN
END
C*********************************************************************
C...PYUEDC
C...Auxiliary to PYXDIN
C...Mass kk states radiative corrections
C...Radiative corrections are included (hep/ph0204342)
SUBROUTINE PYUEDC
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
PARAMETER(KKPART=25,KKFLA=450)
C...UED Pythia common
COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...Pythia common: particles properties
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C...Parameters.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
C...Decay information.
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
C...Resonance width and secondary decay treatment.
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
C...Local variables
DOUBLE PRECISION PI,QUP,QDW
DOUBLE PRECISION WDTP,WDTE
DIMENSION WDTP(0:400),WDTE(0:400,0:5)
DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
DOUBLE PRECISION SWW1,CWW1
DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
DOUBLE PRECISION SW21,CW21,SW021,CW021
COMMON/SW1/SW021,CW021
C...UED related declarations:
C...equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
DIMENSION IUEDEQ(475)
DATA (IUEDEQ(I),I=451,475)/
C...Singlet quarks
& 6100001,6100002,6100003,6100004,6100005,6100006,
C...Doublet quarks
& 5100001,5100002,5100003,5100004,5100005,5100006,
C...Singlet leptons
& 6100011,6100013,6100015,
C...Doublet leptons
& 5100012,5100011,5100014,5100013,5100016,5100015,
C...Gauge boson KK excitations
& 5100021,5100022,5100023,5100024/
C...N.B. rinv=rued(1)
IF(RUED(1).LE.0.)THEN
WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
RETURN
ENDIF
PI=DACOS(-1.D0)
RMZ = PMAS(23,1)
RMZ2 = RMZ**2
RMW = PMAS(24,1)
RMW2 = RMW**2
ALPHEM = PARU(101)
QUP = 2./3.
QDW = -1./3.
c...qt is q-tilde, qs is q-star
c...strong coupling value
Q2 = RUED(1)**2
ALPHS=PYALPS(Q2)
c...weak mixing angle
SW2=PARU(102)
CW2=1D0-PARU(102)
c...for the mass corrections
RMKK = RUED(1)
RMKK2 = RMKK**2
ZETA3= 1.2
C... Either fix the cutoff scale LAMUED
IF(IUED(5).EQ.0)THEN
LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
C... or the ratio LAMUED/RINV (=product Lambda*R)
ELSEIF(IUED(5).EQ.1)THEN
LOGLAM = DLOG(RUED(4)**2)
ELSE
WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
CALL PYSTOP(6000)
ENDIF
C...Calculate the radiative corrections for the UED KK masses
IF(IUED(6).EQ.1)THEN
RFACT=1.D0
C...or induce a minute mass difference
C...keeping the UED KK mass values nearly equal to 1/R
ELSEIF(IUED(6).EQ.0)THEN
RFACT=0.01D0
ELSE
WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
CALL PYSTOP(6001)
ENDIF
c...Take into account only the strong interactions:
c...The space bulk corrections :
DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
c...The boundary terms:
DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
c...Mass corrections for fermions are extracted from
c...Phys. Rev. D66 036005(2002)9
DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
. +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
DBMQU=RMKK*(3.*(ALPHS/4./PI)
. +(ALPHEM/4./PI/CW2))*LOGLAM
DBMQD=RMKK*(3.*(ALPHS/4./PI)
. +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
. (ALPHEM/4./PI/CW2))*LOGLAM
DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
c...Vector boson masss matrix diagonalization
DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
c...Elements of the mass matrix
A = RMZ2*SW2 + DBMB2 + DSMB2
B = RMZ2*CW2 + DBMA2 + DSMA2
C = RMZ2*DSQRT(SW2*CW2)
SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
c...Eigenvalues: corrections to X1 and Z1 masses
DMB2 = (A+B-SQRDEL)/2.
DMA2 = (A+B+SQRDEL)/2.
c...Rotation angles
SWW1 = 2*C
CWW1 = A-B-SQRDEL
C...Weinberg angle
SW21= SWW1**2/(SWW1**2 + CWW1**2)
CW21= 1. - SW21
SW021=SW21
CW021=CW21
c...Masses:
RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
RMDQST=RMKK+RFACT*DBMQDO
RMSQUS=RMKK+RFACT*DBMQU
RMSQDS=RMKK+RFACT*DBMQD
C...Note: MZ mass is included in ma2
RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
RMLSLD=RMKK+RFACT*DBMLDO
RMLSLE=RMKK+RFACT*DBMLE
DO 100 IPART=1,5,2
PMAS(KKFLA+IPART,1)=RMSQDS
100 CONTINUE
DO 110 IPART=2,6,2
PMAS(KKFLA+IPART,1)=RMSQUS
110 CONTINUE
DO 120 IPART=7,12
PMAS(KKFLA+IPART,1)=RMDQST
120 CONTINUE
DO 130 IPART=13,15
PMAS(KKFLA+IPART,1)=RMLSLE
130 CONTINUE
DO 140 IPART=16,21
PMAS(KKFLA+IPART,1)=RMLSLD
140 CONTINUE
PMAS(KKFLA+22,1)=RMGST
PMAS(KKFLA+23,1)=RMPHST
PMAS(KKFLA+24,1)=RMZST
PMAS(KKFLA+25,1)=RMWST
WRITE(MSTU(11),7000) ' PYUEDC: ',
& 'UED Mass Spectrum (GeV) :'
WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
WRITE(MSTU(11),7000) ' '
C...Initialize widths, branching ratios and life time
DO 199 IPART=1,25
KC=KKFLA+IPART
IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
IF(WDTP(0).LE.0)THEN
WRITE(MSTU(11),*)
+ 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
GOTO 199
ELSE
DO 180 IDC=1,MDCY(KC,3)
IC=IDC+MDCY(KC,2)-1
IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
BRAT(IC)=WDTP(IDC)/WDTP(0)
ENDIF
180 CONTINUE
ENDIF
ENDIF
199 CONTINUE
C...Format to use for comments
7000 FORMAT(' * ',A)
7100 FORMAT(' * ',A,F12.3)
END
C********************************************************************
C...PYXUED
C... Last change:
C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
C... Original version:
C... M. El Kacimi
C... 05/07/2005
C Universal Extra Dimensions Subprocess cross sections
C The expressions used are from atl-com-phys-2005-003
C What is coded here is shat**2/pi * dsigma/dt = |M|**2
C For each UED subprocess, the color flow used is the same
C as the equivalent QCD subprocess. Different configuration
C color flows are considered to have the same probability.
C
C The Xsection is calculated following ATL-PHYS-PUB-2005-003
C by G.Azuelos and P.H.Beauchemin.
C
C This routine is called from pysigh.
SUBROUTINE PYXUED(NCHN,SIGS)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...
INTEGER NGRDEC
COMMON/DECMOD/NGRDEC
C...
PARAMETER(KKPART=25,KKFLA=450)
C...Commonblocks
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
&KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
&SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
&AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
C...UED Pythia common
COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...Local arrays and complex variables
DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
+ ,FAC1,XMNKK,XMUED,SIGS
INTEGER NCHN
C...Return if UED not switched on
IF (IUED(1).LE.0) THEN
RETURN
ENDIF
C...Energy scale of the parton processus
C...taken equal to the mass of the final state kk
c Q2=XMNKK**2
C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
XMNKK=PMAS(KKFLA+23,1)
C...To compare the cross section with phys-pub-2005-03
C...(no radiative corrections),
C...take xmnkk=rinv and q2=rinv**2
c++lnk
C...n.b. (rinv=rued(1))
c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
IF(NGRDEC.EQ.1)XMNKK=RUED(1)
c--lnk
SHAT=VINT(44)
SP=SHAT
THAT=VINT(45)
TP=THAT-XMNKK**2
UHAT=VINT(46)
UP=UHAT-XMNKK**2
BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
PI=DACOS(-1.D0)
c++lnk
c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
IF(NGRDEC.EQ.1)Q2=RUED(1)**2
c--lnk
C...Strong coupling value
ALPHAS=PYALPS(Q2)
IF(ISUB.EQ.311)THEN
C...gg --> g* g*
FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
& 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
& +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
& 12.*TP**2*UP**3+6*TP*UP**4)
& +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
& 15.*TP**3*UP**3+13*TP**2*UP**4+
& 6.*TP*UP**5+2.*UP**6)
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
C...Three color flow configurations (qcd g+g->g+g)
XCOL=PYR(0)
IF(XCOL.LE.1./3.)THEN
ISIG(NCHN,3)=1
ELSEIF(XCOL.LE.2./3.)THEN
ISIG(NCHN,3)=2
ELSE
ISIG(NCHN,3)=3
ENDIF
SIGH(NCHN)=COMFAC*XMUED
ELSEIF(ISUB.EQ.312)THEN
C...q + g -> q*_D + g*, q*_S + g*
C...(the two channels have the same cross section)
FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
& 5.*SP**4*UP**2+12.*SP**5*UP)
XMUED=COMFAC*2.*XMUED
DO 190 I=MMINA,MMAXA
IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
DO 180 ISDE=1,2
IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
NCHN=NCHN+1
ISIG(NCHN,ISDE)=I
ISIG(NCHN,3-ISDE)=21
ISIG(NCHN,3)=1
SIGH(NCHN)=XMUED
IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
180 CONTINUE
190 CONTINUE
ELSEIF(ISUB.EQ.313)THEN
C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
C...(the two channels have the same cross section)
C...qi and qj have the same charge sign
DO 100 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
DO 101 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
& EQ.0) GOTO 101
IF(J*I.LE.0)GOTO 101
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
IF(J.EQ.I)THEN
FAC1=1./72.*ALPHAS**2/(TP*UP)**2
XMUED=FAC1*
& (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
& +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
& 20.*TP**2*UP**2+56./3.*
& TP*UP**3+8.*UP**4)
SIGH(NCHN)=COMFAC*2.*XMUED
ISIG(NCHN,3)=1
IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
ELSE
FAC1=2./9.*ALPHAS**2/TP**2
XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
SIGH(NCHN)=COMFAC*2.*XMUED
ISIG(NCHN,3)=1
ENDIF
101 CONTINUE
100 CONTINUE
ELSEIF(ISUB.EQ.314)THEN
C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...(the two channels have the same cross section)
NCHN=NCHN+1
ISIG(NCHN,1)=21
ISIG(NCHN,2)=21
ISIG(NCHN,3)=INT(1.5+PYR(0))
FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
+ +4.*UP**4+4*TP**4)
+ -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
+ *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
+ 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
SIGH(NCHN)=COMFAC*XMUED
C...has been multiplied by 5: all possible quark flavors in final state
ELSEIF(ISUB.EQ.315)THEN
C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...(the two channels have the same cross section)
DO 141 I=MMIN1,MMAX1
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
DO 142 J=MMIN2,MMAX2
IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
& 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
& 2./3.*SP**3*TP+SP**4)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=COMFAC*2.*XMUED
142 CONTINUE
141 CONTINUE
ELSEIF(ISUB.EQ.316)THEN
C...q + qbar' -> q*_D + q*_Sbar'
FAC1=2./9.*ALPHAS**2
DO 300 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
DO 301 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
FAC1=2./9.*ALPHAS**2/TP**2
XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
SIGH(NCHN)=COMFAC*XMUED
301 CONTINUE
300 CONTINUE
ELSEIF(ISUB.EQ.317)THEN
C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
C...(the two channels have the same cross section)
DO 400 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
DO 401 J=MMIN1,MMAX1
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
FAC1=1./18.*ALPHAS**2/TP**2
XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
SIGH(NCHN)=COMFAC*2.*XMUED
401 CONTINUE
400 CONTINUE
ELSEIF(ISUB.EQ.318)THEN
C...q + q' -> q*_D + q*_S'
DO 500 I=MMIN1,MMAX1
IA=IABS(I)
IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
DO 501 J=MMIN2,MMAX2
JA=IABS(J)
IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
IF(J*I.LE.0)GOTO 501
IF(IA.EQ.JA)THEN
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=INT(1.5+PYR(0))
FAC1=1./36.*ALPHAS**2/(TP*UP)**2
XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
& +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
SIGH(NCHN)=COMFAC*XMUED
ELSE
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=J
ISIG(NCHN,3)=1
FAC1=1./18.*ALPHAS**2/TP**2
XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
SIGH(NCHN)=COMFAC*2.*XMUED
ENDIF
501 CONTINUE
500 CONTINUE
ELSEIF(ISUB.EQ.319)THEN
C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
C...(the two channels have the same cross section)
DO 741 I=MMIN1,MMAX1
IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
& KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
DO 742 J=MMIN2,MMAX2
IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
FAC1=16./9.*ALPHAS**2*1./(SP)**2
XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
SIGH(NCHN)=COMFAC*2.*XMUED
742 CONTINUE
741 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYGRAM
C...Universal Extra Dimensions Model (UED)
C...Computation of the Graviton mass.
SUBROUTINE PYGRAM(IN)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Pythia commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C...UED Pythia common
COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...Local variables
INTEGER KCFLA,NMAX
PARAMETER(KCFLA=450,NMAX=5000)
DIMENSION YVEC(5000),RESVEC(5000)
COMMON/INTSAV/YSAV,YMAX,RESMAX
COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
COMMON/KAPPA/XKAPPA
C...External function (used in call to PYGAUS)
EXTERNAL PYGRAW
C...SAVE statements
SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
C...Initialization
NDIM=IUED(4)
RINV=RUED(1)
XMD=RUED(2)
PI=PARU(1)
C...Initialize for numerical integration
XMPLNK=2.4D+18
XKAPPA=DSQRT(2.D0)/XMPLNK
C...For NDIM=2, compute graviton mass distribution numerically
IF(NDIM.EQ.2)THEN
C... For first event: tabulate distribution of stepwise integrals:
C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
IF(IN.EQ.0)THEN
RESMAX = 0D0
YMAX = 0D0
DO 100 I=1,NMAX
YSAV = (I-0.5)/DBLE(NMAX)
TOL = 1D-6
C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
YVEC(I) = YSAV
RESVEC(I) = RESINT
C... Save max of distribution (for accept/reject below)
IF(RESINT.GT.RESMAX)THEN
RESMAX = RESINT
YMAX = YVEC(I)
ENDIF
100 CONTINUE
ENDIF
C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
PCUJET=1D0
KCGAKK=KCFLA+23
XMGAMK=PMAS(KCGAKK,1)
C... Pick random graviton mass, accept according to stored integrals
AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
110 RMG=AMMAX*PYR(0)
X=RMG/XMGAMK
C... Bin enumeration starts at 1, but make sure always in range
IBIN=INT(NMAX*X)+1
IBIN=MIN(IBIN,NMAX)
IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
C... For NDIM=4 and 6, the analytical expression for the
C... graviton mass distribution integral is used.
ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
C... Ensure minimal open phase space (max(mG*) < m(gamma*))
PCUJET=1D0
C... KK photon (?) compressed code and mass
KCGAKK=KCFLA+23
XMGAMK=PMAS(KCGAKK,1)
C... Find maximum of (dGamma/dMg)
IF(IN.EQ.0)THEN
RESMAX=0D0
YMAX=0D0
DO 120 I=1,NMAX-1
Y=I/DBLE(NMAX)
RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
IF(RESINT.GE.RESMAX)THEN
RESMAX=RESINT
YMAX=Y
ENDIF
120 CONTINUE
ENDIF
C... Pick random graviton mass, accept/reject
AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
130 RMG=AMMAX*PYR(0)
X=RMG/XMGAMK
DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
C... If the user has not chosen N=2,4 or 6, STOP
ELSE
WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
& ' (MUST BE 2, 4, OR 6) '
CALL PYSTOP(6002)
ENDIF
C... Now store the sampled Mg
PMAS(39,1)=RMG
RETURN
END
C*********************************************************************
C...PYGRAW
C...Universal Extra Dimensions Model (UED)
C...
C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
C...
C...Integrand for the KK boson -> SM boson + graviton
C...graviton mass distribution (and gravity mediated total width),
C...which contains (see 0201300 and below for the full product)
C...the gravity mediated partial decay width Gamma(xx, yy)
C... i.e. GRADEN(YY)*PYWDKK(XXA)
C... where xx is exclusive to gravity
C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
DOUBLE PRECISION FUNCTION PYGRAW(YIN)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
IMPLICIT INTEGER (I-N)
C...Pythia commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
C...Local UED commonblocks and variables
COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
COMMON/INTSAV/YSAV,YMAX,RESMAX
C...SAVE statements
SAVE /PYDAT1/,/INTSAV/
C...External: Pythia's Gamma function
EXTERNAL PYGAMM
C...Pi
PI=PARU(1)
PI2=PI*PI
YMIN=1.D-9/RINV
YY=YSAV
XX=DSQRT(1.-YY**2)*YIN
DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
XND=(NDIM-1.)/2.
GAMMN=PYGAMM(XND)
FAC=FAC/GAMMN
XXA=DSQRT(XX**2+YY**2)
GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
PYGRAW=DJAC*
+ FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
RETURN
END
C*********************************************************************
C...PYWDKK
C...Universal Extra Dimensions Model (UED)
C...
C...Multiplied by the square modulus of a form factor
C...(see GRADEN in function PYGRAW)
C...PYWDKK is the KK boson -> SM boson + graviton
C...gravity mediated partial decay width Gamma(xx, yy)
C... where xx is exclusive to gravity
C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
C...
C...N.B. The Feynman rules for the couplings of the graviton fields
C...to the UED fields are related to the corresponding couplings of
C...the graviton fields to the SM fields by the form factor.
DOUBLE PRECISION FUNCTION PYWDKK(X)
C...Double precision and integer declarations
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
IMPLICIT INTEGER (I-N)
C...Pythia commonblocks
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C...Local UED commonblocks and variables
COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
COMMON/KAPPA/XKAPPA
C...SAVE statements
SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
PI=PARU(1)
C...gamma* mass 473
KCQKK=473
XMNKK=PMAS(KCQKK,1)
C...Bosons partial width Macesanu hep-ph/0201300
PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
+ ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
RETURN
END
C*********************************************************************
C...PYEIGC
C...Finds eigenvalues of a general complex matrix
C
C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
C OF A COMPLEX GENERAL MATRIX.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX A=(AR,AI).
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
C
C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
C
C ON OUTPUT
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES.
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
C
C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
C
C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
INTEGER N,NM,IS1,IS2,IERR,MATZ
DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
X FV1(5),FV2(5),FV3(5)
IF (N .LE. NM) GOTO 100
IERR = 10 * N
GOTO 120
C
100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
IF (MATZ .NE. 0) GOTO 110
C .......... FIND EIGENVALUES ONLY ..........
CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
GOTO 120
C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
IF (IERR .NE. 0) GOTO 120
CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
120 RETURN
END
C*********************************************************************
C...PYCMQR
C...Auxiliary to PYEICG.
C
C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
C AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
C UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
C THE REDUCTION BY CORTH, IF PERFORMED.
C
C ON OUTPUT
C
C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
C CALLING COMQR IF SUBSEQUENT CALCULATION OF
C EIGENVECTORS IS TO BE PERFORMED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C CALLS PYCDIV FOR COMPLEX DIVISION.
C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
X PYTHAG
IERR = 0
IF (LOW .EQ. IGH) GOTO 130
C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
L = LOW + 1
C
DO 120 I = L, IGH
LL = MIN0(I+1,IGH)
IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
YR = HR(I,I-1) / NORM
YI = HI(I,I-1) / NORM
HR(I,I-1) = NORM
HI(I,I-1) = 0.0D0
C
DO 100 J = I, IGH
SI = YR * HI(I,J) - YI * HR(I,J)
HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
HI(I,J) = SI
100 CONTINUE
C
DO 110 J = LOW, LL
SI = YR * HI(J,I) + YI * HR(J,I)
HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
HI(J,I) = SI
110 CONTINUE
C
120 CONTINUE
C .......... STORE ROOTS ISOLATED BY CBAL ..........
130 DO 140 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
WR(I) = HR(I,I)
WI(I) = HI(I,I)
140 CONTINUE
C
EN = IGH
TR = 0.0D0
TI = 0.0D0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUE ..........
150 IF (EN .LT. LOW) GOTO 320
ITS = 0
ENM1 = EN - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
160 DO 170 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GOTO 180
TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
X + DABS(HR(L,L)) + DABS(HI(L,L))
TST2 = TST1 + DABS(HR(L,L-1))
IF (TST2 .EQ. TST1) GOTO 180
170 CONTINUE
C .......... FORM SHIFT ..........
180 IF (L .EQ. EN) GOTO 300
IF (ITN .EQ. 0) GOTO 310
IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
SR = HR(EN,EN)
SI = HI(EN,EN)
XR = HR(ENM1,EN) * HR(EN,ENM1)
XI = HI(ENM1,EN) * HR(EN,ENM1)
IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
YR = (HR(ENM1,ENM1) - SR) / 2.0D0
YI = (HI(ENM1,ENM1) - SI) / 2.0D0
CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
ZZR = -ZZR
ZZI = -ZZI
190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
SR = SR - XR
SI = SI - XI
GOTO 210
C .......... FORM EXCEPTIONAL SHIFT ..........
200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
SI = 0.0D0
C
210 DO 220 I = LOW, EN
HR(I,I) = HR(I,I) - SR
HI(I,I) = HI(I,I) - SI
220 CONTINUE
C
TR = TR + SR
TI = TI + SI
ITS = ITS + 1
ITN = ITN - 1
C .......... REDUCE TO TRIANGLE (ROWS) ..........
LP1 = L + 1
C
DO 240 I = LP1, EN
SR = HR(I,I-1)
HR(I,I-1) = 0.0D0
NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
XR = HR(I-1,I-1) / NORM
WR(I-1) = XR
XI = HI(I-1,I-1) / NORM
WI(I-1) = XI
HR(I-1,I-1) = NORM
HI(I-1,I-1) = 0.0D0
HI(I,I-1) = SR / NORM
C
DO 230 J = I, EN
YR = HR(I-1,J)
YI = HI(I-1,J)
ZZR = HR(I,J)
ZZI = HI(I,J)
HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
230 CONTINUE
C
240 CONTINUE
C
SI = HI(EN,EN)
IF (SI .EQ. 0.0D0) GOTO 250
NORM = PYTHAG(HR(EN,EN),SI)
SR = HR(EN,EN) / NORM
SI = SI / NORM
HR(EN,EN) = NORM
HI(EN,EN) = 0.0D0
C .......... INVERSE OPERATION (COLUMNS) ..........
250 DO 280 J = LP1, EN
XR = WR(J-1)
XI = WI(J-1)
C
DO 270 I = L, J
YR = HR(I,J-1)
YI = 0.0D0
ZZR = HR(I,J)
ZZI = HI(I,J)
IF (I .EQ. J) GOTO 260
YI = HI(I,J-1)
HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
270 CONTINUE
C
280 CONTINUE
C
IF (SI .EQ. 0.0D0) GOTO 160
C
DO 290 I = L, EN
YR = HR(I,EN)
YI = HI(I,EN)
HR(I,EN) = SR * YR - SI * YI
HI(I,EN) = SR * YI + SI * YR
290 CONTINUE
C
GOTO 160
C .......... A ROOT FOUND ..........
300 WR(EN) = HR(EN,EN) + TR
WI(EN) = HI(EN,EN) + TI
EN = ENM1
GOTO 150
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
310 IERR = EN
320 RETURN
END
C*********************************************************************
C...PYCMQ2
C...Auxiliary to PYEICG.
C
C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
C THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
C
C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C ARBITRARY.
C
C ON OUTPUT
C
C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C HAVE BEEN DESTROYED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
C THE EIGENVECTORS HAS BEEN FOUND.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C CALLS PYCDIV FOR COMPLEX DIVISION.
C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED OCTOBER 1989.
C
C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
C
SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
X ORTR(5),ORTI(5)
DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
X PYTHAG
IERR = 0
C .......... INITIALIZE EIGENVECTOR MATRIX ..........
DO 110 J = 1, N
C
DO 100 I = 1, N
ZR(I,J) = 0.0D0
ZI(I,J) = 0.0D0
100 CONTINUE
ZR(J,J) = 1.0D0
110 CONTINUE
C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C FROM THE INFORMATION LEFT BY CORTH ..........
IEND = IGH - LOW - 1
IF (IEND.LT.0) GOTO 220
IF (IEND.EQ.0) GOTO 170
C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
DO 160 II = 1, IEND
I = IGH - II
IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
IP1 = I + 1
C
DO 120 K = IP1, IGH
ORTR(K) = HR(K,I-1)
ORTI(K) = HI(K,I-1)
120 CONTINUE
C
DO 150 J = I, IGH
SR = 0.0D0
SI = 0.0D0
C
DO 130 K = I, IGH
SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
130 CONTINUE
C
SR = SR / NORM
SI = SI / NORM
C
DO 140 K = I, IGH
ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
140 CONTINUE
C
150 CONTINUE
C
160 CONTINUE
C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
170 L = LOW + 1
C
DO 210 I = L, IGH
LL = MIN0(I+1,IGH)
IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
YR = HR(I,I-1) / NORM
YI = HI(I,I-1) / NORM
HR(I,I-1) = NORM
HI(I,I-1) = 0.0D0
C
DO 180 J = I, N
SI = YR * HI(I,J) - YI * HR(I,J)
HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
HI(I,J) = SI
180 CONTINUE
C
DO 190 J = 1, LL
SI = YR * HI(J,I) + YI * HR(J,I)
HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
HI(J,I) = SI
190 CONTINUE
C
DO 200 J = LOW, IGH
SI = YR * ZI(J,I) + YI * ZR(J,I)
ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
ZI(J,I) = SI
200 CONTINUE
C
210 CONTINUE
C .......... STORE ROOTS ISOLATED BY CBAL ..........
220 DO 230 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
WR(I) = HR(I,I)
WI(I) = HI(I,I)
230 CONTINUE
C
EN = IGH
TR = 0.0D0
TI = 0.0D0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUE ..........
240 IF (EN .LT. LOW) GOTO 430
ITS = 0
ENM1 = EN - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
250 DO 260 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GOTO 270
TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
X + DABS(HR(L,L)) + DABS(HI(L,L))
TST2 = TST1 + DABS(HR(L,L-1))
IF (TST2 .EQ. TST1) GOTO 270
260 CONTINUE
C .......... FORM SHIFT ..........
270 IF (L .EQ. EN) GOTO 420
IF (ITN .EQ. 0) GOTO 550
IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
SR = HR(EN,EN)
SI = HI(EN,EN)
XR = HR(ENM1,EN) * HR(EN,ENM1)
XI = HI(ENM1,EN) * HR(EN,ENM1)
IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
YR = (HR(ENM1,ENM1) - SR) / 2.0D0
YI = (HI(ENM1,ENM1) - SI) / 2.0D0
CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
ZZR = -ZZR
ZZI = -ZZI
280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
SR = SR - XR
SI = SI - XI
GOTO 300
C .......... FORM EXCEPTIONAL SHIFT ..........
290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
SI = 0.0D0
C
300 DO 310 I = LOW, EN
HR(I,I) = HR(I,I) - SR
HI(I,I) = HI(I,I) - SI
310 CONTINUE
C
TR = TR + SR
TI = TI + SI
ITS = ITS + 1
ITN = ITN - 1
C .......... REDUCE TO TRIANGLE (ROWS) ..........
LP1 = L + 1
C
DO 330 I = LP1, EN
SR = HR(I,I-1)
HR(I,I-1) = 0.0D0
NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
XR = HR(I-1,I-1) / NORM
WR(I-1) = XR
XI = HI(I-1,I-1) / NORM
WI(I-1) = XI
HR(I-1,I-1) = NORM
HI(I-1,I-1) = 0.0D0
HI(I,I-1) = SR / NORM
C
DO 320 J = I, N
YR = HR(I-1,J)
YI = HI(I-1,J)
ZZR = HR(I,J)
ZZI = HI(I,J)
HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
320 CONTINUE
C
330 CONTINUE
C
SI = HI(EN,EN)
IF (SI .EQ. 0.0D0) GOTO 350
NORM = PYTHAG(HR(EN,EN),SI)
SR = HR(EN,EN) / NORM
SI = SI / NORM
HR(EN,EN) = NORM
HI(EN,EN) = 0.0D0
IF (EN .EQ. N) GOTO 350
IP1 = EN + 1
C
DO 340 J = IP1, N
YR = HR(EN,J)
YI = HI(EN,J)
HR(EN,J) = SR * YR + SI * YI
HI(EN,J) = SR * YI - SI * YR
340 CONTINUE
C .......... INVERSE OPERATION (COLUMNS) ..........
350 DO 390 J = LP1, EN
XR = WR(J-1)
XI = WI(J-1)
C
DO 370 I = 1, J
YR = HR(I,J-1)
YI = 0.0D0
ZZR = HR(I,J)
ZZI = HI(I,J)
IF (I .EQ. J) GOTO 360
YI = HI(I,J-1)
HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
370 CONTINUE
C
DO 380 I = LOW, IGH
YR = ZR(I,J-1)
YI = ZI(I,J-1)
ZZR = ZR(I,J)
ZZI = ZI(I,J)
ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
380 CONTINUE
C
390 CONTINUE
C
IF (SI .EQ. 0.0D0) GOTO 250
C
DO 400 I = 1, EN
YR = HR(I,EN)
YI = HI(I,EN)
HR(I,EN) = SR * YR - SI * YI
HI(I,EN) = SR * YI + SI * YR
400 CONTINUE
C
DO 410 I = LOW, IGH
YR = ZR(I,EN)
YI = ZI(I,EN)
ZR(I,EN) = SR * YR - SI * YI
ZI(I,EN) = SR * YI + SI * YR
410 CONTINUE
C
GOTO 250
C .......... A ROOT FOUND ..........
420 HR(EN,EN) = HR(EN,EN) + TR
WR(EN) = HR(EN,EN)
HI(EN,EN) = HI(EN,EN) + TI
WI(EN) = HI(EN,EN)
EN = ENM1
GOTO 240
C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
C VECTORS OF UPPER TRIANGULAR FORM ..........
430 NORM = 0.0D0
C
DO 440 I = 1, N
C
DO 441 J = I, N
TR = DABS(HR(I,J)) + DABS(HI(I,J))
IF (TR .GT. NORM) NORM = TR
441 CONTINUE
440 CONTINUE
C
IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
DO 500 NN = 2, N
EN = N + 2 - NN
XR = WR(EN)
XI = WI(EN)
HR(EN,EN) = 1.0D0
HI(EN,EN) = 0.0D0
ENM1 = EN - 1
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 490 II = 1, ENM1
I = EN - II
ZZR = 0.0D0
ZZI = 0.0D0
IP1 = I + 1
C
DO 450 J = IP1, EN
ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
450 CONTINUE
C
YR = XR - WR(I)
YI = XI - WI(I)
IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
TST1 = NORM
YR = TST1
460 YR = 0.01D0 * YR
TST2 = NORM + YR
IF (TST2 .GT. TST1) GOTO 460
470 CONTINUE
CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
C .......... OVERFLOW CONTROL ..........
TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
IF (TR .EQ. 0.0D0) GOTO 490
TST1 = TR
TST2 = TST1 + 1.0D0/TST1
IF (TST2 .GT. TST1) GOTO 490
DO 480 J = I, EN
HR(J,EN) = HR(J,EN)/TR
HI(J,EN) = HI(J,EN)/TR
480 CONTINUE
C
490 CONTINUE
C
500 CONTINUE
C .......... END BACKSUBSTITUTION ..........
C .......... VECTORS OF ISOLATED ROOTS ..........
DO 520 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
C
DO 510 J = I, N
ZR(I,J) = HR(I,J)
ZI(I,J) = HI(I,J)
510 CONTINUE
C
520 CONTINUE
C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C VECTORS OF ORIGINAL FULL MATRIX.
C FOR J=N STEP -1 UNTIL LOW DO -- ..........
DO 540 JJ = LOW, N
J = N + LOW - JJ
M = MIN0(J,IGH)
C
DO 541 I = LOW, IGH
ZZR = 0.0D0
ZZI = 0.0D0
C
DO 530 K = LOW, M
ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
530 CONTINUE
C
ZR(I,J) = ZZR
ZI(I,J) = ZZI
541 CONTINUE
540 CONTINUE
C
GOTO 560
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
550 IERR = EN
560 RETURN
END
C*********************************************************************
C...PYCDIV
C...Auxiliary to PYCMQR
C
C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
C
SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
DOUBLE PRECISION AR,AI,BR,BI,CR,CI
DOUBLE PRECISION S,ARS,AIS,BRS,BIS
S = DABS(BR) + DABS(BI)
ARS = AR/S
AIS = AI/S
BRS = BR/S
BIS = BI/S
S = BRS**2 + BIS**2
CR = (ARS*BRS + AIS*BIS)/S
CI = (AIS*BRS - ARS*BIS)/S
RETURN
END
C*********************************************************************
C...PYCSRT
C...Auxiliary to PYCMQR
C
C (YR,YI) = COMPLEX DSQRT(XR,XI)
C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C
SUBROUTINE PYCSRT(XR,XI,YR,YI)
DOUBLE PRECISION XR,XI,YR,YI
DOUBLE PRECISION S,TR,TI,PYTHAG
TR = XR
TI = XI
S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
IF (TR .GE. 0.0D0) YR = S
IF (TI .LT. 0.0D0) S = -S
IF (TR .LE. 0.0D0) YI = S
IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
RETURN
END
DOUBLE PRECISION FUNCTION PYTHAG(A,B)
DOUBLE PRECISION A,B
C
C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
DOUBLE PRECISION P,R,S,T,U
P = DMAX1(DABS(A),DABS(B))
IF (P .EQ. 0.0D0) GOTO 110
R = (DMIN1(DABS(A),DABS(B))/P)**2
100 CONTINUE
T = 4.0D0 + R
IF (T .EQ. 4.0D0) GOTO 110
S = R/T
U = 1.0D0 + 2.0D0*S
P = U*P
R = (S/U)**2 * R
GOTO 100
110 PYTHAG = P
RETURN
END
C*********************************************************************
C...PYCBAL
C...Auxiliary to PYEICG
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
C EIGENVALUES WHENEVER POSSIBLE.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
C
C ON OUTPUT
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE BALANCED MATRIX.
C
C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
C ARE EQUAL TO ZERO IF
C (1) I IS GREATER THAN J AND
C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
C
C SCALE CONTAINS INFORMATION DETERMINING THE
C PERMUTATIONS AND SCALING FACTORS USED.
C
C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
C SCALE(J) = P(J), FOR J = 1,...,LOW-1
C = D(J,J) J = LOW,...,IGH
C = P(J) J = IGH+1,...,N.
C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C THEN 1 TO LOW-1.
C
C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C K,L HAVE BEEN REVERSED.)
C
C ARITHMETIC IS REAL THROUGHOUT.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
DOUBLE PRECISION C,F,G,R,S,B2,RADIX
LOGICAL NOCONV
RADIX = 16.0D0
C
B2 = RADIX * RADIX
K = 1
L = N
GOTO 150
C .......... IN-LINE PROCEDURE FOR ROW AND
C COLUMN EXCHANGE ..........
100 SCALE(M) = J
IF (J .EQ. M) GOTO 130
C
DO 110 I = 1, L
F = AR(I,J)
AR(I,J) = AR(I,M)
AR(I,M) = F
F = AI(I,J)
AI(I,J) = AI(I,M)
AI(I,M) = F
110 CONTINUE
C
DO 120 I = K, N
F = AR(J,I)
AR(J,I) = AR(M,I)
AR(M,I) = F
F = AI(J,I)
AI(J,I) = AI(M,I)
AI(M,I) = F
120 CONTINUE
C
130 IF(IEXC.EQ.1) GOTO 140
IF(IEXC.EQ.2) GOTO 180
C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C AND PUSH THEM DOWN ..........
140 IF (L .EQ. 1) GOTO 320
L = L - 1
C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
150 DO 170 JJ = 1, L
J = L + 1 - JJ
C
DO 160 I = 1, L
IF (I .EQ. J) GOTO 160
IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
160 CONTINUE
C
M = L
IEXC = 1
GOTO 100
170 CONTINUE
C
GOTO 190
C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C AND PUSH THEM LEFT ..........
180 K = K + 1
C
190 DO 210 J = K, L
C
DO 200 I = K, L
IF (I .EQ. J) GOTO 200
IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
200 CONTINUE
C
M = K
IEXC = 2
GOTO 100
210 CONTINUE
C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
DO 220 I = K, L
SCALE(I) = 1.0D0
220 CONTINUE
C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
230 NOCONV = .FALSE.
C
DO 310 I = K, L
C = 0.0D0
R = 0.0D0
C
DO 240 J = K, L
IF (J .EQ. I) GOTO 240
C = C + DABS(AR(J,I)) + DABS(AI(J,I))
R = R + DABS(AR(I,J)) + DABS(AI(I,J))
240 CONTINUE
C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
G = R / RADIX
F = 1.0D0
S = C + R
250 IF (C .GE. G) GOTO 260
F = F * RADIX
C = C * B2
GOTO 250
260 G = R * RADIX
270 IF (C .LT. G) GOTO 280
F = F / RADIX
C = C / B2
GOTO 270
C .......... NOW BALANCE ..........
280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
G = 1.0D0 / F
SCALE(I) = SCALE(I) * F
NOCONV = .TRUE.
C
DO 290 J = K, N
AR(I,J) = AR(I,J) * G
AI(I,J) = AI(I,J) * G
290 CONTINUE
C
DO 300 J = 1, L
AR(J,I) = AR(J,I) * F
AI(J,I) = AI(J,I) * F
300 CONTINUE
C
310 CONTINUE
C
IF (NOCONV) GOTO 230
C
320 LOW = K
IGH = L
RETURN
END
C*********************************************************************
C...PYCBA2
C...Auxiliary to PYEICG.
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C BALANCED MATRIX DETERMINED BY CBAL.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
C
C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C AND SCALING FACTORS USED BY CBAL.
C
C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVECTORS TO BE
C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
C
C ON OUTPUT
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C IN THEIR FIRST M COLUMNS.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
INTEGER I,J,K,M,N,II,NM,IGH,LOW
DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
DOUBLE PRECISION S
IF (M .EQ. 0) GOTO 150
IF (IGH .EQ. LOW) GOTO 120
C
DO 110 I = LOW, IGH
S = SCALE(I)
C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C IF THE FOREGOING STATEMENT IS REPLACED BY
C S=1.0D0/SCALE(I). ..........
DO 100 J = 1, M
ZR(I,J) = ZR(I,J) * S
ZI(I,J) = ZI(I,J) * S
100 CONTINUE
C
110 CONTINUE
C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
C IGH+1 STEP 1 UNTIL N DO -- ..........
120 DO 140 II = 1, N
I = II
IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
IF (I .LT. LOW) I = LOW - II
K = SCALE(I)
IF (K .EQ. I) GOTO 140
C
DO 130 J = 1, M
S = ZR(I,J)
ZR(I,J) = ZR(K,J)
ZR(K,J) = S
S = ZI(I,J)
ZI(I,J) = ZI(K,J)
ZI(K,J) = S
130 CONTINUE
C
140 CONTINUE
C
150 RETURN
END
C*********************************************************************
C...PYCRTH
C...Auxiliary to PYEICG.
C
C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C UNITARY SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C ON OUTPUT
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLES UNDER THE
C HESSENBERG MATRIX.
C
C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GOTO 210
C
DO 200 M = KP1, LA
H = 0.0D0
ORTR(M) = 0.0D0
ORTI(M) = 0.0D0
SCALE = 0.0D0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
DO 100 I = M, IGH
SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
100 CONTINUE
C
IF (SCALE .EQ. 0.0D0) GOTO 200
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
ORTR(I) = AR(I,M-1) / SCALE
ORTI(I) = AI(I,M-1) / SCALE
H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
110 CONTINUE
C
G = DSQRT(H)
F = PYTHAG(ORTR(M),ORTI(M))
IF (F .EQ. 0.0D0) GOTO 120
H = H + F * G
G = G / F
ORTR(M) = (1.0D0 + G) * ORTR(M)
ORTI(M) = (1.0D0 + G) * ORTI(M)
GOTO 130
C
120 ORTR(M) = G
AR(M,M-1) = SCALE
C .......... FORM (I-(U*UT)/H) * A ..........
130 DO 160 J = M, N
FR = 0.0D0
FI = 0.0D0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 140 II = M, IGH
I = MP - II
FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
140 CONTINUE
C
FR = FR / H
FI = FI / H
C
DO 150 I = M, IGH
AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
150 CONTINUE
C
160 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 190 I = 1, IGH
FR = 0.0D0
FI = 0.0D0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 170 JJ = M, IGH
J = MP - JJ
FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
170 CONTINUE
C
FR = FR / H
FI = FI / H
C
DO 180 J = M, IGH
AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
180 CONTINUE
C
190 CONTINUE
C
ORTR(M) = SCALE * ORTR(M)
ORTI(M) = SCALE * ORTI(M)
AR(M,M-1) = -G * AR(M,M-1)
AI(M,M-1) = -G * AI(M,M-1)
200 CONTINUE
C
210 RETURN
END
C*********************************************************************
C...PYLDCM
C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
C...processes.
SUBROUTINE PYLDCM(A,N,NP,INDX,D)
IMPLICIT NONE
INTEGER N,NP,INDX(N)
REAL*8 D,TINY
COMPLEX*16 A(NP,NP)
PARAMETER (TINY=1.0D-20)
INTEGER I,IMAX,J,K
REAL*8 AAMAX,VV(6),DUM
COMPLEX*16 SUM,DUMC
D=1D0
DO 110 I=1,N
AAMAX=0D0
DO 100 J=1,N
IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
100 CONTINUE
IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
VV(I)=1D0/AAMAX
110 CONTINUE
DO 180 J=1,N
DO 130 I=1,J-1
SUM=A(I,J)
DO 120 K=1,I-1
SUM=SUM-A(I,K)*A(K,J)
120 CONTINUE
A(I,J)=SUM
130 CONTINUE
AAMAX=0D0
DO 150 I=J,N
SUM=A(I,J)
DO 140 K=1,J-1
SUM=SUM-A(I,K)*A(K,J)
140 CONTINUE
A(I,J)=SUM
DUM=VV(I)*ABS(SUM)
IF (DUM.GE.AAMAX) THEN
IMAX=I
AAMAX=DUM
ENDIF
150 CONTINUE
IF (J.NE.IMAX)THEN
DO 160 K=1,N
DUMC=A(IMAX,K)
A(IMAX,K)=A(J,K)
A(J,K)=DUMC
160 CONTINUE
D=-D
VV(IMAX)=VV(J)
ENDIF
INDX(J)=IMAX
IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
IF(J.NE.N)THEN
DO 170 I=J+1,N
A(I,J)=A(I,J)/A(J,J)
170 CONTINUE
ENDIF
180 CONTINUE
RETURN
END
C*********************************************************************
C...PYBKSB
C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
C...processes.
SUBROUTINE PYBKSB(A,N,NP,INDX,B)
IMPLICIT NONE
INTEGER N,NP,INDX(N)
COMPLEX*16 A(NP,NP),B(N)
INTEGER I,II,J,LL
COMPLEX*16 SUM
II=0
DO 110 I=1,N
LL=INDX(I)
SUM=B(LL)
B(LL)=B(I)
IF (II.NE.0)THEN
DO 100 J=II,I-1
SUM=SUM-A(I,J)*B(J)
100 CONTINUE
ELSE IF (ABS(SUM).NE.0D0) THEN
II=I
ENDIF
B(I)=SUM
110 CONTINUE
DO 130 I=N,1,-1
SUM=B(I)
DO 120 J=I+1,N
SUM=SUM-A(I,J)*B(J)
120 CONTINUE
B(I)=SUM/A(I,I)
130 CONTINUE
RETURN
END
C***********************************************************************
C...PYWIDX
C...Calculates full and partial widths of resonances.
C....copy of PYWIDT, used for techniparticle widths
SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT4/,/PYMSSM/,/PYTCSM/
C...Local arrays and saved variables.
DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
&WID2SV(3,2)
SAVE MOFSV,WIDWSV,WID2SV
DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
C...Compressed code and sign; mass.
KFLA=IABS(KFLR)
KFLS=ISIGN(1,KFLR)
KC=PYCOMP(KFLA)
SHR=SQRT(SH)
PMR=PMAS(KC,1)
C...Reset width information.
DO I=0,400
WDTP(I)=0D0
ENDDO
C...Common electroweak and strong constants.
XW=PARU(102)
XWV=XW
IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
XW1=1D0-XW
AEM=PYALEM(SH)
IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
AS=PYALPS(SH)
RADC=1D0+AS/PARU(1)
IF(KFLA.EQ.23) THEN
C...Z0:
XWC=1D0/(16D0*XW*XW1)
FAC=(AEM*XWC/3D0)*SHR
120 CONTINUE
DO 130 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 130
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
IF(I.LE.8) THEN
C...Z0 -> q + qbar
EF=KCHG(I,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
FCOF=3D0*RADC
IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
ELSEIF(I.LE.16) THEN
C...Z0 -> l+ + l-, nu + nubar
EF=KCHG(I+2,1)/3D0
AF=SIGN(1D0,EF+0.1D0)
VF=AF-4D0*EF*XWV
FCOF=1D0
ENDIF
BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
& BE34
WDTP(0)=WDTP(0)+WDTP(I)
130 CONTINUE
ELSEIF(KFLA.EQ.24) THEN
C...W+/-:
FAC=(AEM/(24D0*XW))*SHR
DO 140 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 140
RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
WID2=1D0
IF(I.LE.16) THEN
C...W+/- -> q + qbar'
FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
ELSEIF(I.LE.20) THEN
C...W+/- -> l+/- + nu
FCOF=1D0
ENDIF
WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
WDTP(0)=WDTP(0)+WDTP(I)
140 CONTINUE
C.....V8 -> quark anti-quark
ELSEIF(KFLA.EQ.KTECHN+100021) THEN
FAC=AS/6D0*SHR
TANT3=RTCM(21)
IF(ITCM(2).EQ.0) THEN
IMDL=1
ELSEIF(ITCM(2).EQ.1) THEN
IMDL=2
ENDIF
DO 150 I=1,MDCY(KC,3)
IDC=I+MDCY(KC,2)-1
IF(MDME(IDC,1).LT.0) GOTO 150
PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
RM1=PM1**2/SH
IF(RM1.GT.0.25D0) GOTO 150
WID2=1D0
IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
FMIX=1D0/TANT3**2
ELSE
FMIX=TANT3**2
ENDIF
WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
IF(I.EQ.6) WID2=WIDS(6,1)
WDTP(0)=WDTP(0)+WDTP(I)
150 CONTINUE
ENDIF
RETURN
END
C*********************************************************************
C...PYRVSF
C...Calculates R-violating decays of sfermions.
C...P. Z. Skands
SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3), PYCOMP
SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
C...IS R-VIOLATION ON ?
IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
C...Mass eigenstate counter
ICNT=INT(KFIN/KSUSY1)
C...SM KF code of SUSY particle
KFSM=KFIN-ICNT*KSUSY1
C...Squared Sparticle Mass
SM=PMAS(PYCOMP(KFIN),1)**2
C... Squared mass of top quark
SMT=PMAS(PYCOMP(6),1)**2
C...IS L-VIOLATION ON ?
IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
& THEN
K=INT((KFSM-9)/2)
DO 110 I=1,3
DO 100 J=1,3
IF(I.NE.J) THEN
C...~e,~mu,~tau -> nu_I + lepton-_J
LKNT = LKNT+1
IDLAM(LKNT,1)= 12 +2*(I-1)
IDLAM(LKNT,2)= 11 +2*(J-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
IF (IMSS(51).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
100 CONTINUE
110 CONTINUE
C...~e,~mu,~tau -> nu_Ibar + lepton-_K
J=INT((KFSM-9)/2)
DO 130 I=1,3
IF(I.NE.J) THEN
DO 120 K=1,3
LKNT = LKNT+1
IDLAM(LKNT,1)=-12 -2*(I-1)
IDLAM(LKNT,2)= 11 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
IF (IMSS(51).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
120 CONTINUE
ENDIF
130 CONTINUE
C...~e,~mu,~tau -> u_Jbar + d_K
I=INT((KFSM-9)/2)
DO 150 J=1,3
DO 140 K=1,3
LKNT = LKNT+1
IDLAM(LKNT,1)=-2 -2*(J-1)
IDLAM(LKNT,2)= 1 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0
IF (IMSS(52).NE.0) THEN
C...Use massive top quark
IF (IDLAM(LKNT,1).EQ.-6) THEN
RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
& * (SM-SMT)
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
C...If no top quark, all decay products massless
ELSE
RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
ENDIF
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
140 CONTINUE
150 CONTINUE
ENDIF
C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
C...No right-handed neutrinos
IF(ICNT.EQ.1) THEN
IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
J=INT((KFSM-10)/2)
DO 170 I=1,3
DO 160 K=1,3
IF (I.NE.J) THEN
C...~nu_J -> lepton+_I + lepton-_K
LKNT = LKNT+1
IDLAM(LKNT,1)=-11 -2*(I-1)
IDLAM(LKNT,2)= 11 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAM(I,J,K)**2 * SM
IF (IMSS(51).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
160 CONTINUE
170 CONTINUE
C...~nu_I -> dbar_J + d_K
I=INT((KFSM-10)/2)
DO 190 J=1,3
DO 180 K=1,3
LKNT = LKNT+1
IDLAM(LKNT,1)=-1 -2*(J-1)
IDLAM(LKNT,2)= 1 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=3*RVLAMP(I,J,K)**2 * SM
IF (IMSS(52).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
180 CONTINUE
190 CONTINUE
ENDIF
ENDIF
C * SDOWN -> NU(BAR) + D and LEPTON- + U
IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
J=INT((KFSM+1)/2)
DO 210 I=1,3
DO 200 K=1,3
C...~d_J -> nu_Ibar + d_K
LKNT = LKNT+1
IDLAM(LKNT,1)=-12 -2*(I-1)
IDLAM(LKNT,2)= 1 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
IF (IMSS(52).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
200 CONTINUE
210 CONTINUE
K=INT((KFSM+1)/2)
DO 240 I=1,3
DO 230 J=1,3
C...~d_K -> nu_I + d_J
LKNT = LKNT+1
IDLAM(LKNT,1)= 12 +2*(I-1)
IDLAM(LKNT,2)= 1 +2*(J-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
IF (IMSS(52).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C...~d_K -> lepton_I- + u_J
220 LKNT = LKNT+1
IDLAM(LKNT,1)= 11 +2*(I-1)
IDLAM(LKNT,2)= 2 +2*(J-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
IF (IMSS(52).NE.0) THEN
C...Use massive top quark
IF (IDLAM(LKNT,2).EQ.6) THEN
RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
C...If no top quark, all decay products massless
ELSE
RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
ENDIF
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
230 CONTINUE
240 CONTINUE
ENDIF
C * SUP -> LEPTON+ + D
IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
J=NINT(KFSM/2.)
DO 260 I=1,3
DO 250 K=1,3
C...~u_J -> lepton_I+ + d_K
LKNT = LKNT+1
IDLAM(LKNT,1)=-11 -2*(I-1)
IDLAM(LKNT,2)= 1 +2*(K-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
IF (IMSS(52).NE.0) XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
250 CONTINUE
260 CONTINUE
ENDIF
ENDIF
C...BARYON NUMBER VIOLATING DECAYS
IF (IMSS(53).GE.1) THEN
C * SUP -> DBAR + DBAR
IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
I = KFSM/2
DO 280 J=1,3
DO 270 K=1,3
C...~u_I -> dbar_J + dbar_K
IF (J.LT.K) THEN
C...(anti-) symmetry J <-> K.
LKNT = LKNT + 1
IDLAM(LKNT,1) = -1 -2*(J-1)
IDLAM(LKNT,2) = -1 -2*(K-1)
IDLAM(LKNT,3) = 0
XLAM(LKNT) = 0D0
RM2 = 2.*(RVLAMB(I,J,K)**2)
& * SFMIX(KFSM,2*ICNT)**2 * SM
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT = LKNT-1
ENDIF
ENDIF
270 CONTINUE
280 CONTINUE
ENDIF
C * SDOWN -> UBAR + DBAR
IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
K=(KFSM+1)/2
DO 300 I=1,3
DO 290 J=1,3
C...LAMB coupling antisymmetric in J and K.
IF (J.NE.K) THEN
C...~d_K -> ubar_I + dbar_K
LKNT = LKNT + 1
IDLAM(LKNT,1)= -2 -2*(I-1)
IDLAM(LKNT,2)= -1 -2*(J-1)
IDLAM(LKNT,3)= 0
XLAM(LKNT)=0D0
C...Use massive top quark
IF (IDLAM(LKNT,1).EQ.-6) THEN
RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
& )
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
C...If no top quark, all decay products massless
ELSE
RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
XLAM(LKNT) =
& PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
ENDIF
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
290 CONTINUE
300 CONTINUE
ENDIF
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYRVNE
C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
C...P. Z. Skands
SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
DOUBLE PRECISION XLAM(0:400)
DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
INTEGER IDLAM(400,3), PYCOMP
LOGICAL DCMASS
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
C...R-VIOLATING DECAYS
IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
KFSM=KFIN-KSUSY1
IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
C...WHICH NEUTRALINO ?
NCHI=1
IF (KFSM.EQ.23) NCHI=2
IF (KFSM.EQ.25) NCHI=3
IF (KFSM.EQ.35) NCHI=4
C...SIGN OF MASS (Opposite convention as HERWIG)
ISM = 1
IF (SMZ(NCHI).LT.0D0) ISM = -ISM
C...Useful parameters for the calculation of the A and B constants.
WMASS = PMAS(PYCOMP(24),1)
ECHG = 2*SQRT(PARU(103)*PARU(1))
COSB=1/(SQRT(1+RMSS(5)**2))
SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
COSW=SQRT(1-PARU(102))
SINW=SQRT(PARU(102))
GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
C...Run quark masses to neutralino mass squared (for Higgs-type
C...couplings)
SQMCHI=PMAS(PYCOMP(KFIN),1)**2
DO 100 I=1,6
RMQ(I)=PYMRUN(I,SQMCHI)
100 CONTINUE
C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
DO 110 NCHJ=1,4
ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
110 CONTINUE
C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
C2=ECHG*ZPMIX(NCHI,1)
C3=GW*ZPMIX(NCHI,2)/COSW
EU=2D0/3D0
ED=-1D0/3D0
C... AB(x,y,z):
C x=1-2 : Select A or B constant (1:A ; 2:B)
C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C 11-16:e,nu_e,mu,...)
C z=1-2 : Mass eigenstate number
C...CALCULATE COUPLINGS
DO 120 I = 11,15,2
CMS=PMAS(PYCOMP(I),1)
C...Intermediate sleptons
AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
& *(C2-C3*SINW**2))
AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
& *(C2-C3*SINW**2))
AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
& **2))
AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
& **2))
C...Inermediate sneutrinos
AB(1,I+1,1)=0D0
AB(2,I+1,1)=5D-1*C3
AB(1,I+1,2)=0D0
AB(2,I+1,2)=0D0
C...Inermediate sdown
J=I-10
CMS=RMQ(J)
AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
& *ED*(C2-C3*SINW**2))
AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
& *ED*(C2-C3*SINW**2))
AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
& *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
& *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
C...Inermediate sup
J=J+1
CMS=RMQ(J)
AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
& *EU*(C2-C3*SINW**2))
AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
& *EU*(C2-C3*SINW**2))
AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
& *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
& *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
120 CONTINUE
IF (IMSS(51).GE.1) THEN
C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
C...STEP IN I,J,K USING SINGLE COUNTER
DO 130 ISC=0,26
C...LAMBDA COUPLING ASYM IN I,J
IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
& ,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
& DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=-IDLAM(LKNT,1)
KFR(2)=-IDLAM(LKNT,2)
KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT=LKNT+1
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
ENDIF
130 CONTINUE
ENDIF
IF (IMSS(52).GE.1) THEN
C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
C * CHI0 -> NUBAR_I + DBAR_J + D_K
DO 140 ISC=0,26
LKNT = LKNT+1
IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
& ,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
& DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=-IDLAM(LKNT,1)
KFR(2)=-IDLAM(LKNT,2)
KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT=LKNT+1
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
LKNT = LKNT+1
IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
& ,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
& .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=-IDLAM(LKNT,1)
KFR(2)=-IDLAM(LKNT,2)
KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT=LKNT+1
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
140 CONTINUE
ENDIF
IF (IMSS(53).GE.1) THEN
C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
DO 150 ISC=0,26
C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
& +1,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
& .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)
KFR(2) = IDLAM(LKNT,2)
KFR(3) = IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT=LKNT+1
IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
ENDIF
150 CONTINUE
ENDIF
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYRVCH
C...Calculates R-violating chargino decay widths.
C...P. Z. Skands
SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3), PYCOMP
C...Information from main routine to PYRVGW
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
C...Auxiliary variables needed for BV (RV Gauge STOre)
COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
& ,RVLJKI,RVLJIK
C...Running quark masses
DOUBLE PRECISION RMQ(6)
C...Decay product masses on/off
LOGICAL DCMASS
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
& /RVGSTO/
C...IF R-VIOLATION ON.
IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
KFSM=KFIN-KSUSY1
IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
C...WHICH CHARGINO ?
NCHI = 1
IF (KFSM.EQ.37) NCHI = 2
C...Useful parameters for calculating the A and B constants.
C...SIGN OF MASS (Opposite convention as HERWIG)
ISM = 1
IF (SMW(NCHI).LT.0D0) ISM = -1
WMASS = PMAS(PYCOMP(24),1)
COSB = 1/(SQRT(1+RMSS(5)**2))
SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
GW2 = 4*PARU(103)*PARU(1)/PARU(102)
C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
C2 = UMIX(NCHI,1)
C3 = VMIX(NCHI,1)
C...Running masses at Q^2=MCHI^2.
SQMCHI = PMAS(PYCOMP(KFSM),1)**2
DO 100 I=1,6
RMQ(I)=PYMRUN(I,SQMCHI)
100 CONTINUE
C... AB(x,y,z) coefficients:
C x=1-2 : A or B coefficient (1:A ; 2:B)
C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C 11-16:e,nu_e,mu,...)
C z=1-2 : Mass eigenstate number
DO 110 I = 11,15,2
C...Intermediate sleptons
AB(1,I,1) = 0D0
AB(1,I,2) = 0D0
AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
& SFMIX(I,1)*C2
AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
& SFMIX(I,3)*C2
C...Intermediate sneutrinos
AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
AB(1,I+1,2) = 0D0
AB(2,I+1,1) = ISM*C3
AB(2,I+1,2) = 0D0
C...Intermediate sdown
J=I-10
AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
C...Intermediate sup
J=J+1
AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
110 CONTINUE
C...LLE TYPE R-VIOLATION
IF (IMSS(51).GE.1) THEN
C...LOOP OVER DECAY MODES
DO 140 ISC=0,26
C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = GW2 * 5D-1 *
& RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
& **2
DCMASS=.FALSE.
IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K).
KFR(1) = 0
KFR(2) = 0
KFR(3) = -IDLAM(LKNT,3)+1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = GW2 * 5D-1 *
& RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
C...I,J SYMMETRY => FACTOR 2
RVLAMC=2*RVLAMC
DCMASS=.FALSE.
IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=IDLAM(LKNT,1)-1
KFR(2)=IDLAM(LKNT,2)-1
KFR(3)=0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement
C * from above, thanks to N.-E. Bomark.
LKNT = LKNT+1
IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = GW2 * 5D-1 *
& RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
C...I,J SYMMETRY => FACTOR 2
RVLAMC=2*RVLAMC
DCMASS=.FALSE.
IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
& .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) =-IDLAM(LKNT,1)+1
KFR(2) =-IDLAM(LKNT,2)+1
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC
& /((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
ENDIF
140 CONTINUE
ENDIF
C...LQD TYPE R-VIOLATION
IF (IMSS(52).GE.1) THEN
C...LOOP OVER DECAY MODES
DO 180 ISC=0,26
C...CHI+ -> NUBAR_I + DBAR_J + U_K
LKNT = LKNT+1
IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 3. * GW2 * 5D-1 *
& RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
& DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=0
KFR(2)=0
KFR(3)=-IDLAM(LKNT,3)+1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
150 LKNT = LKNT+1
IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 3. * GW2 * 5D-1 *
& RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
DCMASS=.FALSE.
IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
& .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=0
KFR(2)=0
KFR(3)=-IDLAM(LKNT,3)+1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
160 LKNT = LKNT+1
IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 3. * GW2 * 5D-1 *
& RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
DCMASS = .FALSE.
IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
& .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=-IDLAM(LKNT,1)+1
KFR(2)=-IDLAM(LKNT,2)+1
KFR(3)=0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
C * CHI+ -> NU_I + U_J + DBAR_K.
170 LKNT = LKNT+1
IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
DCMASS = .FALSE.
RVLAMC = 3. * GW2 * 5D-1 *
& RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
& DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1)=IDLAM(LKNT,1)-1
KFR(2)=IDLAM(LKNT,2)-1
KFR(3)=0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
180 CONTINUE
ENDIF
C...UDD TYPE R-VIOLATION
C...These decays need special treatment since more than one BV coupling
C...contributes (with interference). Consider e.g. (symbolically)
C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
C...The problem is that a single call to PYRVGW would evaluate all
C...these terms and sum them, but without the different couplings. The
C...way out is to call PYRVGW three times, once for the first line, once
C...for the second line, and then once for all the lines (it is
C...impossible to get just the last line out) without multiplying by
C...couplings. The last line is then obtained as the result of the third
C...call minus the results of the two first calls. Each term is then
C...multiplied by its respective coupling before the whole thing is
C...summed up in XLAM.
C...Note that with three interfering resonances, this procedure becomes
C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
IF (IMSS(53).GE.1) THEN
C...LOOP OVER DECAY MODES
DO 190 ISC=1,25
C...CHI+ -> U_I + U_J + D_K
C...Decay mode I<->J symmetric.
IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC= 6. * GW2 * 5D-1
RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
& +1)
RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
& +1)
IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
& * RVLAMC
DCMASS=.FALSE.
IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
& .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = -IDLAM(LKNT,1)+1
KFR(2) = 0
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = -IDLAM(LKNT,2)+1
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = -IDLAM(LKNT,1)+1
KFR(2) = -IDLAM(LKNT,2)+1
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESIJ)
IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
XRESIJ = XRESIJ-XRESI-XRESJ
ELSE
XRESIJ = 0D0
ENDIF
C...CALCULATE TOTAL WIDTH
XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
& + RVLJIK*RVLIJK * XRESIJ
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
C...Symmetry I<->J<->K.
IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
& .MOD(ISC,3)).AND.ISC.NE.13) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
XLAM(LKNT) = 0D0
C...Set coupling, and decay product masses on/off
RVLAMC = 6. * GW2 * 5D-1
RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
& +1)
RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
& +1)
RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
& +1)
DCMASS = .FALSE.
IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
& .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
C...Collect symmetry factors
IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
& .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
& RVLAMC = 5D-1 * RVLAMC
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)-1
KFR(2) = 0
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = IDLAM(LKNT,2)-1
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = 0
KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESK)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)-1
KFR(2) = IDLAM(LKNT,2)-1
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESIJ)
IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
XRESIJ = XRESI+XRESJ-XRESIJ
ELSE
XRESIJ = 0D0
ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = IDLAM(LKNT,2)-1
KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESJK)
IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
XRESJK = XRESJ+XRESK-XRESJK
ELSE
XRESJK = 0D0
ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)-1
KFR(2) = 0
KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
& IDLAM(LKNT,3),XRESIK)
IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
XRESIK = XRESI+XRESK-XRESIK
ELSE
XRESIK = 0D0
ENDIF
C...CALCULATE TOTAL WIDTH
XLAM(LKNT) =
& RVLIJK**2 * XRESI
& + RVLJKI**2 * XRESJ
& + RVLKIJ**2 * XRESK
& + RVLIJK*RVLJKI * XRESIJ
& + RVLIJK*RVLKIJ * XRESIK
& + RVLJKI*RVLKIJ * XRESJK
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-1
ENDIF
ENDIF
190 CONTINUE
ENDIF
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYRVGL
C...Calculates R-violating gluino decay widths.
C...See BV part of PYRVCH for comments about the way the BV decay width
C...is calculated. Same comments apply here.
C...P. Z. Skands
SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
&SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
DOUBLE PRECISION XLAM(0:400)
INTEGER IDLAM(400,3), PYCOMP
C...Information from main routine to PYRVGW
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
C...Auxiliary variables needed for BV (RV Gauge STOre)
COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
& ,RVLJKI,RVLJIK
C...Running quark masses
DOUBLE PRECISION RMQ(6)
C...Decay product masses on/off
LOGICAL DCMASS
SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
& /RVGSTO/
C...IF LQD OR UDD TYPE R-VIOLATION ON.
IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
KFSM=KFIN-KSUSY1
C... AB(x,y,z):
C x=1-2 : Select A or B coupling (1:A ; 2:B)
C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C 11-16:e,nu_e,mu,... not used here)
C z=1-2 : Mass eigenstate number
DO 100 I = 1,6
C...A Couplings
AB(1,I,1) = SFMIX(I,2)
AB(1,I,2) = SFMIX(I,4)
C...B Couplings
AB(2,I,1) = -SFMIX(I,1)
AB(2,I,2) = -SFMIX(I,3)
100 CONTINUE
GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
C...LQD DECAYS.
IF (IMSS(52).GE.1) THEN
C...STEP IN I,J,K USING SINGLE COUNTER
DO 120 ISC=0,26
C * GLUINO -> NUBAR_I + DBAR_J + D_K.
LKNT = LKNT+1
IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off
RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
& * 5D-1 * GSTR2
DCMASS = .FALSE.
IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = -IDLAM(LKNT,2)
KFR(3) = -IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
C...Normalize
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
110 LKNT = LKNT+1
IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
XLAM(LKNT) = XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
C * GLUINO -> LEPTON+_I + UBAR_J + D_K
LKNT = LKNT+1
IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off
RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
& **2* 5D-1 * GSTR2
DCMASS = .FALSE.
IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
& .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = -IDLAM(LKNT,2)
KFR(3) = -IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XLAM(LKNT))
XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT=LKNT+1
IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
XLAM(LKNT) = XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
120 CONTINUE
ENDIF
C...UDD DECAYS.
IF (IMSS(53).GE.1) THEN
C...STEP IN I,J,K USING SINGLE COUNTER
DO 130 ISC=0,26
C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
LKNT = LKNT+1
IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off. A factor of 2 for
C...(N_C-1) has been used to cancel a factor 0.5.
RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
& **2 * GSTR2
DCMASS = .FALSE.
IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
& .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)
KFR(2) = 0
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = IDLAM(LKNT,2)
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = 0
KFR(3) = IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESK)
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)
KFR(2) = IDLAM(LKNT,2)
KFR(3) = 0
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESIJ)
C...Calculate interference function. (Factor -1/2 to make up for factor
C...-2 in PYRVGW.
IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
ELSE
XRESIJ = 0D0
ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = 0
KFR(2) = IDLAM(LKNT,2)
KFR(3) = IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESJK)
IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
ELSE
XRESJK = 0D0
ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
KFR(1) = IDLAM(LKNT,1)
KFR(2) = 0
KFR(3) = IDLAM(LKNT,3)
C...Calculate width.
CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
& ,XRESIK)
IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
ELSE
XRESIK = 0D0
ENDIF
C...Calculate total width (factor 1/2 from 1/(N_C-1))
XLAM(LKNT) = XRESI + XRESJ + XRESK
& + 5D-1 * (XRESIJ + XRESIK + XRESJK)
C...Normalize
XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
LKNT = LKNT+1
IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
XLAM(LKNT) = XLAM(LKNT-1)
C...KINEMATICS CHECK
IF (XLAM(LKNT).EQ.0D0) THEN
LKNT=LKNT-2
ENDIF
ENDIF
130 CONTINUE
ENDIF
ENDIF
RETURN
END
C*********************************************************************
C...PYRVSB
C...Auxiliary function to PYRVSF for calculating R-Violating
C...sfermion widths. Though the decay products are most often treated
C...as massless in the calculation, the kinematical boundary of phase
C...space is tested using the true masses.
C...MODE = 1: All decay products massive
C...MODE = 2: Decay product 1 massless
C...MODE = 3: Decay product 2 massless
C...MODE = 4: All decay products massless
FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
IMPLICIT INTEGER (I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYDAT1/,/PYDAT2/
DOUBLE PRECISION SM(3)
INTEGER PYCOMP, KC(3)
KC(1)=PYCOMP(KFIN)
KC(2)=PYCOMP(ID1)
KC(3)=PYCOMP(ID2)
SM(1)=PMAS(KC(1),1)**2
SM(2)=PMAS(KC(2),1)**2
SM(3)=PMAS(KC(3),1)**2
C...Kinematics check
IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
PYRVSB=0D0
RETURN
ENDIF
C...CM momenta squared
IF (MODE.EQ.1) THEN
P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
& * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
ELSE IF (MODE.EQ.2) THEN
P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
ELSE IF (MODE.EQ.3) THEN
P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
ELSE
P2CM=SM(1)/4.
ENDIF
C...Calculate Width
PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
RETURN
END
C*********************************************************************
C...PYRVGW
C...Generalized Matrix Element for R-Violating 3-body widths.
C...P. Z. Skands
SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
IMPLICIT INTEGER (I-N)
PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
&KEXCIT=4000000,KDIMEN=5000000)
PARAMETER (EPS=1D-4)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
& SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
DOUBLE PRECISION XLIM(3,3)
INTEGER KC(0:3), PYCOMP
LOGICAL DCMASS, DCHECK(6)
SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
XLAM = 0D0
KC(0) = PYCOMP(KFIN)
KC(1) = PYCOMP(ID1)
KC(2) = PYCOMP(ID2)
KC(3) = PYCOMP(ID3)
RMS(0) = PMAS(KC(0),1)
RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
XLIM(1,1)=(RMS(1)+RMS(2))**2
XLIM(1,2)=(RMS(0)-RMS(3))**2
XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
XLIM(2,1)=(RMS(2)+RMS(3))**2
XLIM(2,2)=(RMS(0)-RMS(1))**2
XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
XLIM(3,1)=(RMS(1)+RMS(3))**2
XLIM(3,2)=(RMS(0)-RMS(2))**2
XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
C...Check Phase Space
IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
RETURN
ENDIF
C...INITIALIZE RESONANCE INFORMATION
DO 110 JRES = 1,3
DO 100 IMASS = 1,2
IRES = 2*(JRES-1)+IMASS
INTRES(IRES,1) = 0
DCHECK(IRES) =.FALSE.
C...NO RIGHT-HANDED NEUTRINOS
IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
& .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
& .KFR(JRES).EQ.0) GOTO 100
RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
INTRES(IRES,1) = IABS(KFR(JRES))
INTRES(IRES,2) = IMASS
IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
100 CONTINUE
110 CONTINUE
C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
C...RESONANCE CONTRIBUTIONS
C...(Only sum contributions where the resonance is off shell).
C...Store whether diagram on/off in DCHECK.
C...LOOP OVER MASS STATES
DO 120 J=1,2
IDR=J
IF(INTRES(IDR,1).NE.0) THEN
TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
& +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
DCHECK(IDR) =.TRUE.
XLAM = XLAM + TMIX * PYRVI1(2,3,1)
ENDIF
ENDIF
IDR=J+2
IF(INTRES(IDR,1).NE.0) THEN
TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
& +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
DCHECK(IDR) =.TRUE.
XLAM = XLAM + TMIX * PYRVI1(1,3,2)
ENDIF
ENDIF
IDR=J+4
IF(INTRES(IDR,1).NE.0) THEN
TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
& +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
DCHECK(IDR) =.TRUE.
XLAM = XLAM + TMIX * PYRVI1(1,2,3)
ENDIF
ENDIF
120 CONTINUE
C... L-R INTERFERENCES
C... (Only add contributions where both contributing diagrams
C... are non-resonant).
IDR=1
IF (DCHECK(1).AND.DCHECK(2)) THEN
C...Bug corrected 11/12 2001. Skands.
XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
& * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
& * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
ENDIF
IDR=3
IF (DCHECK(3).AND.DCHECK(4)) THEN
XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
& * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
& * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
ENDIF
IDR=5
IF (DCHECK(5).AND.DCHECK(6)) THEN
XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
& * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
& * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
ENDIF
C... TRUE INTERFERENCES
C... (Only add contributions where both contributing diagrams
C... are non-resonant).
PREF=-2D0
IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
DO 140 IKR1 = 1,2
DO 130 IKR2 = 1,2
IDR = IKR1+2
IDR2 = IKR2
IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
XLAM = XLAM + PREF*PYRVI3(1,3,2) *
& SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
& *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
ENDIF
IDR = IKR1+4
IDR2 = IKR2
IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
XLAM = XLAM + PREF*PYRVI3(1,2,3) *
& SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
& *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
ENDIF
IDR = IKR1+4
IDR2 = IKR2+2
IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
XLAM = XLAM + PREF*PYRVI3(2,1,3) *
& SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
& *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
ENDIF
130 CONTINUE
140 CONTINUE
RETURN
END
C*********************************************************************
C...PYRVI1
C...Function to integrate resonance contributions
FUNCTION PYRVI1(ID1,ID2,ID3)
IMPLICIT NONE
DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
LOGICAL MFLAG,DCMASS
EXTERNAL PYRVG1,PYGAUS
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
PYRVI1 = 0D0
RM(0) = RMS(0)
RM(1) = RMS(ID1)
RM(2) = RMS(ID2)
RM(3) = RMS(ID3)
RESM(1)= RES(IDR,1)
RESW(1)= RES(IDR,2)
C...A->B and B->A for antisparticles
A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
C...Integration boundaries and mass flag
LO = (RM(1)+RM(2))**2
HI = (RM(0)-RM(3))**2
MFLAG = DCMASS
PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
RETURN
END
C*********************************************************************
C...PYRVI2
C...Function to integrate L-R interference contributions
FUNCTION PYRVI2(ID1,ID2,ID3)
IMPLICIT NONE
DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
LOGICAL MFLAG,DCMASS
EXTERNAL PYRVG2,PYGAUS
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
PYRVI2 = 0D0
RM(0) = RMS(0)
RM(1) = RMS(ID1)
RM(2) = RMS(ID2)
RM(3) = RMS(ID3)
RESM(1)= RES(IDR,1)
RESW(1)= RES(IDR,2)
RESM(2)= RES(IDR+1,1)
RESW(2)= RES(IDR+1,2)
C...A->B and B->A for antisparticles
A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
C...Boundaries and mass flag
LO = (RM(1)+RM(2))**2
HI = (RM(0)-RM(3))**2
MFLAG = DCMASS
PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
RETURN
END
C*********************************************************************
C...PYRVI3
C...Function to integrate true interference contributions
FUNCTION PYRVI3(ID1,ID2,ID3)
IMPLICIT NONE
DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
LOGICAL MFLAG,DCMASS
EXTERNAL PYRVG3,PYGAUS
COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
& ,DCMASS,KFR(3)
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
PYRVI3 = 0D0
RM(0) = RMS(0)
RM(1) = RMS(ID1)
RM(2) = RMS(ID2)
RM(3) = RMS(ID3)
RESM(1)= RES(IDR,1)
RESW(1)= RES(IDR,2)
RESM(2)= RES(IDR2,1)
RESW(2)= RES(IDR2,2)
C...A -> B and B -> A for antisparticles
A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
C...Boundaries and mass flag
LO = (RM(1)+RM(2))**2
HI = (RM(0)-RM(3))**2
MFLAG = DCMASS
PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
RETURN
END
C*********************************************************************
C...PYRVG1
C...Integrand for resonance contributions
FUNCTION PYRVG1(X)
IMPLICIT NONE
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
LOGICAL MFLAG
SAVE/PYRVPM/
RVR = PYRVR(X,RESM(1),RESW(1))
C1 = 2D0*SQRT(MAX(0D0,X))
IF (.NOT.MFLAG) THEN
E2 = X/C1
E3 = (RM(0)**2-X)/C1
DELTAY = 4D0*E2*E3
PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
ELSE
E2 = (X-RM(1)**2+RM(2)**2)/C1
E3 = (RM(0)**2-X-RM(3)**2)/C1
SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
DELTAY = 4D0*SR1*SR2
A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
ENDIF
RETURN
END
C*********************************************************************
C...PYRVG2
C...Integrand for L-R interference contributions
FUNCTION PYRVG2(X)
IMPLICIT NONE
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
LOGICAL MFLAG
SAVE/PYRVPM/
C1 = 2D0*SQRT(MAX(0D0,X))
RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
IF (.NOT.MFLAG) THEN
E2 = X/C1
E3 = (RM(0)**2-X)/C1
DELTAY = 4D0*E2*E3
PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
ELSE
E2 = (X-RM(1)**2+RM(2)**2)/C1
E3 = (RM(0)**2-X-RM(3)**2)/C1
SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
DELTAY = 4D0*SR1*SR2
PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
& + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
& + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
ENDIF
RETURN
END
C*********************************************************************
C...PYRVG3
C...Function to do Y integration over true interference contributions
FUNCTION PYRVG3(X)
IMPLICIT NONE
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
C...Second Dalitz variable for PYRVG4
COMMON/PYG2DX/X1
DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
LOGICAL MFLAG
EXTERNAL PYGAU2,PYRVG4
SAVE/PYRVPM/,/PYG2DX/
PYRVG3=0D0
C1=2D0*SQRT(MAX(1D-9,X))
X1=X
IF (.NOT.MFLAG) THEN
E2 = X/C1
E3 = (RM(0)**2-X)/C1
YMIN = 0D0
YMAX = 4D0*E2*E3
ELSE
E2 = (X-RM(1)**2+RM(2)**2)/C1
E3 = (RM(0)**2-X-RM(3)**2)/C1
SQ1 = (E2+E3)**2
SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
YMIN = SQ1-(SR1+SR2)**2
YMAX = SQ1-(SR1-SR2)**2
ENDIF
PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
RETURN
END
C*********************************************************************
C...PYRVG4
C...Integrand for true intereference contributions
FUNCTION PYRVG4(Y)
IMPLICIT NONE
COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
COMMON/PYG2DX/X
DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
LOGICAL MFLAG
SAVE /PYRVPM/,/PYG2DX/
PYRVG4=0D0
RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
IF (.NOT.MFLAG) THEN
PYRVG4 = RVS*B(1)*B(2)*X*Y
ELSE
PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
& + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
& + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
& + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
ENDIF
RETURN
END
C*********************************************************************
C...PYRVR
C...Breit-Wigner for resonance contributions
FUNCTION PYRVR(Mab2,RM,RW)
IMPLICIT NONE
DOUBLE PRECISION Mab2,RM,RW,PYRVR
PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
RETURN
END
C*********************************************************************
C...PYRVS
C...Interference function
FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
IMPLICIT NONE
DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
& +W1*W2*M1*M2)
RETURN
END
C*********************************************************************
C...PY1ENT
C...Stores one parton/particle in commonblock PYJETS.
SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Standard checks.
MSTU(28)=0
IF(MSTU(12).NE.12345) CALL PYLIST(0)
IPA=MAX(1,IABS(IP))
IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
&'(PY1ENT:) writing outside PYJETS memory')
KC=PYCOMP(KF)
IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
C...Find mass. Reset K, P and V vectors.
PM=0D0
IF(MSTU(10).EQ.1) PM=P(IPA,5)
IF(MSTU(10).GE.2) PM=PYMASS(KF)
DO 100 J=1,5
K(IPA,J)=0
P(IPA,J)=0D0
V(IPA,J)=0D0
100 CONTINUE
C...Store parton/particle in K and P vectors.
K(IPA,1)=1
IF(IP.LT.0) K(IPA,1)=2
K(IPA,2)=KF
P(IPA,5)=PM
P(IPA,4)=MAX(PE,PM)
PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
P(IPA,1)=PA*SIN(THE)*COS(PHI)
P(IPA,2)=PA*SIN(THE)*SIN(PHI)
P(IPA,3)=PA*COS(THE)
C...Set N. Optionally fragment/decay.
N=IPA
IF(IP.EQ.0) CALL PYEXEC
RETURN
END
C*********************************************************************
C...PY2ENT
C...Stores two partons/particles in their CM frame,
C...with the first along the +z axis.
SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Standard checks.
MSTU(28)=0
IF(MSTU(12).NE.12345) CALL PYLIST(0)
IPA=MAX(1,IABS(IP))
IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
&'(PY2ENT:) writing outside PYJETS memory')
KC1=PYCOMP(KF1)
KC2=PYCOMP(KF2)
IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
&'(PY2ENT:) unknown flavour code')
C...Find masses. Reset K, P and V vectors.
PM1=0D0
IF(MSTU(10).EQ.1) PM1=P(IPA,5)
IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
PM2=0D0
IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
DO 110 I=IPA,IPA+1
DO 100 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
100 CONTINUE
110 CONTINUE
C...Check flavours.
KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
IF(MSTU(19).EQ.1) THEN
MSTU(19)=0
ELSE
IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
& '(PY2ENT:) unphysical flavour combination')
ENDIF
K(IPA,2)=KF1
K(IPA+1,2)=KF2
C...Store partons/particles in K vectors for normal case.
IF(IP.GE.0) THEN
K(IPA,1)=1
IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
K(IPA+1,1)=1
C...Store partons in K vectors for parton shower evolution.
ELSE
K(IPA,1)=3
K(IPA+1,1)=3
K(IPA,4)=MSTU(5)*(IPA+1)
K(IPA,5)=K(IPA,4)
K(IPA+1,4)=MSTU(5)*IPA
K(IPA+1,5)=K(IPA+1,4)
ENDIF
C...Check kinematics and store partons/particles in P vectors.
IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
&'(PY2ENT:) energy smaller than sum of masses')
PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
&(2D0*PECM)
P(IPA,3)=PA
P(IPA,4)=SQRT(PM1**2+PA**2)
P(IPA,5)=PM1
P(IPA+1,3)=-PA
P(IPA+1,4)=SQRT(PM2**2+PA**2)
P(IPA+1,5)=PM2
C...Set N. Optionally fragment/decay.
N=IPA+1
IF(IP.EQ.0) CALL PYEXEC
RETURN
END
C*********************************************************************
C...PY3ENT
C...Stores three partons or particles in their CM frame,
C...with the first along the +z axis and the third in the (x,z)
C...plane with x > 0.
SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Standard checks.
MSTU(28)=0
IF(MSTU(12).NE.12345) CALL PYLIST(0)
IPA=MAX(1,IABS(IP))
IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
&'(PY3ENT:) writing outside PYJETS memory')
KC1=PYCOMP(KF1)
KC2=PYCOMP(KF2)
KC3=PYCOMP(KF3)
IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
&'(PY3ENT:) unknown flavour code')
C...Find masses. Reset K, P and V vectors.
PM1=0D0
IF(MSTU(10).EQ.1) PM1=P(IPA,5)
IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
PM2=0D0
IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
PM3=0D0
IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
DO 110 I=IPA,IPA+2
DO 100 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
100 CONTINUE
110 CONTINUE
C...Check flavours.
KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
IF(MSTU(19).EQ.1) THEN
MSTU(19)=0
ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
& KQ1+KQ3.EQ.4)) THEN
ELSE
CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
ENDIF
K(IPA,2)=KF1
K(IPA+1,2)=KF2
K(IPA+2,2)=KF3
C...Store partons/particles in K vectors for normal case.
IF(IP.GE.0) THEN
K(IPA,1)=1
IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
K(IPA+1,1)=1
IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
K(IPA+2,1)=1
C...Store partons in K vectors for parton shower evolution.
ELSE
K(IPA,1)=3
K(IPA+1,1)=3
K(IPA+2,1)=3
KCS=4
IF(KQ1.EQ.-1) KCS=5
K(IPA,KCS)=MSTU(5)*(IPA+1)
K(IPA,9-KCS)=MSTU(5)*(IPA+2)
K(IPA+1,KCS)=MSTU(5)*(IPA+2)
K(IPA+1,9-KCS)=MSTU(5)*IPA
K(IPA+2,KCS)=MSTU(5)*IPA
K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
ENDIF
C...Check kinematics.
MKERR=0
IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
&0.5D0*X3*PECM.LE.PM3) MKERR=1
PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
IF(MKERR.NE.0) CALL PYERRM(13,
&'(PY3ENT:) unphysical kinematical variable setup')
C...Store partons/particles in P vectors.
P(IPA,3)=PA1
P(IPA,4)=SQRT(PA1**2+PM1**2)
P(IPA,5)=PM1
P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
P(IPA+2,3)=PA3*CTHE3
P(IPA+2,4)=SQRT(PA3**2+PM3**2)
P(IPA+2,5)=PM3
P(IPA+1,1)=-P(IPA+2,1)
P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
P(IPA+1,5)=PM2
C...Set N. Optionally fragment/decay.
N=IPA+2
IF(IP.EQ.0) CALL PYEXEC
RETURN
END
C*********************************************************************
C...PY4ENT
C...Stores four partons or particles in their CM frame, with
C...the first along the +z axis, the last in the xz plane with x > 0
C...and the second having y < 0 and y > 0 with equal probability.
SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Standard checks.
MSTU(28)=0
IF(MSTU(12).NE.12345) CALL PYLIST(0)
IPA=MAX(1,IABS(IP))
IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
&'(PY4ENT:) writing outside PYJETS momory')
KC1=PYCOMP(KF1)
KC2=PYCOMP(KF2)
KC3=PYCOMP(KF3)
KC4=PYCOMP(KF4)
IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
&'(PY4ENT:) unknown flavour code')
C...Find masses. Reset K, P and V vectors.
PM1=0D0
IF(MSTU(10).EQ.1) PM1=P(IPA,5)
IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
PM2=0D0
IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
PM3=0D0
IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
PM4=0D0
IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
DO 110 I=IPA,IPA+3
DO 100 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=0D0
100 CONTINUE
110 CONTINUE
C...Check flavours.
KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
IF(MSTU(19).EQ.1) THEN
MSTU(19)=0
ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
& KQ1+KQ4.EQ.4)) THEN
ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
& THEN
ELSE
CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
ENDIF
K(IPA,2)=KF1
K(IPA+1,2)=KF2
K(IPA+2,2)=KF3
K(IPA+3,2)=KF4
C...Store partons/particles in K vectors for normal case.
IF(IP.GE.0) THEN
K(IPA,1)=1
IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
K(IPA+1,1)=1
IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
& K(IPA+1,1)=2
K(IPA+2,1)=1
IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
K(IPA+3,1)=1
C...Store partons for parton shower evolution from q-g-g-qbar or
C...g-g-g-g event.
ELSEIF(KQ1+KQ2.NE.0) THEN
K(IPA,1)=3
K(IPA+1,1)=3
K(IPA+2,1)=3
K(IPA+3,1)=3
KCS=4
IF(KQ1.EQ.-1) KCS=5
K(IPA,KCS)=MSTU(5)*(IPA+1)
K(IPA,9-KCS)=MSTU(5)*(IPA+3)
K(IPA+1,KCS)=MSTU(5)*(IPA+2)
K(IPA+1,9-KCS)=MSTU(5)*IPA
K(IPA+2,KCS)=MSTU(5)*(IPA+3)
K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
K(IPA+3,KCS)=MSTU(5)*IPA
K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
C...Store partons for parton shower evolution from q-qbar-q-qbar event.
ELSE
K(IPA,1)=3
K(IPA+1,1)=3
K(IPA+2,1)=3
K(IPA+3,1)=3
K(IPA,4)=MSTU(5)*(IPA+1)
K(IPA,5)=K(IPA,4)
K(IPA+1,4)=MSTU(5)*IPA
K(IPA+1,5)=K(IPA+1,4)
K(IPA+2,4)=MSTU(5)*(IPA+3)
K(IPA+2,5)=K(IPA+2,4)
K(IPA+3,4)=MSTU(5)*(IPA+2)
K(IPA+3,5)=K(IPA+3,4)
ENDIF
C...Check kinematics.
MKERR=0
IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
&0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
&MKERR=1
PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
IF(ABS(CTHE4).GE.1.002D0) MKERR=1
CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
STHE4=SQRT(1D0-CTHE4**2)
CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
IF(ABS(CTHE2).GE.1.002D0) MKERR=1
CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
STHE2=SQRT(1D0-CTHE2**2)
CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
&MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
IF(ABS(CPHI2).GE.1.05D0) MKERR=1
CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
IF(MKERR.EQ.1) CALL PYERRM(13,
&'(PY4ENT:) unphysical kinematical variable setup')
C...Store partons/particles in P vectors.
P(IPA,3)=PA1
P(IPA,4)=SQRT(PA1**2+PM1**2)
P(IPA,5)=PM1
P(IPA+3,1)=PA4*STHE4
P(IPA+3,3)=PA4*CTHE4
P(IPA+3,4)=SQRT(PA4**2+PM4**2)
P(IPA+3,5)=PM4
P(IPA+1,1)=PA2*STHE2*CPHI2
P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
P(IPA+1,3)=PA2*CTHE2
P(IPA+1,4)=SQRT(PA2**2+PM2**2)
P(IPA+1,5)=PM2
P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
P(IPA+2,2)=-P(IPA+1,2)
P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
P(IPA+2,5)=PM3
C...Set N. Optionally fragment/decay.
N=IPA+3
IF(IP.EQ.0) CALL PYEXEC
RETURN
END
C*********************************************************************
C...PY2FRM
C...An interface from a two-fermion generator to include
C...parton showers and hadronization.
SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYJETS/,/PYDAT1/
C...Local arrays.
DIMENSION IJOIN(2),INTAU(2)
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(2)
ENDIF
C...Loop through entries and pick up all final fermions/antifermions.
I1=0
I2=0
DO 100 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
KFA=IABS(K(I,2))
IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
IF(K(I,2).GT.0) THEN
IF(I1.EQ.0) THEN
I1=I
ELSE
CALL PYERRM(16,'(PY2FRM:) more than one fermion')
ENDIF
ELSE
IF(I2.EQ.0) THEN
I2=I
ELSE
CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
ENDIF
ENDIF
ENDIF
100 CONTINUE
C...Check that event is arranged according to conventions.
IF(I1.EQ.0.OR.I2.EQ.0) THEN
CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
ENDIF
IF(I2.LT.I1) THEN
CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
ENDIF
C...Check whether fermion pair is quarks or leptons.
IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
IQL12=1
ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
IQL12=2
ELSE
CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
ENDIF
C...Decide whether to allow or not photon radiation in showers.
MSTJ(41)=2
IF(IRAD.EQ.0) MSTJ(41)=1
C...Do colour joining and parton showers.
IP1=I1
IP2=I2
IF(IQL12.EQ.1) THEN
IJOIN(1)=IP1
IJOIN(2)=IP2
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
& (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
ENDIF
C...Do fragmentation and decays. Possibly except tau decay.
IF(ITAU.EQ.0) THEN
NTAU=0
DO 110 I=1,N
IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
NTAU=NTAU+1
INTAU(NTAU)=I
K(I,1)=11
ENDIF
110 CONTINUE
ENDIF
CALL PYEXEC
IF(ITAU.EQ.0) THEN
DO 120 I=1,NTAU
K(INTAU(I),1)=1
120 CONTINUE
ENDIF
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(1)
ENDIF
END
C*********************************************************************
C...PY4FRM
C...An interface from a four-fermion generator to include
C...parton showers and hadronization.
SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
C...Local arrays.
DIMENSION IJOIN(2),INTAU(4)
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(2)
ENDIF
C...Loop through entries and pick up all final fermions/antifermions.
I1=0
I2=0
I3=0
I4=0
DO 100 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
KFA=IABS(K(I,2))
IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
IF(K(I,2).GT.0) THEN
IF(I1.EQ.0) THEN
I1=I
ELSEIF(I3.EQ.0) THEN
I3=I
ELSE
CALL PYERRM(16,'(PY4FRM:) more than two fermions')
ENDIF
ELSE
IF(I2.EQ.0) THEN
I2=I
ELSEIF(I4.EQ.0) THEN
I4=I
ELSE
CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
ENDIF
ENDIF
ENDIF
100 CONTINUE
C...Check that event is arranged according to conventions.
IF(I3.EQ.0.OR.I4.EQ.0) THEN
CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
ENDIF
IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
ENDIF
C...Check which fermion pairs are quarks and which leptons.
IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
IQL12=1
ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
IQL12=2
ELSE
CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
ENDIF
IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
IQL34=1
ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
IQL34=2
ELSE
CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
ENDIF
C...Decide whether to allow or not photon radiation in showers.
MSTJ(41)=2
IF(IRAD.EQ.0) MSTJ(41)=1
C...Decide on dipole pairing.
IP1=I1
IP2=I2
IP3=I3
IP4=I4
IF(IQL12.EQ.IQL34) THEN
R1SQ=A1SQ
R2SQ=A2SQ
DELTA=ATOTSQ-A1SQ-A2SQ
IF(ISTRAT.EQ.1) THEN
IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
ELSEIF(ISTRAT.EQ.2) THEN
IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
ENDIF
IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
IP2=I4
IP4=I2
ENDIF
ENDIF
C...If colour reconnection then bookkeep W+W- or Z0Z0
C...and copy q qbar q qbar consecutively.
IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
K(N+1,1)=11
K(N+1,3)=IP1
K(N+1,4)=N+3
K(N+1,5)=N+4
K(N+2,1)=11
K(N+2,3)=IP3
K(N+2,4)=N+5
K(N+2,5)=N+6
IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
K(N+1,2)=23
K(N+2,2)=23
MINT(1)=22
ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
K(N+1,2)=24
K(N+2,2)=-24
MINT(1)=25
ELSE
K(N+1,2)=-24
K(N+2,2)=24
MINT(1)=25
ENDIF
DO 110 J=1,5
K(N+3,J)=K(IP1,J)
K(N+4,J)=K(IP2,J)
K(N+5,J)=K(IP3,J)
K(N+6,J)=K(IP4,J)
P(N+1,J)=P(IP1,J)+P(IP2,J)
P(N+2,J)=P(IP3,J)+P(IP4,J)
P(N+3,J)=P(IP1,J)
P(N+4,J)=P(IP2,J)
P(N+5,J)=P(IP3,J)
P(N+6,J)=P(IP4,J)
V(N+1,J)=V(IP1,J)
V(N+2,J)=V(IP3,J)
V(N+3,J)=V(IP1,J)
V(N+4,J)=V(IP2,J)
V(N+5,J)=V(IP3,J)
V(N+6,J)=V(IP4,J)
110 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
& P(N+2,3)**2))
K(N+3,3)=N+1
K(N+4,3)=N+1
K(N+5,3)=N+2
K(N+6,3)=N+2
C...Remove original q qbar q qbar and update counters.
K(IP1,1)=K(IP1,1)+10
K(IP2,1)=K(IP2,1)+10
K(IP3,1)=K(IP3,1)+10
K(IP4,1)=K(IP4,1)+10
IW1=N+1
IW2=N+2
NSD1=N+2
IP1=N+3
IP2=N+4
IP3=N+5
IP4=N+6
N=N+6
ENDIF
C...Do colour joinings and parton showers.
IF(IQL12.EQ.1) THEN
IJOIN(1)=IP1
IJOIN(2)=IP2
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
& (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
ENDIF
NAFT1=N
IF(IQL34.EQ.1) THEN
IJOIN(1)=IP3
IJOIN(2)=IP4
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
& (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
ENDIF
C...Optionally do colour reconnection.
MINT(32)=0
MSTI(32)=0
IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
CALL PYRECO(IW1,IW2,NSD1,NAFT1)
MSTI(32)=MINT(32)
ENDIF
C...Do fragmentation and decays. Possibly except tau decay.
IF(ITAU.EQ.0) THEN
NTAU=0
DO 120 I=1,N
IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
NTAU=NTAU+1
INTAU(NTAU)=I
K(I,1)=11
ENDIF
120 CONTINUE
ENDIF
CALL PYEXEC
IF(ITAU.EQ.0) THEN
DO 130 I=1,NTAU
K(INTAU(I),1)=1
130 CONTINUE
ENDIF
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(1)
ENDIF
END
C*********************************************************************
C...PY6FRM
C...An interface from a six-fermion generator to include
C...parton showers and hadronization.
SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYJETS/,/PYDAT1/
C...Local arrays.
DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(2)
ENDIF
C...Loop through entries and pick up all final fermions/antifermions.
I1=0
I2=0
I3=0
I4=0
I5=0
I6=0
DO 100 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
KFA=IABS(K(I,2))
IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
IF(K(I,2).GT.0) THEN
IF(I1.EQ.0) THEN
I1=I
ELSEIF(I3.EQ.0) THEN
I3=I
ELSEIF(I5.EQ.0) THEN
I5=I
ELSE
CALL PYERRM(16,'(PY6FRM:) more than three fermions')
ENDIF
ELSE
IF(I2.EQ.0) THEN
I2=I
ELSEIF(I4.EQ.0) THEN
I4=I
ELSEIF(I6.EQ.0) THEN
I6=I
ELSE
CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
ENDIF
ENDIF
ENDIF
100 CONTINUE
C...Check that event is arranged according to conventions.
IF(I5.EQ.0.OR.I6.EQ.0) THEN
CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
ENDIF
IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
ENDIF
C...Check which fermion pairs are quarks and which leptons.
IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
IQL12=1
ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
IQL12=2
ELSE
CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
ENDIF
IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
IQL34=1
ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
IQL34=2
ELSE
CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
ENDIF
IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
IQL56=1
ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
IQL56=2
ELSE
CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
ENDIF
C...Decide whether to allow or not photon radiation in showers.
MSTJ(41)=2
IF(IRAD.EQ.0) MSTJ(41)=1
C...Allow dipole pairings only among leptons and quarks separately.
P12D=P12
P13D=0D0
IF(IQL34.EQ.IQL56) P13D=P13
P21D=0D0
IF(IQL12.EQ.IQL34) P21D=P21
P23D=0D0
IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
P31D=0D0
IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
P32D=0D0
IF(IQL12.EQ.IQL56) P32D=P32
C...Decide whether t+tbar.
ITOP=0
IF(PYR(0).LT.PTOP) THEN
ITOP=1
C...If t+tbar: reconstruct t's.
IT=N+1
ITB=N+2
DO 110 J=1,5
K(IT,J)=0
K(ITB,J)=0
P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
V(IT,J)=0D0
V(ITB,J)=0D0
110 CONTINUE
K(IT,1)=1
K(ITB,1)=1
K(IT,2)=6
K(ITB,2)=-6
P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
& P(IT,3)**2))
P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
& P(ITB,3)**2))
N=N+2
C...If t+tbar: colour join t's and let them shower.
IJOIN(1)=IT
IJOIN(2)=ITB
CALL PYJOIN(2,IJOIN)
PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
& (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
C...If t+tbar: pick up the t's after shower.
ITNEW=IT
ITBNEW=ITB
DO 120 I=ITB+1,N
IF(K(I,2).EQ.6) ITNEW=I
IF(K(I,2).EQ.-6) ITBNEW=I
120 CONTINUE
C...If t+tbar: loop over two top systems.
DO 200 IT1=1,2
IF(IT1.EQ.1) THEN
ITO=IT
ITN=ITNEW
IBO=I1
IW1=I3
IW2=I4
ELSE
ITO=ITB
ITN=ITBNEW
IBO=I2
IW1=I5
IW2=I6
ENDIF
IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
& '(PY6FRM:) not b in t decay')
C...If t+tbar: find boost from original to new top frame.
DO 130 J=1,3
BETAO(J)=P(ITO,J)/P(ITO,4)
BETAN(J)=P(ITN,J)/P(ITN,4)
130 CONTINUE
C...If t+tbar: boost copy of b by t shower and connect it in colour.
N=N+1
IB=N
K(IB,1)=3
K(IB,2)=K(IBO,2)
K(IB,3)=ITN
DO 140 J=1,5
P(IB,J)=P(IBO,J)
V(IB,J)=0D0
140 CONTINUE
CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
K(IB,4)=MSTU(5)*ITN
K(IB,5)=MSTU(5)*ITN
K(ITN,4)=K(ITN,4)+IB
K(ITN,5)=K(ITN,5)+IB
K(ITN,1)=K(ITN,1)+10
K(IBO,1)=K(IBO,1)+10
C...If t+tbar: construct W recoiling against b.
N=N+1
IW=N
DO 150 J=1,5
K(IW,J)=0
V(IW,J)=0D0
150 CONTINUE
K(IW,1)=1
KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
IF(IABS(KCHW).EQ.3) THEN
K(IW,2)=ISIGN(24,KCHW)
ELSE
CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
ENDIF
K(IW,3)=IW1
C...If t+tbar: construct W momentum, including boost by t shower.
DO 160 J=1,4
P(IW,J)=P(IW1,J)+P(IW2,J)
160 CONTINUE
P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
& P(IW,3)**2))
CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
C...If t+tbar: boost b and W to top rest frame.
DO 170 J=1,3
BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
170 CONTINUE
CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
C...If t+tbar: let b shower and pick up modified W.
PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
& (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
DO 180 I=IW,N
IF(IABS(K(I,2)).EQ.24) IWM=I
180 CONTINUE
C...If t+tbar: take copy of W decay products.
DO 190 J=1,5
K(N+1,J)=K(IW1,J)
P(N+1,J)=P(IW1,J)
V(N+1,J)=V(IW1,J)
K(N+2,J)=K(IW2,J)
P(N+2,J)=P(IW2,J)
V(N+2,J)=V(IW2,J)
190 CONTINUE
K(IW1,1)=K(IW1,1)+10
K(IW2,1)=K(IW2,1)+10
K(IWM,1)=K(IWM,1)+10
K(IWM,4)=N+1
K(IWM,5)=N+2
K(N+1,3)=IWM
K(N+2,3)=IWM
IF(IT1.EQ.1) THEN
I3=N+1
I4=N+2
ELSE
I5=N+1
I6=N+2
ENDIF
N=N+2
C...If t+tbar: boost W decay products, first by effects of t shower,
C...then by those of b shower. b and its shower simple boost back.
CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
& -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
& P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
200 CONTINUE
ENDIF
C...Decide on dipole pairing.
IP1=I1
IP3=I3
IP5=I5
PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
IP2=I2
IP4=I4
IP6=I6
ELSEIF(PRN.LT.P12D+P13D) THEN
IP2=I2
IP4=I6
IP6=I4
ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
IP2=I4
IP4=I2
IP6=I6
ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
IP2=I4
IP4=I6
IP6=I2
ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
IP2=I6
IP4=I2
IP6=I4
ELSE
IP2=I6
IP4=I4
IP6=I2
ENDIF
C...Do colour joinings and parton showers
C...(except ones already made for t+tbar).
IF(ITOP.EQ.0) THEN
IF(IQL12.EQ.1) THEN
IJOIN(1)=IP1
IJOIN(2)=IP2
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
& (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
ENDIF
ENDIF
IF(IQL34.EQ.1) THEN
IJOIN(1)=IP3
IJOIN(2)=IP4
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
& (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
ENDIF
IF(IQL56.EQ.1) THEN
IJOIN(1)=IP5
IJOIN(2)=IP6
CALL PYJOIN(2,IJOIN)
ENDIF
IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
& (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
ENDIF
C...Do fragmentation and decays. Possibly except tau decay.
IF(ITAU.EQ.0) THEN
NTAU=0
DO 210 I=1,N
IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
NTAU=NTAU+1
INTAU(NTAU)=I
K(I,1)=11
ENDIF
210 CONTINUE
ENDIF
CALL PYEXEC
IF(ITAU.EQ.0) THEN
DO 220 I=1,NTAU
K(INTAU(I),1)=1
220 CONTINUE
ENDIF
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(1)
ENDIF
END
C*********************************************************************
C...PY4JET
C...An interface from a four-parton generator to include
C...parton showers and hadronization.
SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE /PYJETS/,/PYDAT1/
C...Local arrays.
DIMENSION IJOIN(2),PTOT(4),BETA(3)
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(2)
ENDIF
C...Loop through entries and pick up all final partons.
I1=0
I2=0
I3=0
I4=0
DO 100 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
KFA=IABS(K(I,2))
IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
IF(I1.EQ.0) THEN
I1=I
ELSEIF(I3.EQ.0) THEN
I3=I
ELSE
CALL PYERRM(16,'(PY4JET:) more than two quarks')
ENDIF
ELSEIF(K(I,2).LT.0) THEN
IF(I2.EQ.0) THEN
I2=I
ELSEIF(I4.EQ.0) THEN
I4=I
ELSE
CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
ENDIF
ELSE
IF(I3.EQ.0) THEN
I3=I
ELSEIF(I4.EQ.0) THEN
I4=I
ELSE
CALL PYERRM(16,'(PY4JET:) more than two gluons')
ENDIF
ENDIF
ENDIF
100 CONTINUE
C...Check that event is arranged according to conventions.
IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
CALL PYERRM(16,'(PY4JET:) event contains too few partons')
ENDIF
IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
ENDIF
C...Check whether second pair are quarks or gluons.
IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
IQG34=1
ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
IQG34=2
ELSE
CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
ENDIF
C...Boost partons to their cm frame.
DO 110 J=1,4
PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
110 CONTINUE
ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
DO 120 J=1,3
BETA(J)=PTOT(J)/PTOT(4)
120 CONTINUE
CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
NSAV=N
C...Decide and set up shower history for q qbar q' qbar' events.
IF(IQG34.EQ.1) THEN
W1=PY4JTW(0,I1,I3,I4)
W2=PY4JTW(0,I2,I3,I4)
IF(W1.GT.PYR(0)*(W1+W2)) THEN
CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
ELSE
CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
ENDIF
C...Decide and set up shower history for q qbar g g events.
ELSE
W1=PY4JTW(I1,I3,I2,I4)
W2=PY4JTW(I1,I4,I2,I3)
W3=PY4JTW(0,I3,I1,I4)
W4=PY4JTW(0,I4,I1,I3)
W5=PY4JTW(0,I3,I2,I4)
W6=PY4JTW(0,I4,I2,I3)
W7=PY4JTW(0,I1,I3,I4)
W8=PY4JTW(0,I2,I3,I4)
WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
IF(W1.GT.WR) THEN
CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
ELSEIF(W1+W2.GT.WR) THEN
CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
ELSEIF(W1+W2+W3.GT.WR) THEN
CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
ELSEIF(W1+W2+W3+W4.GT.WR) THEN
CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
ELSE
CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
ENDIF
ENDIF
C...Boost back original partons and mark them as deleted.
CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
K(I1,1)=K(I1,1)+10
K(I2,1)=K(I2,1)+10
K(I3,1)=K(I3,1)+10
K(I4,1)=K(I4,1)+10
C...Rotate shower initiating partons to be along z axis.
PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
C...Set up copy of shower initiating partons as on mass shell.
DO 140 I=N+1,N+2
DO 130 J=1,5
K(I,J)=0
P(I,J)=0D0
V(I,J)=V(I1,J)
130 CONTINUE
K(I,1)=1
K(I,2)=K(I-6,2)
140 CONTINUE
IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
K(N+1,3)=I1
P(N+1,5)=P(I1,5)
K(N+2,3)=I2
P(N+2,5)=P(I2,5)
ELSE
K(N+1,3)=I2
P(N+1,5)=P(I2,5)
K(N+2,3)=I1
P(N+2,5)=P(I1,5)
ENDIF
PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
&(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
P(N+1,3)=PABS
P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
P(N+2,3)=-PABS
P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
N=N+2
C...Decide whether to allow or not photon radiation in showers.
C...Connect up colours.
MSTJ(41)=2
IF(IRAD.EQ.0) MSTJ(41)=1
IJOIN(1)=N-1
IJOIN(2)=N
CALL PYJOIN(2,IJOIN)
C...Decide on maximum virtuality and do parton shower.
IF(PMAX.LT.PARJ(82)) THEN
PQMAX=QMAX
ELSE
PQMAX=PMAX
ENDIF
CALL PYSHOW(NSAV+1,-100,PQMAX)
C...Rotate and boost back system.
CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
C...Do fragmentation and decays.
CALL PYEXEC
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
IF(ICOM.EQ.0) THEN
MSTU(28)=0
CALL PYHEPC(1)
ENDIF
RETURN
END
C*********************************************************************
C...PY4JTW
C...Auxiliary to PY4JET, to evaluate weight of configuration.
FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
SAVE /PYJETS/
C...First case: when both original partons radiate.
C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
IF(IA1.NE.0) THEN
DO 100 J=1,4
P(N+1,J)=P(IA1,J)+P(IA2,J)
P(N+2,J)=P(IA3,J)+P(IA4,J)
100 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
& P(N+2,3)**2))
Z1=P(IA1,4)/P(N+1,4)
WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
Z2=P(IA3,4)/P(N+2,4)
WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
C...Second case: when one original parton radiates to three.
C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
ELSE
DO 110 J=1,4
P(N+2,J)=P(IA3,J)+P(IA4,J)
P(N+1,J)=P(N+2,J)+P(IA2,J)
110 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
& P(N+2,3)**2))
IF(K(IA2,2).EQ.21) THEN
Z1=P(N+2,4)/P(N+1,4)
WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
& P(IA3,5)**2)
ELSE
Z1=P(IA2,4)/P(N+1,4)
WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
& P(IA2,5)**2)
ENDIF
Z2=P(IA3,4)/P(N+2,4)
IF(K(IA2,2).EQ.21) THEN
WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
& P(IA3,5)**2)
ELSEIF(K(IA3,2).EQ.21) THEN
WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
ELSE
WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
ENDIF
ENDIF
C...Total weight.
PY4JTW=WT1*WT2
RETURN
END
C*********************************************************************
C...PY4JTS
C...Auxiliary to PY4JET, to set up chosen configuration.
SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
SAVE /PYJETS/
C...Reset info.
DO 110 I=N+1,N+6
DO 100 J=1,5
K(I,J)=0
V(I,J)=V(IA2,J)
100 CONTINUE
K(I,1)=16
110 CONTINUE
C...First case: when both original partons radiate.
C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
IF(IA1.NE.0) THEN
C...Set up flavour and history pointers for new partons.
K(N+1,2)=K(IA1,2)
K(N+2,2)=K(IA3,2)
K(N+3,2)=K(IA1,2)
K(N+4,2)=K(IA2,2)
K(N+5,2)=K(IA3,2)
K(N+6,2)=K(IA4,2)
K(N+1,3)=IA1
K(N+1,4)=N+3
K(N+1,5)=N+4
K(N+2,3)=IA3
K(N+2,4)=N+5
K(N+2,5)=N+6
K(N+3,3)=N+1
K(N+4,3)=N+1
K(N+5,3)=N+2
K(N+6,3)=N+2
C...Set up momenta for new partons.
DO 120 J=1,5
P(N+1,J)=P(IA1,J)+P(IA2,J)
P(N+2,J)=P(IA3,J)+P(IA4,J)
P(N+3,J)=P(IA1,J)
P(N+4,J)=P(IA2,J)
P(N+5,J)=P(IA3,J)
P(N+6,J)=P(IA4,J)
120 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
& P(N+2,3)**2))
QMAX=MIN(P(N+1,5),P(N+2,5))
C...Second case: q radiates twice.
C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
ELSEIF(K(IA2,2).EQ.21) THEN
C...Set up flavour and history pointers for new partons.
K(N+1,2)=K(IA3,2)
K(N+2,2)=K(IA5,2)
K(N+3,2)=K(IA3,2)
K(N+4,2)=K(IA2,2)
K(N+5,2)=K(IA3,2)
K(N+6,2)=K(IA4,2)
K(N+1,3)=IA3
K(N+1,4)=N+3
K(N+1,5)=N+4
K(N+2,3)=IA5
K(N+3,3)=N+1
K(N+3,4)=N+5
K(N+3,5)=N+6
K(N+4,3)=N+1
K(N+5,3)=N+3
K(N+6,3)=N+3
C...Set up momenta for new partons.
DO 130 J=1,5
P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
P(N+2,J)=P(IA5,J)
P(N+3,J)=P(IA3,J)+P(IA4,J)
P(N+4,J)=P(IA2,J)
P(N+5,J)=P(IA3,J)
P(N+6,J)=P(IA4,J)
130 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
& P(N+3,3)**2))
QMAX=P(N+3,5)
C...Third case: q radiates g, g branches.
C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
ELSE
C...Set up flavour and history pointers for new partons.
K(N+1,2)=K(IA2,2)
K(N+2,2)=K(IA5,2)
K(N+3,2)=K(IA2,2)
K(N+4,2)=21
K(N+5,2)=K(IA3,2)
K(N+6,2)=K(IA4,2)
K(N+1,3)=IA2
K(N+1,4)=N+3
K(N+1,5)=N+4
K(N+2,3)=IA5
K(N+3,3)=N+1
K(N+4,3)=N+1
K(N+4,4)=N+5
K(N+4,5)=N+6
K(N+5,3)=N+4
K(N+6,3)=N+4
C...Set up momenta for new partons.
DO 140 J=1,5
P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
P(N+2,J)=P(IA5,J)
P(N+3,J)=P(IA2,J)
P(N+4,J)=P(IA3,J)+P(IA4,J)
P(N+5,J)=P(IA3,J)
P(N+6,J)=P(IA4,J)
140 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
& P(N+4,3)**2))
QMAX=P(N+4,5)
ENDIF
N=N+6
RETURN
END
C*********************************************************************
C...PYJOIN
C...Connects a sequence of partons with colour flow indices,
C...as required for subsequent shower evolution (or other operations).
SUBROUTINE PYJOIN(NJOIN,IJOIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Local array.
DIMENSION IJOIN(*)
C...Check that partons are of right types to be connected.
IF(NJOIN.LT.2) GOTO 120
KQSUM=0
DO 100 IJN=1,NJOIN
I=IJOIN(IJN)
IF(I.LE.0.OR.I.GT.N) GOTO 120
IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 120
KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
IF(KQ.EQ.0) GOTO 120
IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
IF(KQ.NE.2) KQSUM=KQSUM+KQ
IF(IJN.EQ.1) KQS=KQ
100 CONTINUE
IF(KQSUM.NE.0) GOTO 120
C...Connect the partons sequentially (closing for gluon loop).
KCS=(9-KQS)/2
IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
DO 110 IJN=1,NJOIN
I=IJOIN(IJN)
K(I,1)=3
IF(IJN.NE.1) IP=IJOIN(IJN-1)
IF(IJN.EQ.1) IP=IJOIN(NJOIN)
IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
IF(IJN.EQ.NJOIN) IN=IJOIN(1)
K(I,KCS)=MSTU(5)*IN
K(I,9-KCS)=MSTU(5)*IP
IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
110 CONTINUE
C...Error exit: no action taken.
RETURN
120 CALL PYERRM(12,
&'(PYJOIN:) given entries can not be joined by one string')
RETURN
END
C*********************************************************************
C...PYGIVE
C...Sets values of commonblock variables.
SUBROUTINE PYGIVE(CHIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYDAT4/CHAF(500,2)
CHARACTER CHAF*16
COMMON/PYDATR/MRPY(6),RRPY(100)
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
COMMON/PYINT4/MWID(500),WIDS(500,5)
COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
COMMON/PYINT6/PROC(0:500)
CHARACTER PROC*28
COMMON/PYINT7/SIGT(0:6,0:6,0:5)
COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
&XPDIR(-6:6)
COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
COMMON/PYPUED/IUED(0:99),RUED(0:99)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
&/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
&/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
C...Local arrays and character variables.
CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
&CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
&CHINR*16,CHDIG*10
DIMENSION MSVAR(56,8)
C...For each variable to be translated give: name,
C...integer/real/character, no. of indices, lower&upper index bounds.
DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
&'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
&'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
&'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
&'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
&'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
&'ITCM','RTCM','IUED','RUED'/
DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
&2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
&2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
&1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
&2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
&2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
&1,1,1,6,4*0, 2,1,1,100,4*0,
&1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
&1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
&1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
&1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
&2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
&1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
&2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
&2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
&2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
&2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
&1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
&'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
C...Length of character variable. Subdivide it into instructions.
IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
&CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
CHBIT=CHIN//' '
LBIT=101
100 LBIT=LBIT-1
IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
LTOT=0
DO 110 LCOM=1,LBIT
IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
LTOT=LTOT+1
CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
110 CONTINUE
LLOW=0
120 LHIG=LLOW+1
130 LHIG=LHIG+1
IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
LBIT=LHIG-LLOW-1
CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
C...Send off decay-mode on/off commands to PYONOF.
IONOF=0
DO 135 LDIG=1,10
IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
135 CONTINUE
IF(IONOF.EQ.1) THEN
CALL PYONOF(CHIN)
RETURN
ENDIF
C...Peel off any text following exclamation mark.
LHIG2=LBIT
DO 140 LLOW2=LHIG2,1,-1
IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
140 CONTINUE
IF(LBIT.EQ.0) RETURN
C...Identify commonblock variable.
LNAM=1
150 LNAM=LNAM+1
IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
&LNAM.LE.6) GOTO 150
CHNAM=CHBIT(1:LNAM-1)//' '
DO 170 LCOM=1,LNAM-1
DO 160 LALP=1,26
IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
& CHALP(2)(LALP:LALP)
160 CONTINUE
170 CONTINUE
IVAR=0
DO 180 IV=1,56
IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
180 CONTINUE
IF(IVAR.EQ.0) THEN
CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
LLOW=LHIG
IF(LLOW.LT.LTOT) GOTO 120
RETURN
ENDIF
C...Identify any indices.
I1=0
I2=0
I3=0
NINDX=0
IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
LIND=LNAM
190 LIND=LIND+1
IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
CHIND=' '
IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
& .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
& IVAR.EQ.37)) THEN
CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
READ(CHIND,'(I8)') KF
I1=PYCOMP(KF)
ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
& 'c') THEN
CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
& CHNAM)
LLOW=LHIG
IF(LLOW.LT.LTOT) GOTO 120
RETURN
ELSE
CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
READ(CHIND,'(I8)') I1
ENDIF
LNAM=LIND
IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
NINDX=1
ENDIF
IF(CHBIT(LNAM:LNAM).EQ.',') THEN
LIND=LNAM
200 LIND=LIND+1
IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
CHIND=' '
CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
READ(CHIND,'(I8)') I2
LNAM=LIND
IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
NINDX=2
ENDIF
IF(CHBIT(LNAM:LNAM).EQ.',') THEN
LIND=LNAM
210 LIND=LIND+1
IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
CHIND=' '
CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
READ(CHIND,'(I8)') I3
LNAM=LIND+1
NINDX=3
ENDIF
C...Check that indices allowed.
IERR=0
IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
&IERR=2
IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
&IERR=3
IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
&IERR=4
IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
IF(IERR.GE.1) THEN
CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
& CHBIT(1:LNAM-1))
LLOW=LHIG
IF(LLOW.LT.LTOT) GOTO 120
RETURN
ENDIF
C...Save old value of variable.
IF(IVAR.EQ.1) THEN
IOLD=N
ELSEIF(IVAR.EQ.2) THEN
IOLD=K(I1,I2)
ELSEIF(IVAR.EQ.3) THEN
ROLD=P(I1,I2)
ELSEIF(IVAR.EQ.4) THEN
ROLD=V(I1,I2)
ELSEIF(IVAR.EQ.5) THEN
IOLD=MSTU(I1)
ELSEIF(IVAR.EQ.6) THEN
ROLD=PARU(I1)
ELSEIF(IVAR.EQ.7) THEN
IOLD=MSTJ(I1)
ELSEIF(IVAR.EQ.8) THEN
ROLD=PARJ(I1)
ELSEIF(IVAR.EQ.9) THEN
IOLD=KCHG(I1,I2)
ELSEIF(IVAR.EQ.10) THEN
ROLD=PMAS(I1,I2)
ELSEIF(IVAR.EQ.11) THEN
ROLD=PARF(I1)
ELSEIF(IVAR.EQ.12) THEN
ROLD=VCKM(I1,I2)
ELSEIF(IVAR.EQ.13) THEN
IOLD=MDCY(I1,I2)
ELSEIF(IVAR.EQ.14) THEN
IOLD=MDME(I1,I2)
ELSEIF(IVAR.EQ.15) THEN
ROLD=BRAT(I1)
ELSEIF(IVAR.EQ.16) THEN
IOLD=KFDP(I1,I2)
ELSEIF(IVAR.EQ.17) THEN
CHOLD=CHAF(I1,I2)(1:8)
ELSEIF(IVAR.EQ.18) THEN
IOLD=MRPY(I1)
ELSEIF(IVAR.EQ.19) THEN
ROLD=RRPY(I1)
ELSEIF(IVAR.EQ.20) THEN
IOLD=MSEL
ELSEIF(IVAR.EQ.21) THEN
IOLD=MSUB(I1)
ELSEIF(IVAR.EQ.22) THEN
IOLD=KFIN(I1,I2)
ELSEIF(IVAR.EQ.23) THEN
ROLD=CKIN(I1)
ELSEIF(IVAR.EQ.24) THEN
IOLD=MSTP(I1)
ELSEIF(IVAR.EQ.25) THEN
ROLD=PARP(I1)
ELSEIF(IVAR.EQ.26) THEN
IOLD=MSTI(I1)
ELSEIF(IVAR.EQ.27) THEN
ROLD=PARI(I1)
ELSEIF(IVAR.EQ.28) THEN
IOLD=MINT(I1)
ELSEIF(IVAR.EQ.29) THEN
ROLD=VINT(I1)
ELSEIF(IVAR.EQ.30) THEN
IOLD=ISET(I1)
ELSEIF(IVAR.EQ.31) THEN
IOLD=KFPR(I1,I2)
ELSEIF(IVAR.EQ.32) THEN
ROLD=COEF(I1,I2)
ELSEIF(IVAR.EQ.33) THEN
IOLD=ICOL(I1,I2,I3)
ELSEIF(IVAR.EQ.34) THEN
ROLD=XSFX(I1,I2)
ELSEIF(IVAR.EQ.35) THEN
IOLD=ISIG(I1,I2)
ELSEIF(IVAR.EQ.36) THEN
ROLD=SIGH(I1)
ELSEIF(IVAR.EQ.37) THEN
IOLD=MWID(I1)
ELSEIF(IVAR.EQ.38) THEN
ROLD=WIDS(I1,I2)
ELSEIF(IVAR.EQ.39) THEN
IOLD=NGEN(I1,I2)
ELSEIF(IVAR.EQ.40) THEN
ROLD=XSEC(I1,I2)
ELSEIF(IVAR.EQ.41) THEN
CHOLD2=PROC(I1)
ELSEIF(IVAR.EQ.42) THEN
ROLD=SIGT(I1,I2,I3)
ELSEIF(IVAR.EQ.43) THEN
ROLD=XPVMD(I1)
ELSEIF(IVAR.EQ.44) THEN
ROLD=XPANL(I1)
ELSEIF(IVAR.EQ.45) THEN
ROLD=XPANH(I1)
ELSEIF(IVAR.EQ.46) THEN
ROLD=XPBEH(I1)
ELSEIF(IVAR.EQ.47) THEN
ROLD=XPDIR(I1)
ELSEIF(IVAR.EQ.48) THEN
IOLD=IMSS(I1)
ELSEIF(IVAR.EQ.49) THEN
ROLD=RMSS(I1)
ELSEIF(IVAR.EQ.50) THEN
ROLD=RVLAM(I1,I2,I3)
ELSEIF(IVAR.EQ.51) THEN
ROLD=RVLAMP(I1,I2,I3)
ELSEIF(IVAR.EQ.52) THEN
ROLD=RVLAMB(I1,I2,I3)
ELSEIF(IVAR.EQ.53) THEN
IOLD=ITCM(I1)
ELSEIF(IVAR.EQ.54) THEN
ROLD=RTCM(I1)
ELSEIF(IVAR.EQ.55) THEN
IOLD=IUED(I1)
ELSEIF(IVAR.EQ.56) THEN
ROLD=RUED(I1)
ENDIF
C...Print current value of variable. Loop back.
IF(LNAM.GE.LBIT) THEN
CHBIT(LNAM:14)=' '
CHBIT(15:60)=' has the value '
IF(MSVAR(IVAR,1).EQ.1) THEN
WRITE(CHBIT(51:60),'(I10)') IOLD
ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
WRITE(CHBIT(47:60),'(F14.5)') ROLD
ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
CHBIT(53:60)=CHOLD
ELSE
CHBIT(33:60)=CHOLD
ENDIF
IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
LLOW=LHIG
IF(LLOW.LT.LTOT) GOTO 120
RETURN
ENDIF
C...Read in new variable value.
IF(MSVAR(IVAR,1).EQ.1) THEN
CHINI=' '
CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
READ(CHINI,'(I10)') INEW
ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
CHINR=' '
CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
READ(CHINR,*) RNEW
ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
CHNEW=CHBIT(LNAM+1:LBIT)//' '
ELSE
CHNEW2=CHBIT(LNAM+1:LBIT)//' '
ENDIF
C...Store new variable value.
IF(IVAR.EQ.1) THEN
N=INEW
ELSEIF(IVAR.EQ.2) THEN
K(I1,I2)=INEW
ELSEIF(IVAR.EQ.3) THEN
P(I1,I2)=RNEW
ELSEIF(IVAR.EQ.4) THEN
V(I1,I2)=RNEW
ELSEIF(IVAR.EQ.5) THEN
MSTU(I1)=INEW
ELSEIF(IVAR.EQ.6) THEN
PARU(I1)=RNEW
ELSEIF(IVAR.EQ.7) THEN
MSTJ(I1)=INEW
ELSEIF(IVAR.EQ.8) THEN
PARJ(I1)=RNEW
ELSEIF(IVAR.EQ.9) THEN
KCHG(I1,I2)=INEW
ELSEIF(IVAR.EQ.10) THEN
PMAS(I1,I2)=RNEW
ELSEIF(IVAR.EQ.11) THEN
PARF(I1)=RNEW
ELSEIF(IVAR.EQ.12) THEN
VCKM(I1,I2)=RNEW
ELSEIF(IVAR.EQ.13) THEN
MDCY(I1,I2)=INEW
ELSEIF(IVAR.EQ.14) THEN
MDME(I1,I2)=INEW
ELSEIF(IVAR.EQ.15) THEN
BRAT(I1)=RNEW
ELSEIF(IVAR.EQ.16) THEN
KFDP(I1,I2)=INEW
ELSEIF(IVAR.EQ.17) THEN
CHAF(I1,I2)=CHNEW
ELSEIF(IVAR.EQ.18) THEN
MRPY(I1)=INEW
ELSEIF(IVAR.EQ.19) THEN
RRPY(I1)=RNEW
ELSEIF(IVAR.EQ.20) THEN
MSEL=INEW
ELSEIF(IVAR.EQ.21) THEN
MSUB(I1)=INEW
ELSEIF(IVAR.EQ.22) THEN
KFIN(I1,I2)=INEW
ELSEIF(IVAR.EQ.23) THEN
CKIN(I1)=RNEW
ELSEIF(IVAR.EQ.24) THEN
MSTP(I1)=INEW
ELSEIF(IVAR.EQ.25) THEN
PARP(I1)=RNEW
ELSEIF(IVAR.EQ.26) THEN
MSTI(I1)=INEW
ELSEIF(IVAR.EQ.27) THEN
PARI(I1)=RNEW
ELSEIF(IVAR.EQ.28) THEN
MINT(I1)=INEW
ELSEIF(IVAR.EQ.29) THEN
VINT(I1)=RNEW
ELSEIF(IVAR.EQ.30) THEN
ISET(I1)=INEW
ELSEIF(IVAR.EQ.31) THEN
KFPR(I1,I2)=INEW
ELSEIF(IVAR.EQ.32) THEN
COEF(I1,I2)=RNEW
ELSEIF(IVAR.EQ.33) THEN
ICOL(I1,I2,I3)=INEW
ELSEIF(IVAR.EQ.34) THEN
XSFX(I1,I2)=RNEW
ELSEIF(IVAR.EQ.35) THEN
ISIG(I1,I2)=INEW
ELSEIF(IVAR.EQ.36) THEN
SIGH(I1)=RNEW
ELSEIF(IVAR.EQ.37) THEN
MWID(I1)=INEW
ELSEIF(IVAR.EQ.38) THEN
WIDS(I1,I2)=RNEW
ELSEIF(IVAR.EQ.39) THEN
NGEN(I1,I2)=INEW
ELSEIF(IVAR.EQ.40) THEN
XSEC(I1,I2)=RNEW
ELSEIF(IVAR.EQ.41) THEN
PROC(I1)=CHNEW2
ELSEIF(IVAR.EQ.42) THEN
SIGT(I1,I2,I3)=RNEW
ELSEIF(IVAR.EQ.43) THEN
XPVMD(I1)=RNEW
ELSEIF(IVAR.EQ.44) THEN
XPANL(I1)=RNEW
ELSEIF(IVAR.EQ.45) THEN
XPANH(I1)=RNEW
ELSEIF(IVAR.EQ.46) THEN
XPBEH(I1)=RNEW
ELSEIF(IVAR.EQ.47) THEN
XPDIR(I1)=RNEW
ELSEIF(IVAR.EQ.48) THEN
IMSS(I1)=INEW
ELSEIF(IVAR.EQ.49) THEN
RMSS(I1)=RNEW
ELSEIF(IVAR.EQ.50) THEN
RVLAM(I1,I2,I3)=RNEW
ELSEIF(IVAR.EQ.51) THEN
RVLAMP(I1,I2,I3)=RNEW
ELSEIF(IVAR.EQ.52) THEN
RVLAMB(I1,I2,I3)=RNEW
ELSEIF(IVAR.EQ.53) THEN
ITCM(I1)=INEW
ELSEIF(IVAR.EQ.54) THEN
RTCM(I1)=RNEW
ELSEIF(IVAR.EQ.55) THEN
IUED(I1)=INEW
ELSEIF(IVAR.EQ.56) THEN
RUED(I1)=RNEW
ENDIF
C...Write old and new value. Loop back.
CHBIT(LNAM:14)=' '
CHBIT(15:60)=' changed from to '
IF(MSVAR(IVAR,1).EQ.1) THEN
WRITE(CHBIT(33:42),'(I10)') IOLD
WRITE(CHBIT(51:60),'(I10)') INEW
IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
WRITE(CHBIT(29:42),'(F14.5)') ROLD
WRITE(CHBIT(47:60),'(F14.5)') RNEW
IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
CHBIT(35:42)=CHOLD
CHBIT(53:60)=CHNEW
IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
ELSE
CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
ENDIF
LLOW=LHIG
IF(LLOW.LT.LTOT) GOTO 120
C...Format statement for output on unit MSTU(11) (by default 6).
5000 FORMAT(5X,A60)
5100 FORMAT(5X,A88)
RETURN
END
C*********************************************************************
C...PYONOF
C...Switches on and off decay channel by search for match.
SUBROUTINE PYONOF(CHIN)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
SAVE /PYDAT1/,/PYDAT3/
C...Local arrays and character variables.
INTEGER KFCMP(10),KFTMP(10)
CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
&CHALP(2)*26
DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
&'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
C...Determine length of character variable.
CHTMP=CHIN//' '
LBEG=0
100 LBEG=LBEG+1
IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
LEND=LBEG-1
105 LEND=LEND+1
IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
110 LEND=LEND-1
IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
LEN=1+LEND-LBEG
CHFIX(1:LEN)=CHTMP(LBEG:LEND)
C...Find colon separator and particle code.
LCOLON=0
120 LCOLON=LCOLON+1
IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
CHCODE=' '
CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
READ(CHCODE,'(I8)',ERR=300) KF
KC=PYCOMP(KF)
C...Done if unknown code or no decay channels.
IF(KC.EQ.0) THEN
CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
RETURN
ENDIF
IDCBEG=MDCY(KC,2)
IDCLEN=MDCY(KC,3)
IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
RETURN
ENDIF
C...Find command name up to blank or equal sign.
LSEP=LCOLON
130 LSEP=LSEP+1
IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
&CHFIX(LSEP:LSEP).NE.'=') GOTO 130
CHMODE=' '
LMODE=LSEP-LCOLON-1
CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
C...Convert to uppercase.
DO 150 LCOM=1,LMODE
DO 140 LALP=1,26
IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
& CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
140 CONTINUE
150 CONTINUE
C...Identify command. Failed if not identified.
MODE=0
IF(CHMODE.EQ.'ALLOFF') MODE=1
IF(CHMODE.EQ.'ALLON') MODE=2
IF(CHMODE.EQ.'OFFIFANY') MODE=3
IF(CHMODE.EQ.'ONIFANY') MODE=4
IF(CHMODE.EQ.'OFFIFALL') MODE=5
IF(CHMODE.EQ.'ONIFALL') MODE=6
IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
IF(CHMODE.EQ.'ONIFMATCH') MODE=8
IF(MODE.EQ.0) THEN
CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
RETURN
ENDIF
C...Simple cases when all on or all off.
IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
WRITE(MSTU(11),1000) KF,CHMODE
DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
IF(MDME(IDC,1).LT.0) GOTO 160
MDME(IDC,1)=MODE-1
160 CONTINUE
RETURN
ENDIF
C...Identify matching list.
NCMP=0
LBEG=LSEP
170 LBEG=LBEG+1
IF(LBEG.GT.LEN) GOTO 190
IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
&CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
LEND=LBEG-1
180 LEND=LEND+1
IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
&CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
IF(LEND.LT.LEN) LEND=LEND-1
CHCODE=' '
CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
READ(CHCODE,'(I8)',ERR=300) KFREAD
NCMP=NCMP+1
KFCMP(NCMP)=IABS(KFREAD)
LBEG=LEND
IF(NCMP.LT.10) GOTO 170
190 CONTINUE
WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
C...Only one matching required.
IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
IF(MDME(IDC,1).LT.0) GOTO 220
DO 210 IKF=1,5
KFNOW=IABS(KFDP(IDC,IKF))
IF(KFNOW.EQ.0) GOTO 210
DO 200 ICMP=1,NCMP
IF(KFCMP(ICMP).EQ.KFNOW) THEN
MDME(IDC,1)=MODE-3
GOTO 220
ENDIF
200 CONTINUE
210 CONTINUE
220 CONTINUE
RETURN
ENDIF
C...Multiple matchings required.
DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
IF(MDME(IDC,1).LT.0) GOTO 260
NTMP=NCMP
DO 230 ITMP=1,NTMP
KFTMP(ITMP)=KFCMP(ITMP)
230 CONTINUE
NFIN=0
DO 250 IKF=1,5
KFNOW=IABS(KFDP(IDC,IKF))
IF(KFNOW.EQ.0) GOTO 250
NFIN=NFIN+1
DO 240 ITMP=1,NTMP
IF(KFTMP(ITMP).EQ.KFNOW) THEN
KFTMP(ITMP)=KFTMP(NTMP)
NTMP=NTMP-1
GOTO 250
ENDIF
240 CONTINUE
250 CONTINUE
IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
& MDME(IDC,1)=MODE-7
260 CONTINUE
RETURN
C...Error exit for impossible read of particle code.
300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
&//CHCODE)
C...Formats for output.
1000 FORMAT(' Decays for',I8,' set ',A10)
1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
RETURN
END
C*********************************************************************
C...PYTUNE
C...Presets for a few specific underlying-event and min-bias tunes
C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
C...others require particular versions of pythia (e.g. the SCI and GAL
C...models). See below for details.
SUBROUTINE PYTUNE(ITUNE)
C
C ITUNE NAME (detailed descriptions below)
C 0 Default : No settings changed => defaults.
C
C ====== Old UE, Q2-ordered showers ====================================
C 100 A : Rick Field's CDF Tune A (Oct 2002)
C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
C 107 ACR : Tune A modified with new CR model (Mar 2007)
C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
C 111 AW-Pro : Tune AW, -"- (Oct 2008)
C 112 BW-Pro : Tune BW, -"- (Oct 2008)
C 113 DW-Pro : Tune DW, -"- (Oct 2008)
C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
C 115 QW-Pro : Tune QW, -"- (Oct 2008)
C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
C 118 D6-Pro : Tune D6, -"- (Oct 2008)
C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009)
C
C ====== Intermediate and Hybrid Models ================================
C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
C
C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
C 311 S1-Pro : S1 -"- (Oct 2008)
C 312 S2-Pro : S2 -"- (Oct 2008)
C 313 S0A-Pro : S0A -"- (Oct 2008)
C 314 NOCR-Pro : NOCR -"- (Oct 2008)
C 315 Old-Pro : Old -"- (Oct 2008)
C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008)
C ---- Peter's Perugia Tunes : 320+ ------------------------------------
C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
C balance & different scaling to LHC & RHIC (Feb 2009)
C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010)
C off ISR, more BR breakup, more strangeness
C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010)
C K-factor applied to MPI cross sections
C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009)
C ---- Tunes introduced in 6.4.23:
C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009)
C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010)
C 335 Pro-pT* : Professor Tune with LO* (Mar 2009)
C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009)
C 339 Pro-pT** : Professor Tune with LO** (Mar 2009)
C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010)
C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010)
C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010)
C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010)
C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011)
C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
C 351 P2011 radHi : Variation with alphaS(pT/2)
C 352 P2011 radLo : Variation with alphaS(2pT)
C 353 P2011 mpiHi : Variation with more semi-hard MPI
C 354 P2011 noCR : Variation without color reconnections
C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011)
C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011)
C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV
C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV
C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011)
C 360 S Global : Schulz-Skands Global fit (Mar 2011)
C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011)
C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011)
C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011)
C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011)
C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011)
C
C ======= The Uppsala models ===========================================
C ( NB! must be run with special modified Pythia 6.215 version )
C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
C
C More details;
C
C Quick Dictionary:
C BE : Bose-Einstein
C BR : Beam Remnants
C CR : Colour Reconnections
C HAD: Hadronization
C ISR/FSR: Initial-State Radiation / Final-State Radiation
C FSI: Final-State Interactions (=CR+BE)
C MB : Minimum-bias
C MI : Multiple Interactions
C UE : Underlying Event
C
C=======================================================================
C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
C=======================================================================
C
C A (100) and AW (101). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...* Large starting scale for ISR (PARP(67)=4)
C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C BW (102). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...NB: Can also be run with Pythia 6.2 or 6.312+
C...* Small starting scale for ISR (PARP(67)=1)
C...* BW has more radiation due to smaller mu_R choice in alpha_s.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C DW (103) and DWT (104). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...NB: Can also be run with Pythia 6.2 or 6.312+
C...* Intermediate starting scale for ISR (PARP(67)=2.5)
C...* DWT has a different reference energy, the same as the "S" models
C... below, leading to more UE activity at the LHC, but less at RHIC.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C QW (105). CTEQ61 parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: uses CTEQ61 (external pdf library must be linked)
C
C ATLAS-DC2 (106). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: tune used by the ATLAS collaboration.
C
C ACR (107). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
C...Key feature: Tune A modified to use annealing CR.
C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
C
C D6 (108) and D6T (109). CTEQ6L parton distributions
C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
C
C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
C Old UE model, Q2-ordered showers.
C...Key feature: Rick Field's family of tunes revamped with the
C...Professor Q2-ordered final-state shower and fragmentation tunes
C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
C...Key feature: improved descriptions of LEP data.
C
C Pro-Q2O (129). CTEQ5L parton distributions
C Old UE model, Q2-ordered showers.
C...Key feature: Complete retune of old model by Professor, including
C...large amounts of both LEP and Tevatron data.
C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
C...extreme in this tune, corresponding to using mu_R = pT/3 .
C
C=======================================================================
C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
C=======================================================================
C
C IM1 (200). Intermediate model, Q2-ordered showers,
C CTEQ5L parton distributions
C...Key feature: new UE model w Q2-ordered showers and no interleaving.
C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
C
C APT (201). Old UE model, pT-ordered final-state showers,
C CTEQ5L parton distributions
C...Key feature: Rick Field's Tune A, but with new final-state showers
C
C APT-Pro (211). Old UE model, pT-ordered final-state showers,
C CTEQ5L parton distributions
C...Key feature: APT revamped with the Professor pT-ordered final-state
C...shower and fragmentation tunes presented by Hendrik Hoeth at the
C...Perugia MPI workshop in October 2008.
C
C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
C CTEQ5L parton distributions
C...Key feature: APT-Pro with final-state showers off the MPI,
C...lower ISR renormalization scale to improve agreement with the
C...Tevatron Drell-Yan pT measurements and with improved energy scaling
C...to min-bias at 630 GeV.
C
C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
C CTEQ6L1 parton distributions.
C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
C
C=======================================================================
C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
C=======================================================================
C
C S0 (300) and S0A (303). CTEQ5L parton distributions
C...Key feature: large amount of multiple interactions
C...* Somewhat faster than the other colour annealing scenarios.
C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
C... from Tune A, leading to less UE at the LHC, but more at RHIC.
C...* Small amount of radiation.
C...* Large amount of low-pT MI
C...* Low degree of proton lumpiness (broad matter dist.)
C...* CR Type S (driven by free triplets), of medium strength.
C...* See: Pythia6402 update notes or later.
C
C S1 (301). CTEQ5L parton distributions
C...Key feature: large amount of radiation.
C...* Large amount of low-pT perturbative ISR
C...* Large amount of FSR off ISR partons
C...* Small amount of low-pT multiple interactions
C...* Moderate degree of proton lumpiness
C...* Least aggressive CR type (S+S Type I), but with large strength
C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
C
C S2 (302). CTEQ5L parton distributions
C...Key feature: very lumpy proton + gg string cluster formation allowed
C...* Small amount of radiation
C...* Moderate amount of low-pT MI
C...* High degree of proton lumpiness (more spiky matter distribution)
C...* Most aggressive CR type (S+S Type II), but with small strength
C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
C
C NOCR (304). CTEQ5L parton distributions
C...Key feature: no colour reconnections (NB: "Best fit" only).
C...* NB: <pT>(Nch) problematic in this tune.
C...* Small amount of radiation
C...* Small amount of low-pT MI
C...* Low degree of proton lumpiness
C...* Large BR composite x enhancement factor
C...* Most clever colour flow without CR ("Lambda ordering")
C
C ATLAS-CSC (306). CTEQ6L parton distributions
C...Key feature: 11-parameter ATLAS tune of the new framework.
C...* Old (pre-annealing) colour reconnections a la 305.
C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
C
C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
C...Key feature: the S0 family of tunes revamped with the Professor
C...pT-ordered final-state shower and fragmentation tunes presented by
C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
C...Key feature: improved descriptions of LEP data.
C
C ATLAS MC08 (316). CTEQ6L1 parton distributions
C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
C...* Warning: uses Peterson fragmentation function for heavy quarks
C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
C
C Perugia-0 (320). CTEQ5L parton distributions.
C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
C...beam-remnant breakup (more baryon number transport), and suppression
C...of CR in high-pT string pieces.
C
C Perugia-HARD (321). CTEQ5L parton distributions.
C...Key feature: More ISR, More FSR, Less MPI, Less BR
C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
C...baryon number transport), and more fragmentation pT.
C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
C...DY pT spectrum is HARD.
C
C Perugia-SOFT (322). CTEQ5L parton distributions.
C...Key feature: Less ISR, Less FSR, More MPI, More BR
C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
C...number transport), and less fragmentation pT.
C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
C...DY pT spectrum is SOFT
C
C Perugia-3 (323). CTEQ5L parton distributions.
C...Key feature: variant of Perugia-0 with more extreme energy scaling
C...properties while still agreeing with Tevatron data from 630 to 1960.
C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
C...allows FSR off the active end of dipoles stretched to the remnant.
C
C Perugia-NOCR (324). CTEQ5L parton distributions.
C...Key feature: Retune of NOCR-Pro with better scaling properties to
C...lower energies and somewhat better agreement with Tevatron data
C...at 1800/1960.
C
C Perugia-* (325). MRST LO* parton distributions for generators
C...Key feature: first attempt at using the LO* distributions
C...(external pdf library must be linked).
C
C Perugia-6 (326). CTEQ6L1 parton distributions
C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
C
C Perugia-2010 (327). CTEQ5L parton distributions
C...Key feature: Retune of Perugia 0 to attempt to better describe
C...strangeness yields at RHIC and at LEP. Also increased the amount
C...of FSR off ISR following the conclusions in arXiv:1001.4082.
C...Increased the amount of beam blowup, causing more baryon transport
C...into the detector, to further explore this possibility. Using
C...a new color-reconnection model that relies on determining a thrust
C...axis for the events and then computing reconnection probabilities for
C...the individual string pieces based on the actual string densities
C...per rapidity interval along that thrust direction.
C
C Perugia-K (328). CTEQ5L parton distributions
C...Key feature: uses a ``K'' factor on the MPI cross sections
C...This gives a larger rate of minijets and pushes the underlying-event
C...activity towards higher pT. To compensate for the increased activity
C...at higher pT, the infared regularization scale is larger for this tune.
C
C Pro-pTO (329). CTEQ5L parton distributions
C...Key feature: Complete retune of new model by Professor, including
C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
C
C ATLAS MC09 (330). LO* parton distributions
C...Key feature: Good overall agreement with Tevatron and early LHC data.
C...Similar to Perugia *.
C
C ATLAS MC09c (331). LO* parton distributions
C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
C...Similar to Perugia *. Retuned CR model with respect to MC09.
C
C Pro-pT* (335) LO* parton distributions
C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
C
C Pro-pT6 (336). CTEQ6L1 parton distributions
C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
C
C Pro-pT** (339). LO** parton distributions
C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
C
C AMBT1 (340). LO* parton distributions
C...Key feature: First ATLAS tune including 7-TeV LHC data.
C...Mainly retuned CR and mass distribution with respect to MC09c.
C...Note: cannot be run standalone since it uses external PDFs.
C
C CMSZ1 (341). CTEQ5L parton distributions
C...Key feature: First CMS tune including 7-TeV LHC data.
C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs,
C...has a lower pT0 at the Tevatron, which scales faster with energy.
C
C Z1-LEP (342). CTEQ5L parton distributions
C...Key feature: CMS tune Z1 with improved LEP parameters, mostly
C...taken from the Professor/Perugia tunes, with a few minor updates.
C
C=======================================================================
C OTHER TUNES
C=======================================================================
C
C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
C...with an unmodified Pythia distribution.
C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
C
C ::: + Future improvements?
C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
C (problem: K-factor affects everything so only works as
C intended for min-bias, not for UE ... probably need a
C better long-term solution to handle UE as well. Anyway,
C Mark uses MSTP(33) and PARP(31)-PARP(33).)
C...Global statements
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
C...SCI and GAL Commonblocks
COMMON /SCIPAR/MSWI(2),PARSCI(2)
C...SAVE statements
SAVE /PYDAT1/,/PYPARS/
SAVE /SCIPAR/
C...Internal parameters
PARAMETER(MXTUNS=500)
CHARACTER*8 CHDOC
PARAMETER (CHDOC='Mar 2011')
CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
& CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40
CHARACTER*60 CH60
CHARACTER*70 CH70
DATA (CHNAMS(I),I=0,1)/'Default',' '/
DATA (CHNAMS(I),I=100,119)/
& 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
& 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
1 'Tune D6-Pro','Tune D6T-Pro'/
DATA (CHNAMS(I),I=120,129)/
& 9*' ','Pro-Q2O'/
DATA (CHNAMS(I),I=300,309)/
& 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
DATA (CHNAMS(I),I=310,316)/
& 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
& 'NOCR-Pro','Old-Pro','ATLAS MC08'/
DATA (CHNAMS(I),I=320,329)/
& 'Perugia 0','Perugia HARD','Perugia SOFT',
& 'Perugia 3','Perugia NOCR','Perugia LO*',
& 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
DATA (CHNAMS(I),I=330,349)/
& 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
& 'Pro-PT6',' ',' ','Pro-PT**',
4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
4 5*' '/
DATA (CHNAMS(I),I=350,359)/
& 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
& 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
& 'P2011 T16','P2011 T32','P2011 Tevatron'/
DATA (CHNAMS(I),I=360,369)/
& 'S Global','S 7000','S 1960','S 1800',
& 'S 900','S 630', 4*' '/
DATA (CHNAMS(I),I=200,229)/
& 'IM Tune 1','Tune APT',8*' ',
& ' ','Tune APT-Pro',8*' ',
& ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
DATA (CHNAMS(I),I=400,409)/
& 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
DATA (CHMSTJ(I),I=11,20)/
& 'HAD choice of fragmentation function(s)',4*' ',
& 'HAD treatment of small-mass systems',4*' '/
DATA (CHMSTJ(I),I=41,50)/
& 'FSR type (Q2 or pT) for old framework',9*' '/
DATA (CHMSTP(I),I=1,10)/
& 2*' ','INT switch for choice of LambdaQCD',7*' '/
DATA (CHMSTP(I),I=31,40)/
& 2*' ','"K" switch for K-factor on/off & type',7*' '/
DATA (CHMSTP(I),I=51,100)/
5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
6 'ISR coherence option for 1st emission',
6 'ISR phase space choice & ME corrections',' ',
7 'ISR IR regularization scheme',' ',
7 'IFSR scheme for non-decay FSR',8*' ',
8 'UE model',
8 'UE hadron transverse mass distribution',5*' ',
8 'BR composite scheme','BR color scheme',
9 'BR primordial kT compensation',
9 'BR primordial kT distribution',
9 'BR energy partitioning scheme',2*' ',
9 'FSI color (re-)connection model',5*' '/
DATA (CHPARP(I),I=1,10)/
& 'ME/UE LambdaQCD',9*' '/
DATA (CHPARP(I),I=31,40)/
& ' ','"K" K-factor',8*' '/
DATA (CHPARP(I),I=61,100)/
6 'ISR LambdaQCD','ISR IR cutoff',' ',
6 'ISR renormalization scale prefactor',
6 2*' ','ISR Q2max factor',3*' ',
7 'IFSR Q2max factor in non-s-channel procs',
7 'IFSR LambdaQCD (outside resonance decays)',4*' ',
7 'FSI color reco high-pT damping strength',
7 'FSI color reconnection strength',
7 'BR composite x enhancement','BR breakup suppression',
8 2*'UE IR cutoff at reference ecm',
8 2*'UE mass distribution parameter',
8 'UE gg color correlated fraction','UE total gg fraction',
8 2*' ',
8 'UE IR cutoff reference ecm',
8 'UE IR cutoff ecm scaling power',
9 'BR primordial kT width <|kT|>',' ',
9 'BR primordial kT UV cutoff',7*' '/
DATA (CHPARJ(I),I=1,30)/
& 'HAD diquark suppression','HAD strangeness suppression',
& 'HAD strange diquark suppression',
& 'HAD vector diquark suppression','HAD P(popcorn)',
& 'HAD extra popcorn B(s)-M-B(s) supp',
& 'HAD extra popcorn B-M(s)-B supp',
& 3*' ',
1 'HAD P(vector meson), u and d only',
1 'HAD P(vector meson), contains s',
1 'HAD P(vector meson), heavy quarks',7*' ',
2 'HAD fragmentation pT',' ',' ',' ',
2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
DATA (CHPARJ(I),I=41,90)/
4 'HAD string parameter a(Meson)','HAD string parameter b',
4 2*' ','HAD string a(Baryon)-a(Meson)',
4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
6 10*' ',10*' ',
8 'FSR LambdaQCD (inside resonance decays)',
& 'FSR IR cutoff',8*' '/
DATA (CHMSTU(I),I=111,120)/
1 ' ','INT n(flavors) for LambdaQCD',8*' '/
DATA (CHPARU(I),I=111,120)/
1 ' ','INT LambdaQCD',8*' '/
C...1) Shorthand notation
M13=MSTU(13)
M11=MSTU(11)
IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
CHNAME=CHNAMS(ITUNE)
IF (ITUNE.EQ.0) GOTO 9999
ELSE
CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
GOTO 9999
ENDIF
C...2) Hello World
IF (M13.GE.1) WRITE(M11,5000) CHDOC
C...Hardcode some defaults
C...Get Lambda from PDF
MSTP(3) = 2
C...CTEQ5L1 PDFs
MSTP(52) = 1
MSTP(51) = 7
C... No K-factor
MSTP(33) = 0
C...3) Tune parameters
C=======================================================================
C...ATLAS MC08
IF (ITUNE.EQ.316) THEN
IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...First set some explicit defaults from 6.4.20
C...# Old defaults
MSTJ(11) = 4
C...# Old default flavour parameters
PARJ(1) = 0.1
PARJ(2) = 0.3
PARJ(3) = 0.40
PARJ(4) = 0.05
PARJ(11) = 0.5
PARJ(12) = 0.6
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(82) = 1.0
C...PDFs: CTEQ6L1 for 326
MSTP(52)=2
MSTP(51)=10042
C...UE and ISR switches
MSTP(81)=21
MSTP(82)=4
MSTP(70)=0
MSTP(72)=1
C...CR:
MSTP(95)=2
PARP(78)=0.3
PARP(77)=0.0
PARP(80)=0.1
C...Primordial kT
PARP(91)=2.0D0
PARP(93)=5.0D0
C...MPI:
PARP(82)=2.1
PARP(83)=0.8
PARP(84)=0.7
PARP(89)=1800.0
PARP(90)=0.16
C...FSR inside resonance decays
PARJ(81)=0.29
C...Fragmentation (warning: uses Peterson)
MSTJ(11)=3
PARJ(54)=-0.07
PARJ(55)=-0.006
MSTJ(22)=2
IF (M13.GE.1) THEN
CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
WRITE(M11,5030) CH60
CH60='Physics model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
C...Output
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
IF (MSTP(70).EQ.0) THEN
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
ENDIF
WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
WRITE(M11,5050) 79, PARP(79), CHPARP(79)
WRITE(M11,5050) 80, PARP(80), CHPARP(80)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
IF (MSTP(95).GE.1) THEN
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
ENDIF
ENDIF
C=======================================================================
C...ATLAS MC09, MC09c, AMBT1
C...CMS Z1 (R. Field), Z1-LEP
ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
& ITUNE.GE.341.AND.ITUNE.LE.344) THEN
IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...First set some explicit defaults from 6.4.20
IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
C... # Old defaults
MSTJ(11) = 4
C...# Old default flavour parameters
PARJ(1) = 0.1
PARJ(2) = 0.3
PARJ(3) = 0.40
PARJ(4) = 0.05
PARJ(11) = 0.5
PARJ(12) = 0.6
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(82) = 1.0
ELSE
C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
PARJ( 1) = 0.08D0
PARJ( 2) = 0.21D0
PARJ(3) = 0.94
PARJ( 4) = 0.04D0
PARJ(11) = 0.35D0
PARJ(12) = 0.35D0
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C...# Switch on Bowler:
MSTJ(11) = 5
C...# Fragmentation
PARJ(21) = 0.34D0
PARJ(41) = 0.35D0
PARJ(42) = 0.80D0
PARJ(47) = 1.0
PARJ(81) = 0.26D0
PARJ(82) = 1.0D0
ENDIF
C...PDFs: MRST LO*
MSTP(52)=2
MSTP(51)=20650
IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
C...Z1 uses CTEQ5L
MSTP(52)=1
MSTP(51)=7
ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
C...Z2 uses CTEQ6L
MSTP(52)=2
MSTP(51)=10042
ENDIF
C...UE and ISR switches
MSTP(81)=21
MSTP(82)=4
MSTP(70)=0
MSTP(72)=1
C...CR:
MSTP(95)=6
PARP(78)=0.3
PARP(77)=0.0
PARP(80)=0.1
IF (ITUNE.EQ.331) THEN
PARP(78)=0.224
ELSEIF (ITUNE.EQ.340) THEN
C...AMBT1
PARP(77)=1.016D0
PARP(78)=0.538D0
ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
C...Z1 and Z2 use the AMBT1 CR values
PARP(77)=1.016D0
PARP(78)=0.538D0
ENDIF
C...MPI:
PARP(82)=2.3
PARP(83)=0.8
PARP(84)=0.7
PARP(89)=1800.0
PARP(90)=0.25
IF (ITUNE.EQ.331) THEN
PARP(82)=2.315
PARP(90)=0.2487
ELSEIF (ITUNE.EQ.340) THEN
PARP(82)=2.292D0
PARP(83)=0.356D0
PARP(84)=0.651
PARP(90)=0.25D0
ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
PARP(82)=1.932D0
PARP(83)=0.356D0
PARP(84)=0.651
PARP(90)=0.275D0
ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
PARP(82)=1.832D0
PARP(83)=0.356D0
PARP(84)=0.651
PARP(90)=0.275D0
ENDIF
C...Primordial kT
PARP(91)=2.0D0
PARP(93)=5D0
IF (ITUNE.GE.340) THEN
PARP(93)=10D0
ENDIF
C...ISR
IF (ITUNE.GE.340) THEN
PARP(62)=1.025
ENDIF
C...FSR inside resonance decays
PARJ(81)=0.29
C...Fragmentation (org 6.4 defs hardcoded)
MSTJ(11)=4
PARJ(41)=0.3
PARJ(42)=0.58
MSTJ(22)=2
C...AMBT1 mentions 46 explicitly, but Z1 doesn't ...
PARJ(46)=0.75
IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
C...Reset PARJ(46) to org def value for Z1 and Z2
PARJ(46)=1.0
ENDIF
IF (M13.GE.1) THEN
IF (ITUNE.LT.340) THEN
CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
ELSEIF (ITUNE.EQ.340) THEN
CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
ELSEIF (ITUNE.EQ.341) THEN
CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
WRITE(M11,5030) CH60
CH60='Z1 variation tuned by R. D. Field (CMS)'
ELSEIF (ITUNE.EQ.342) THEN
CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
WRITE(M11,5030) CH60
CH60='Z1 variation retuned by R. D. Field (CMS)'
WRITE(M11,5030) CH60
CH60='Z1-LEP variation retuned by Professor / P. Skands'
ELSEIF (ITUNE.EQ.343) THEN
CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
WRITE(M11,5030) CH60
CH60='Z2 variation retuned by R. D. Field (CMS)'
ELSEIF (ITUNE.EQ.344) THEN
CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
WRITE(M11,5030) CH60
CH60='Z2 variation retuned by R. D. Field (CMS)'
WRITE(M11,5030) CH60
CH60='Z2-LEP variation retuned by Professor / P. Skands'
ENDIF
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
C...Output
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
IF (MSTP(70).EQ.0) THEN
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
ENDIF
WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
WRITE(M11,5050) 79, PARP(79), CHPARP(79)
WRITE(M11,5050) 80, PARP(80), CHPARP(80)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
IF (MSTP(95).GE.1) THEN
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
ENDIF
ENDIF
C=======================================================================
C...S0, S1, S2, S0A, NOCR, Rap,
C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
C...Perugia 2011 (incl variations)
C...Schulz-Skands tunes
ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
& .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
& .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
& .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
& .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN
IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND.
& ITUNE.NE.334.AND.
& (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
& THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
& (MSTP(181).LE.5.OR.
& (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
& THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...Use 327 as base tune for 350-359 (Perugia 2011)
ITUNSV = ITUNE
IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
C...Use 320 as base tune for 360+ (Schulz-Skands)
IF (ITUNE.GE.360) ITUNE = 320
C...HAD: Use Professor's LEP pars if ITUNE >= 310
C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
IF (ITUNE.LT.310) THEN
C...# Old defaults
MSTJ(11) = 4
C...# Old default flavour parameters
PARJ(1) = 0.1
PARJ(2) = 0.3
PARJ(3) = 0.40
PARJ(4) = 0.05
PARJ(11) = 0.5
PARJ(12) = 0.6
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(82) = 1.0
ELSEIF (ITUNE.GE.310) THEN
C...# Tuned flavour parameters:
PARJ(1) = 0.073
PARJ(2) = 0.2
PARJ(3) = 0.94
PARJ(4) = 0.032
PARJ(11) = 0.31
PARJ(12) = 0.4
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C...# Always use pT-ordered shower:
MSTJ(41) = 12
C...# Switch on Bowler:
MSTJ(11) = 5
C...# Fragmentation
PARJ(21) = 0.313
PARJ(41) = 0.49
PARJ(42) = 1.2
PARJ(47) = 1.0
PARJ(81) = 0.257
PARJ(82) = 0.8
C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
IF (ITUNE.EQ.321) PARJ(21)=0.34D0
IF (ITUNE.EQ.322) PARJ(21)=0.28D0
C...HAD: P-2010 and P-K use different strangeness parameters
C... indicated by LEP and RHIC yields.
C...(only 5% different from Professor values, so should be within acceptable
C...theoretical uncertainty range)
C...(No attempt made to retune other flavor parameters post facto)
IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
PARJ( 1) = 0.08D0
PARJ( 2) = 0.21D0
PARJ( 4) = 0.04D0
PARJ(11) = 0.35D0
PARJ(12) = 0.35D0
PARJ(21) = 0.36D0
PARJ(41) = 0.35D0
PARJ(42) = 0.90D0
PARJ(81) = 0.26D0
PARJ(82) = 1.0D0
ENDIF
ENDIF
C...Remove middle digit now for Professor variants, since identical pars
ITUNEB=ITUNE
IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
ENDIF
C...PDFs: all use CTEQ5L as starting point
MSTP(52)=1
MSTP(51)=7
IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN
C...MRST LO* for 325 and 335
MSTP(52)=2
MSTP(51)=20650
ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
C...CTEQ6L1 for 326 and 336
MSTP(52)=2
MSTP(51)=10042
ELSEIF (ITUNE.EQ.339) THEN
C...MRST LO** for 339
MSTP(52)=2
MSTP(51)=20651
ENDIF
C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
MSTP(3)=2
IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
MSTP(3) = 1
C...Hardcode CTEQ5L values for ME and ISR
MSTU(112) = 4
PARU(112) = 0.192D0
PARP(61) = 0.192D0
PARP( 1) = 0.192D0
C...but use LEP value also for non-res FSR
PARP(72) = 0.260D0
ENDIF
C...ISR: use Lambda_MSbar with default scale for S0(A)
MSTP(64)=2
PARP(64)=1D0
IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334
& .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN
C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
MSTP(64)=3
PARP(64)=1D0
ELSEIF (ITUNE.EQ.321) THEN
C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
MSTP(64)=3
PARP(64)=0.25D0
ELSEIF (ITUNE.EQ.322) THEN
C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
MSTP(64)=2
PARP(64)=2D0
ELSEIF (ITUNE.EQ.325) THEN
C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
MSTP(64)=3
PARP(64)=2D0
ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
& ITUNE.EQ.339) THEN
C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
MSTP(64)=2
PARP(64)=1.3D0
IF (ITUNE.EQ.335) PARP(64)=0.92D0
IF (ITUNE.EQ.336) PARP(64)=0.89D0
IF (ITUNE.EQ.339) PARP(64)=0.97D0
ENDIF
C...ISR : power-suppressed power showers above s_color (since 6.4.19)
MSTP(67)=2
PARP(67)=4D0
C...Perugia tunes have stronger suppression, except HARD
IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
PARP(67)=1D0
IF (ITUNE.EQ.321) PARP(67)=4D0
IF (ITUNE.EQ.322) PARP(67)=0.25D0
ENDIF
C...ISR IR cutoff type and FSR off ISR setting:
C...Smooth ISR, low FSR-off-ISR
MSTP(70)=2
MSTP(72)=0
IF (ITUNEB.EQ.301) THEN
C...S1, S1-Pro: sharp ISR, high FSR
MSTP(70)=0
MSTP(72)=1
ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
& .OR.ITUNE.EQ.325) THEN
C...Perugia default is smooth ISR, high FSR-off-ISR
MSTP(70)=2
MSTP(72)=1
ELSEIF (ITUNE.EQ.321) THEN
C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
MSTP(70)=0
PARP(62)=1.25D0
MSTP(72)=1
ELSEIF (ITUNE.EQ.322) THEN
C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
MSTP(70)=1
PARP(81)=1.5D0
MSTP(72)=0
ELSEIF (ITUNE.EQ.323) THEN
C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
MSTP(70)=0
PARP(62)=1.25D0
MSTP(72)=2
ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
MSTP(70)=2
MSTP(72)=2
ENDIF
C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
C...by Professor tunes (with HARD and SOFT variations)
PARP(71)=4D0
IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
PARP(71)=2D0
IF (ITUNE.EQ.321) PARP(71)=4D0
IF (ITUNE.EQ.322) PARP(71)=1D0
ENDIF
IF (ITUNE.EQ.329) PARP(71)=2D0
IF (ITUNE.EQ.335) PARP(71)=1.29D0
IF (ITUNE.EQ.336) PARP(71)=1.72D0
IF (ITUNE.EQ.339) PARP(71)=1.20D0
C...FSR: Lambda_FSR scale (only if not using professor)
IF (ITUNE.LT.310) PARJ(81)=0.23D0
IF (ITUNE.EQ.321) PARJ(81)=0.30D0
IF (ITUNE.EQ.322) PARJ(81)=0.20D0
C...K-factor : only 328 uses a K-factor on the UE cross sections
MSTP(33)=0
IF (ITUNE.EQ.328) THEN
MSTP(33)=10
PARP(32)=1.5
ENDIF
C...UE on, new model
MSTP(81)=21
C...UE: hadron-hadron overlap profile (expOfPow for all)
MSTP(82)=5
C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
PARP(83)=1.6D0
IF (ITUNEB.EQ.301) PARP(83)=1.4D0
IF (ITUNEB.EQ.302) PARP(83)=1.2D0
C...NOCR variants have very smooth distributions
IF (ITUNEB.EQ.304) PARP(83)=1.8D0
IF (ITUNEB.EQ.305) PARP(83)=2.0D0
IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
C...Perugia variants have slightly smoother profiles by default
C...(to compensate for more tail by added radiation)
C...Perugia-SOFT has more peaked distribution, NOCR less peaked
PARP(83)=1.7D0
IF (ITUNE.EQ.322) PARP(83)=1.5D0
IF (ITUNE.EQ.327) PARP(83)=1.5D0
IF (ITUNE.EQ.328) PARP(83)=1.5D0
C...NOCR variants have smoother mass profiles
IF (ITUNE.EQ.324) PARP(83)=1.8D0
IF (ITUNE.EQ.334) PARP(83)=1.8D0
ENDIF
C...Professor-pT0 also has very smooth distribution
IF (ITUNE.EQ.329) PARP(83)=1.8
IF (ITUNE.EQ.335) PARP(83)=1.68
IF (ITUNE.EQ.336) PARP(83)=1.72
IF (ITUNE.EQ.339) PARP(83)=1.67
C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
PARP(82)=1.85D0
IF (ITUNEB.EQ.301) PARP(82)=2.1D0
IF (ITUNEB.EQ.302) PARP(82)=1.9D0
IF (ITUNEB.EQ.304) PARP(82)=2.05D0
IF (ITUNEB.EQ.305) PARP(82)=1.9D0
IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
C...slightly higher, due to increased activity.
PARP(82)=2.0D0
IF (ITUNE.EQ.321) PARP(82)=2.3D0
IF (ITUNE.EQ.322) PARP(82)=1.9D0
IF (ITUNE.EQ.323) PARP(82)=2.2D0
IF (ITUNE.EQ.324) PARP(82)=1.95D0
IF (ITUNE.EQ.325) PARP(82)=2.2D0
IF (ITUNE.EQ.326) PARP(82)=1.95D0
IF (ITUNE.EQ.327) PARP(82)=2.05D0
IF (ITUNE.EQ.328) PARP(82)=2.45D0
IF (ITUNE.EQ.334) PARP(82)=2.15D0
ENDIF
C...Professor-pT0 maintains low pT0 vaue
IF (ITUNE.EQ.329) PARP(82)=1.85D0
IF (ITUNE.EQ.335) PARP(82)=2.10D0
IF (ITUNE.EQ.336) PARP(82)=1.83D0
IF (ITUNE.EQ.339) PARP(82)=2.28D0
C...UE: IR cutoff reference energy and default energy scaling pace
PARP(89)=1800D0
PARP(90)=0.16D0
C...S0A, S0A-Pro have tune A energy scaling
IF (ITUNEB.EQ.303) PARP(90)=0.25D0
IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
C...Perugia tunes explicitly include MB at 630 to fix energy scaling
PARP(90)=0.26
IF (ITUNE.EQ.321) PARP(90)=0.30D0
IF (ITUNE.EQ.322) PARP(90)=0.24D0
IF (ITUNE.EQ.323) PARP(90)=0.32D0
IF (ITUNE.EQ.324) PARP(90)=0.24D0
C...LO* and CTEQ6L1 tunes have slower energy scaling
IF (ITUNE.EQ.325) PARP(90)=0.23D0
IF (ITUNE.EQ.326) PARP(90)=0.22D0
ENDIF
C...Professor-pT0 has intermediate scaling
IF (ITUNE.EQ.329) PARP(90)=0.22D0
IF (ITUNE.EQ.335) PARP(90)=0.20D0
IF (ITUNE.EQ.336) PARP(90)=0.20D0
IF (ITUNE.EQ.339) PARP(90)=0.21D0
C...BR: MPI initiator color connections rap-ordered by default
C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
MSTP(89)=1
IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
IF (ITUNE.EQ.322) MSTP(89)=0
IF (ITUNE.EQ.327) MSTP(89)=0
IF (ITUNE.EQ.328) MSTP(89)=0
C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
PARP(80)=0.01D0
IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN
C...Perugia tunes have more beam blowup by default
PARP(80)=0.05D0
IF (ITUNE.EQ.321) PARP(80)=0.01
IF (ITUNE.EQ.323) PARP(80)=0.03
IF (ITUNE.EQ.324) PARP(80)=0.01
IF (ITUNE.EQ.327) PARP(80)=0.1
IF (ITUNE.EQ.328) PARP(80)=0.1
ENDIF
C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
MSTP(88)=0
PARP(79)=2D0
IF (ITUNEB.EQ.304) PARP(79)=3D0
IF (ITUNE.EQ.329) PARP(79)=1.18
IF (ITUNE.EQ.335) PARP(79)=1.11
IF (ITUNE.EQ.336) PARP(79)=1.10
IF (ITUNE.EQ.339) PARP(79)=3.69
C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
MSTP(91)=1
PARP(91)=2D0
PARP(93)=10D0
C...Perugia-HARD only uses 1.0 GeV
IF (ITUNE.EQ.321) PARP(91)=1.0D0
C...Perugia-3 only uses 1.5 GeV
IF (ITUNE.EQ.323) PARP(91)=1.5D0
C...Professor-pT0 uses 7-GeV cutoff
IF (ITUNE.EQ.329) PARP(93)=7.0
IF (ITUNE.EQ.335) THEN
PARP(91)=2.15
PARP(93)=6.79
ELSEIF (ITUNE.EQ.336) THEN
PARP(91)=1.85
PARP(93)=6.86
ELSEIF (ITUNE.EQ.339) THEN
PARP(91)=2.11
PARP(93)=5.08
ENDIF
C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
MSTP(95)=6
C...S1, S1-Pro: use S1
IF (ITUNEB.EQ.301) MSTP(95)=2
C...S2, S2-Pro: use S2
IF (ITUNEB.EQ.302) MSTP(95)=4
C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR.
& ITUNE.EQ.334) MSTP(95)=0
C..."Old" and "Old"-Pro: use old CR
IF (ITUNEB.EQ.305) MSTP(95)=1
C...Perugia 2010 and K use Paquis model
IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8
C...FSI: CR strength and high-pT dampening, default is S0
PARP(77)=0D0
IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
PARP(78)=0.2D0
IF (ITUNEB.EQ.301) PARP(78)=0.35D0
IF (ITUNEB.EQ.302) PARP(78)=0.15D0
IF (ITUNEB.EQ.304) PARP(78)=0.0D0
IF (ITUNEB.EQ.305) PARP(78)=1.0D0
IF (ITUNE.EQ.329) PARP(78)=0.17D0
IF (ITUNE.EQ.335) PARP(78)=0.14D0
IF (ITUNE.EQ.336) PARP(78)=0.17D0
IF (ITUNE.EQ.339) PARP(78)=0.13D0
ELSE
C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
PARP(78)=0.33
PARP(77)=0.9D0
IF (ITUNE.EQ.321) THEN
C...HARD has HIGH amount of CR
PARP(78)=0.37D0
PARP(77)=0.4D0
ELSEIF (ITUNE.EQ.322) THEN
C...SOFT has LOW amount of CR
PARP(78)=0.15D0
PARP(77)=0.5D0
ELSEIF (ITUNE.EQ.323) THEN
C...Scaling variant appears to need slightly more than default
PARP(78)=0.35D0
PARP(77)=0.6D0
ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN
C...NOCR has no CR
PARP(78)=0D0
PARP(77)=0D0
ELSEIF (ITUNE.EQ.327) THEN
C...2010
PARP(78)=0.035D0
PARP(77)=1D0
ELSEIF (ITUNE.EQ.328) THEN
C...K
PARP(78)=0.033D0
PARP(77)=1D0
ENDIF
ENDIF
C================
C...Perugia 2011 tunes
C...(written as modifications on top of Perugia 2010)
C================
IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN
ITUNE = ITUNSV
C... Scale setting for matching applications.
C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
MSTP(64)=2
MSTU(112)=5
C... This sets the Lambda scale for ISR, IFSR, and FSR
PARP(61)=0.26D0
PARP(72)=0.26D0
PARJ(81)=0.26D0
C... This sets the Lambda scale for QCD hard interactions (important for the
C... UE dijet cross sections. Here we still use an MSbar value, rather than
C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
PARP(1)=0.16D0
PARU(112)=0.16D0
C... For matching applications, PARP(71) and PARP(67) = 1
PARP(67) = 1D0
PARP(71) = 1D0
C... Primordial kT: only use 1 GeV
MSTP(91)=1
PARP(91)=1D0
C... ADDITIONAL LESSONS WRT PERUGIA 2010
C... ALICE taught us: need less baryon transport than SOFT
MSTP(89)=0
PARP(80)=0.015
C... Small adjustments at LEP (slightly softer frag functions, esp for baryons)
PARJ(21)=0.33
PARJ(41)=0.35
PARJ(42)=0.8
PARJ(45)=0.55
C... Increase Lambda/K ratio and other strange baryon yields
PARJ(1)=0.087D0
PARJ(3)=0.95D0
PARJ(4)=0.043D0
PARJ(6)=1.0D0
PARJ(7)=1.0D0
C... Also reduce total strangeness yield a bit, with higher K*/K
PARJ(2)=0.19D0
PARJ(12)=0.40D0
C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
MSTP(70)=0
MSTP(72)=2
PARP(62)=1.5D0
C... Holger taught us a smoother proton is preferred at high energies
C... Just use a simple Gaussian
MSTP(82)=3
C... Scaling of pt0 cutoff
PARP(90)=0.265
C... Now retune pT0 to give right UE activity.
C... Low CR strength indicated by LHC tunes
C... (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
PARP(78)=0.036D0
C... Choose 7 TeV as new reference scale
PARP(89)=7000.0D0
PARP(82)=2.93D0
C================
C... P2011 Variations
C================
IF (ITUNE.EQ.351) THEN
C... radHi: high Lambda scale for ISR, IFSR, and FSR
C... ( ca 10% more particles at LEP after retune )
PARP(61)=0.52D0
PARP(72)=0.52D0
PARJ(81)=0.52D0
C... Retune cutoff scales to compensate partially
C... (though higher cutoff causes faster multiplicity drop at low energies)
PARP(62)=1.75D0
PARJ(82)=1.75D0
PARP(82)=3.00D0
C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
C... (since more radiation otherwise generates faster mult growth)
PARP(90)=0.28
ELSEIF (ITUNE.EQ.352) THEN
C... radLo: low Lambda scale for ISR, IFSR, and FSR
C... ( ca 10% less particles at LEP after retune )
PARP(61)=0.13D0
PARP(72)=0.13D0
PARJ(81)=0.13D0
C... Retune cutoff scales to compensate partially
PARP(62)=1.00D0
PARJ(82)=0.75D0
PARP(82)=2.95D0
C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
C... (since less radiation otherwise generates slower mult growth)
PARP(90)=0.24
ELSEIF (ITUNE.EQ.353) THEN
C... mpiHi: high Lambda scale for MPI
PARP(1)=0.26D0
PARU(112)=0.26D0
PARP(82)=3.35D0
PARP(90)=0.26D0
ELSEIF (ITUNE.EQ.354) THEN
MSTP(95)=0
PARP(82)=3.05D0
ELSEIF (ITUNE.EQ.355) THEN
C... LO**
MSTP(52)=2
MSTP(51)=20651
PARP(62)=1.5D0
C... Compensate for higher <pT> with less CR
PARP(78)=0.034
PARP(82)=3.40D0
C... Need slower energy scaling than CTEQ5L
PARP(90)=0.23D0
ELSEIF (ITUNE.EQ.356) THEN
C... CTEQ6L1
MSTP(52)=2
MSTP(51)=10042
PARP(82)=2.65D0
C... Need slower cutoff scaling than CTEQ5L
PARP(90)=0.22D0
ELSEIF (ITUNE.EQ.357) THEN
C... T16
PARP(90)=0.16
ELSEIF (ITUNE.EQ.358) THEN
C... T32
PARP(90)=0.32
ELSEIF (ITUNE.EQ.359) THEN
C... Tevatron
PARP(89)=1800D0
PARP(90)=0.28
PARP(82)=2.10
PARP(78)=0.05
ENDIF
C================
C...Schulz-Skands 2011 tunes
C...(written as modifications on top of Perugia 0)
C================
ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
ITUNE = ITUNSV
IF (ITUNE.EQ.360) THEN
PARP(78)=0.40D0
PARP(82)=2.19D0
PARP(83)=1.45D0
PARP(89)=1800.0D0
PARP(90)=0.27D0
ELSEIF (ITUNE.EQ.361) THEN
PARP(78)=0.20D0
PARP(82)=2.75D0
PARP(83)=1.73D0
PARP(89)=7000.0D0
ELSEIF (ITUNE.EQ.362) THEN
PARP(78)=0.31D0
PARP(82)=1.97D0
PARP(83)=1.98D0
PARP(89)=1960.0D0
ELSEIF (ITUNE.EQ.363) THEN
PARP(78)=0.35D0
PARP(82)=1.91D0
PARP(83)=2.02D0
PARP(89)=1800.0D0
ELSEIF (ITUNE.EQ.364) THEN
PARP(78)=0.33D0
PARP(82)=1.69D0
PARP(83)=1.92D0
PARP(89)=900.0D0
ELSEIF (ITUNE.EQ.365) THEN
PARP(78)=0.47D0
PARP(82)=1.61D0
PARP(83)=1.50D0
PARP(89)=630.0D0
ENDIF
ENDIF
C...Switch off trial joinings
MSTP(96)=0
C...S0 (300), S0A (303)
IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
IF (M13.GE.1) THEN
CH60='see P. Skands & D. Wicke, hep-ph/0703081'
WRITE(M11,5030) CH60
CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.GE.310) THEN
CH60='LEP parameters tuned by Professor,'//
& ' hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...S1 (301)
ELSEIF(ITUNEB.EQ.301) THEN
IF (M13.GE.1) THEN
CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.GE.310) THEN
CH60='LEP parameters tuned by Professor,'//
& ' hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...S2 (302)
ELSEIF(ITUNEB.EQ.302) THEN
IF (M13.GE.1) THEN
CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.GE.310) THEN
CH60='LEP parameters tuned by Professor,'//
& ' hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...NOCR (304)
ELSEIF(ITUNEB.EQ.304) THEN
IF (M13.GE.1) THEN
CH60='"best try" without colour reconnections'
WRITE(M11,5030) CH60
CH60='see P. Skands & D. Wicke, hep-ph/0703081'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.GE.310) THEN
CH60='LEP parameters tuned by Professor,'//
& ' hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C..."Lo FSR" retune (305)
ELSEIF(ITUNEB.EQ.305) THEN
IF (M13.GE.1) THEN
CH60='"Lo FSR retune" with primitive colour reconnections'
WRITE(M11,5030) CH60
CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.GE.310) THEN
CH60='LEP parameters tuned by Professor,'//
& ' hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...Perugia Tunes (320-328 and 334)
ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
IF (M13.GE.1) THEN
CH60='Tuned by P. Skands, hep-ph/1005.3457'
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.LE.326) THEN
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
IF (ITUNE.EQ.325) THEN
CH70='NB! This tune requires MRST LO* pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ELSEIF (ITUNE.EQ.326) THEN
CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ELSEIF (ITUNE.EQ.321) THEN
CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
WRITE(M11,5030) CH60
ELSEIF (ITUNE.EQ.322) THEN
CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...Professor-pTO (329)
ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
& ITUNE.EQ.339) THEN
IF (M13.GE.1) THEN
CH60='Tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
ENDIF
C...Perugia 2011 Tunes (350-359)
ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
IF (M13.GE.1) THEN
CH60='Tuned by P. Skands, hep-ph/1005.3457'
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
IF (ITUNE.EQ.355) THEN
CH70='NB! This tune requires MRST LO** pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ELSEIF (ITUNE.EQ.356) THEN
CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ENDIF
ENDIF
C...Schulz-Skands Tunes (360-365)
ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
IF (M13.GE.1) THEN
CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
WRITE(M11,5030) CH60
CH60='Based on Perugia 0, hep-ph/1005.3457'
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
WRITE(M11,5030) CH60
ENDIF
ENDIF
C...Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
IF (MSTP(33).GE.10) THEN
WRITE(M11,5050) 32, PARP(32), CHPARP(32)
ENDIF
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
IF (MSTP(3).EQ.1) THEN
WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
WRITE(M11,6110) 112, PARU(112), CHPARU(112)
WRITE(M11,5050) 1, PARP(1) , CHPARP( 1)
ENDIF
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
IF (MSTP(3).EQ.1)
& WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
IF (MSTP(3).EQ.1) THEN
WRITE(M11,5050) 61, PARP(61) , CHPARP( 61)
ENDIF
WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
IF (MSTP(70).EQ.0) THEN
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
ELSEIF (MSTP(70).EQ.1) THEN
WRITE(M11,5050) 81, PARP(81), CHPARP(62)
CH60='(Note: PARP(81) replaces PARP(62).)'
WRITE(M11,5030) CH60
ENDIF
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
IF (MSTP(70).EQ.2) THEN
CH60='(Note: PARP(82) replaces PARP(62).)'
WRITE(M11,5030) CH60
ENDIF
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
IF (MSTP(82).EQ.5) THEN
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
ELSEIF (MSTP(82).EQ.4) THEN
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
ENDIF
WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
WRITE(M11,5050) 79, PARP(79), CHPARP(79)
WRITE(M11,5050) 80, PARP(80), CHPARP(80)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
IF (MSTP(95).GE.1) THEN
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
ENDIF
ENDIF
C=======================================================================
C...ATLAS-CSC 11-parameter tune (By A. Moraes)
ELSEIF (ITUNE.EQ.306) THEN
IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...PDFs
MSTP(52)=2
MSTP(54)=2
MSTP(51)=10042
MSTP(53)=10042
C...ISR
C PARP(64)=1D0
C...UE on, new model.
MSTP(81)=21
C...Energy scaling
PARP(89)=1800D0
PARP(90)=0.22D0
C...Switch off trial joinings
MSTP(96)=0
C...Primordial kT cutoff
IF (M13.GE.1) THEN
CH60='see presentations by A. Moraes (ATLAS),'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
WRITE(M11,5030) ' '
CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ENDIF
C...Smooth ISR, low FSR
MSTP(70)=2
MSTP(72)=0
C...pT0
PARP(82)=1.9D0
C...Transverse density profile.
MSTP(82)=4
PARP(83)=0.3D0
PARP(84)=0.5D0
C...ISR & FSR in interactions after the first (default)
MSTP(84)=1
MSTP(85)=1
C...No double-counting (default)
MSTP(86)=2
C...Companion quark parent gluon (1-x) power
MSTP(87)=4
C...Primordial kT compensation along chaings (default = 0 : uniform)
MSTP(90)=1
C...Colour Reconnections
MSTP(95)=1
PARP(78)=0.2D0
C...Lambda_FSR scale.
PARJ(81)=0.23D0
C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
MSTP(89)=1
MSTP(88)=0
C PARP(79)=2D0
PARP(80)=0.01D0
C...Peterson charm frag, and c and b hadr parameters
MSTJ(11)=3
PARJ(54)=-0.07
PARJ(55)=-0.006
C... Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
WRITE(M11,5030) CH60
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
WRITE(M11,5050) 79, PARP(79), CHPARP(79)
WRITE(M11,5050) 80, PARP(80), CHPARP(80)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
ENDIF
C=======================================================================
C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
& ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
& ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see R.D. Field, in hep-ph/0610012'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='Tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
CH60='Physics Model: '//
& 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
ENDIF
C...Make sure we start from old default fragmentation parameters
PARJ(81) = 0.29
PARJ(82) = 1.0
C...Use Professor's LEP pars if ITUNE >= 110
C...(i.e., for A-Pro, DW-Pro etc)
IF (ITUNE.LT.110) THEN
C...# Old defaults
MSTJ(11) = 4
PARJ(1) = 0.1
PARJ(2) = 0.3
PARJ(3) = 0.40
PARJ(4) = 0.05
PARJ(11) = 0.5
PARJ(12) = 0.6
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(81) = 0.29
PARJ(82) = 1.0
ELSE
C...# Tuned flavour parameters:
PARJ(1) = 0.073
PARJ(2) = 0.2
PARJ(3) = 0.94
PARJ(4) = 0.032
PARJ(11) = 0.31
PARJ(12) = 0.4
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C...# Switch on Bowler:
MSTJ(11) = 5
C...# Fragmentation
PARJ(21) = 0.325
PARJ(41) = 0.5
PARJ(42) = 0.6
PARJ(47) = 0.67
PARJ(81) = 0.29
PARJ(82) = 1.65
ENDIF
C...Remove middle digit now for Professor variants, since identical pars
ITUNEB=ITUNE
IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
ENDIF
C...Multiple interactions on, old framework
MSTP(81)=1
C...Fast IR cutoff energy scaling by default
PARP(89)=1800D0
PARP(90)=0.25D0
C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
MSTP(51)=7
MSTP(52)=1
IF (ITUNEB.EQ.105) THEN
MSTP(51)=10150
MSTP(52)=2
ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
MSTP(52)=2
MSTP(54)=2
MSTP(51)=10042
MSTP(53)=10042
ENDIF
C...Double Gaussian matter distribution.
MSTP(82)=4
PARP(83)=0.5D0
PARP(84)=0.4D0
C...FSR activity.
PARP(71)=4D0
C...Fragmentation functions and c and b parameters
C...(only if not using Professor)
IF (ITUNE.LE.109) THEN
MSTJ(11)=4
PARJ(54)=-0.05
PARJ(55)=-0.005
ENDIF
C...Tune A and AW
IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
C...pT0.
PARP(82)=2.0D0
c...String drawing almost completely minimizes string length.
PARP(85)=0.9D0
PARP(86)=0.95D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1D0
PARP(64)=1D0
PARP(67)=4D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=1D0
PARP(93)=5D0
C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
IF (ITUNEB.EQ.101) THEN
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(91)=2.1D0
PARP(92)=15.0D0
ENDIF
C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
ELSEIF (ITUNEB.EQ.102) THEN
C...pT0.
PARP(82)=1.9D0
c...String drawing completely minimizes string length.
PARP(85)=1.0D0
PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(67)=1D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=2.1D0
PARP(93)=15D0
C...Tune DW
ELSEIF (ITUNEB.EQ.103) THEN
C...pT0.
PARP(82)=1.9D0
c...String drawing completely minimizes string length.
PARP(85)=1.0D0
PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(67)=2.5D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=2.1D0
PARP(93)=15D0
C...Tune DWT
ELSEIF (ITUNEB.EQ.104) THEN
C...pT0.
PARP(82)=1.9409D0
C...Run II ref scale and slow scaling
PARP(89)=1960D0
PARP(90)=0.16D0
c...String drawing completely minimizes string length.
PARP(85)=1.0D0
PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(67)=2.5D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=2.1D0
PARP(93)=15D0
C...Tune QW
ELSEIF(ITUNEB.EQ.105) THEN
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ENDIF
C...pT0.
PARP(82)=1.1D0
c...String drawing completely minimizes string length.
PARP(85)=1.0D0
PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(67)=2.5D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=2.1D0
PARP(93)=15D0
C...Tune D6 and D6T
ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
CH70='NB! This tune requires CTEQ6L pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
ENDIF
C...The "Rick" proton, double gauss with 0.5/0.4
MSTP(82)=4
PARP(83)=0.5D0
PARP(84)=0.4D0
c...String drawing completely minimizes string length.
PARP(85)=1.0D0
PARP(86)=1.0D0
IF (ITUNEB.EQ.108) THEN
C...D6: pT0, Run I ref scale, and fast energy scaling
PARP(82)=1.8D0
PARP(89)=1800D0
PARP(90)=0.25D0
ELSE
C...D6T: pT0, Run II ref scale, and slow energy scaling
PARP(82)=1.8387D0
PARP(89)=1960D0
PARP(90)=0.16D0
ENDIF
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1.25D0
PARP(64)=0.2D0
PARP(67)=2.5D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=2.1D0
PARP(93)=15D0
C...Old ATLAS-DC2 5-parameter tune
ELSEIF(ITUNEB.EQ.106) THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
WRITE(M11,5030) CH60
CH60=' R. Field in hep-ph/0610012,'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
ENDIF
C... pT0.
PARP(82)=1.8D0
C... Different ref and rescaling pacee
PARP(89)=1000D0
PARP(90)=0.16D0
C... Parameters of mass distribution
PARP(83)=0.5D0
PARP(84)=0.5D0
C... Old default string drawing
PARP(85)=0.33D0
PARP(86)=0.66D0
C... ISR, phase space equivalent to Tune B
PARP(62)=1D0
PARP(64)=1D0
PARP(67)=1D0
C... FSR
PARP(71)=4D0
C... Intrinsic kT
MSTP(91)=1
PARP(91)=1D0
PARP(93)=5D0
C...Professor's Pro-Q2O Tune
ELSEIF(ITUNE.EQ.129) THEN
PARP(62)=2.9
PARP(64)=0.14
PARP(67)=2.65
PARP(82)=1.9
PARP(83)=0.83
PARP(84)=0.6
PARP(85)=0.86
PARP(86)=0.93
PARP(89)=1800D0
PARP(90)=0.22
MSTP(91)=1
PARP(91)=2.1
PARP(93)=5.0
ENDIF
C... Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5050) 85, PARP(85), CHPARP(85)
WRITE(M11,5050) 86, PARP(86), CHPARP(86)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
ENDIF
C=======================================================================
C... ACR, tune A with new CR (107)
ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='Tune A modified with new colour reconnections'
WRITE(M11,5030) CH60
CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
WRITE(M11,5030) CH60
CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
WRITE(M11,5030) CH60
CH60=' R. Field, in hep-ph/0610012 (Tune A),'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
IF (ITUNE.EQ.117) THEN
CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune. Using defaults.')
GOTO 100
ENDIF
C...Make sure we start from old default fragmentation parameters
PARJ(81) = 0.29
PARJ(82) = 1.0
C...Use Professor's LEP pars if ITUNE >= 110
C...(i.e., for A-Pro, DW-Pro etc)
IF (ITUNE.LT.110) THEN
C...# Old defaults
MSTJ(11) = 4
C...# Old default flavour parameters
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(82) = 1.0
ELSE
C...# Tuned flavour parameters:
PARJ(1) = 0.073
PARJ(2) = 0.2
PARJ(3) = 0.94
PARJ(4) = 0.032
PARJ(11) = 0.31
PARJ(12) = 0.4
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C...# Switch on Bowler:
MSTJ(11) = 5
C...# Fragmentation
PARJ(21) = 0.325
PARJ(41) = 0.5
PARJ(42) = 0.6
PARJ(47) = 0.67
PARJ(81) = 0.29
PARJ(82) = 1.65
ENDIF
MSTP(81)=1
PARP(89)=1800D0
PARP(90)=0.25D0
MSTP(82)=4
PARP(83)=0.5D0
PARP(84)=0.4D0
MSTP(51)=7
MSTP(52)=1
PARP(71)=4D0
PARP(82)=2.0D0
PARP(85)=0.0D0
PARP(86)=0.66D0
PARP(62)=1D0
PARP(64)=1D0
PARP(67)=4D0
MSTP(91)=1
PARP(91)=1D0
PARP(93)=5D0
MSTP(95)=6
C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
PARP(78)=0.09D0
C...Frag functions (only if not using Professor)
IF (ITUNE.LE.109) THEN
MSTJ(11)=4
PARJ(54)=-0.05
PARJ(55)=-0.005
ENDIF
C...Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5050) 85, PARP(85), CHPARP(85)
WRITE(M11,5050) 86, PARP(86), CHPARP(86)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
ENDIF
C=======================================================================
C...Intermediate model. Rap tune
C...(retuned to post-6.406 IR factorization)
ELSEIF(ITUNE.EQ.200) THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
WRITE(M11,5030) CH60
ENDIF
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...PDF
MSTP(51)=7
MSTP(52)=1
C...ISR
PARP(62)=1D0
PARP(64)=1D0
PARP(67)=4D0
C...FSR
PARP(71)=4D0
PARJ(81)=0.29D0
C...UE
MSTP(81)=11
PARP(82)=2.25D0
PARP(89)=1800D0
PARP(90)=0.25D0
C... ExpOfPow(1.8) overlap profile
MSTP(82)=5
PARP(83)=1.8D0
C... Valence qq
MSTP(88)=0
C... Rap Tune
MSTP(89)=1
C... Default diquark, BR-g-BR supp
PARP(79)=2D0
PARP(80)=0.01D0
C... Final state reconnect.
MSTP(95)=1
PARP(78)=0.55D0
C...Fragmentation functions and c and b parameters
MSTJ(11)=4
PARJ(54)=-0.05
PARJ(55)=-0.005
C... Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
WRITE(M11,5050) 79, PARP(79), CHPARP(79)
WRITE(M11,5050) 80, PARP(80), CHPARP(80)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
WRITE(M11,5050) 78, PARP(78), CHPARP(78)
ENDIF
C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
C...Old model for ISR and UE, new pT-ordered model for FSR
ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
& .ITUNE.EQ.226) THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
WRITE(M11,5030) CH60
CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
WRITE(M11,5030) CH60
CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
WRITE(M11,5030) CH60
IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
WRITE(M11,5030) CH60
ENDIF
ENDIF
IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
& ' with tune.')
ENDIF
C...First set as if Pythia tune A
C...Multiple interactions on, old framework
MSTP(81)=1
C...Fast IR cutoff energy scaling by default
PARP(89)=1800D0
PARP(90)=0.25D0
C...Default CTEQ5L (internal)
MSTP(51)=7
MSTP(52)=1
C...Double Gaussian matter distribution.
MSTP(82)=4
PARP(83)=0.5D0
PARP(84)=0.4D0
C...FSR activity.
PARP(71)=4D0
c...String drawing almost completely minimizes string length.
PARP(85)=0.9D0
PARP(86)=0.95D0
C...ISR cutoff, muR scale factor, and phase space size
PARP(62)=1D0
PARP(64)=1D0
PARP(67)=4D0
C...Intrinsic kT, size, and max
MSTP(91)=1
PARP(91)=1D0
PARP(93)=5D0
C...Use 2 GeV of primordial kT for "Perugia" version
IF (ITUNE.EQ.221) THEN
PARP(91)=2D0
PARP(93)=10D0
ENDIF
C...Use pT-ordered FSR
MSTJ(41)=12
C...Lambda_FSR scale for pT-ordering
PARJ(81)=0.23D0
C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
PARP(82)=2.05D0
C...Fragmentation functions and c and b parameters
C...(overwritten for 211, i.e., if using Professor pars)
PARJ(54)=-0.05
PARJ(55)=-0.005
C...Use Professor's LEP pars if ITUNE == 211, 221, 226
IF (ITUNE.LT.210) THEN
C...# Old defaults
MSTJ(11) = 4
C...# Old default flavour parameters
PARJ(21) = 0.36
PARJ(41) = 0.30
PARJ(42) = 0.58
PARJ(46) = 1.0
PARJ(82) = 1.0
ELSE
C...# Tuned flavour parameters:
PARJ(1) = 0.073
PARJ(2) = 0.2
PARJ(3) = 0.94
PARJ(4) = 0.032
PARJ(11) = 0.31
PARJ(12) = 0.4
PARJ(13) = 0.54
PARJ(25) = 0.63
PARJ(26) = 0.12
C...# Always use pT-ordered shower:
MSTJ(41) = 12
C...# Switch on Bowler:
MSTJ(11) = 5
C...# Fragmentation
PARJ(21) = 3.1327e-01
PARJ(41) = 4.8989e-01
PARJ(42) = 1.2018e+00
PARJ(47) = 1.0000e+00
PARJ(81) = 2.5696e-01
PARJ(82) = 8.0000e-01
ENDIF
C...221, 226 : Perugia-APT and Perugia-APT6
IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
PARP(64)=0.5D0
PARP(82)=2.05D0
PARP(90)=0.26D0
PARP(91)=2.0D0
C...The Perugia variants use Steve's showers off the old MPI
MSTP(152)=1
C...And use a lower PARP(71) as suggested by Professor tunings
C...(although not certain that applies to Q2-pT2 hybrid)
PARP(71)=2.5D0
C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
IF (ITUNE.EQ.226) THEN
CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
& 'externally linked'
WRITE(M11,5035) CH70
MSTP(52)=2
MSTP(51)=10042
PARP(82)=1.95D0
ENDIF
ENDIF
C... Output
IF (M13.GE.1) THEN
WRITE(M11,5030) ' '
WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
WRITE(M11,5050) 64, PARP(64), CHPARP(64)
WRITE(M11,5050) 67, PARP(67), CHPARP(67)
WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
WRITE(M11,5030) CH60
WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
WRITE(M11,5050) 71, PARP(71), CHPARP(71)
WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5050) 89, PARP(89), CHPARP(89)
WRITE(M11,5050) 90, PARP(90), CHPARP(90)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
WRITE(M11,5050) 85, PARP(85), CHPARP(85)
WRITE(M11,5050) 86, PARP(86), CHPARP(86)
WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
WRITE(M11,5050) 91, PARP(91), CHPARP(91)
WRITE(M11,5050) 93, PARP(93), CHPARP(93)
ENDIF
C======================================================================
C...Uppsala models: Generalized Area Law and Soft Colour Interactions
ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see J. Rathsman, PLB452(1999)364'
WRITE(M11,5030) CH60
C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
C ? WRITE(M11,5030)
CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
WRITE(M11,5030) ' '
CH70='NB! The GAL model must be run with modified '//
& 'Pythia v6.215:'
WRITE(M11,5035) CH70
CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
WRITE(M11,5035) CH70
WRITE(M11,5030) ' '
ENDIF
C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
MSWI(2) = 3
PARSCI(2) = 0.10
MSWI(1) = 2
PARSCI(1) = 0.44
MSTJ(16) = 0
PARJ(42) = 0.45
PARJ(82) = 2.0
PARP(62) = 2.0
MSTP(81) = 1
MSTP(82) = 1
PARP(81) = 1.9
MSTP(92) = 1
IF(CHNAME.EQ.'GAL Tune 1') THEN
C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
MSTP(82)=4
PARP(83)=0.25D0
PARP(84)=0.5D0
PARP(82) = 1.75
IF (M13.GE.1) THEN
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 84, PARP(84), CHPARP(84)
ENDIF
ELSE
IF (M13.GE.1) THEN
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 81, PARP(81), CHPARP(81)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
ENDIF
ENDIF
C...Output
IF (M13.GE.1) THEN
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
CH40='FSI SCI/GAL selection'
WRITE(M11,6040) 1, MSWI(1), CH40
CH40='FSI SCI/GAL sea quark treatment'
WRITE(M11,6040) 2, MSWI(2), CH40
CH40='FSI SCI/GAL sea quark treatment parm'
WRITE(M11,6050) 1, PARSCI(1), CH40
CH40='FSI SCI/GAL string reco probability R_0'
WRITE(M11,6050) 2, PARSCI(2), CH40
WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
ENDIF
ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
IF (M13.GE.1) THEN
WRITE(M11,5010) ITUNE, CHNAME
CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
WRITE(M11,5030) CH60
CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
WRITE(M11,5030) CH60
WRITE(M11,5030) ' '
CH70='NB! The SCI model must be run with modified '//
& 'Pythia v6.215:'
WRITE(M11,5035) CH70
CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
WRITE(M11,5035) CH70
WRITE(M11,5030) ' '
ENDIF
C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
MSTP(81)=1
MSTP(82)=1
PARP(81)=2.2
MSTP(92)=1
MSWI(2)=2
PARSCI(2)=0.50
MSWI(1)=2
PARSCI(1)=0.44
MSTJ(16)=0
IF (CHNAME.EQ.'SCI Tune 1') THEN
C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
MSTP(81) = 1
MSTP(82) = 3
PARP(82) = 2.4
PARP(83) = 0.5D0
PARP(62) = 1.5
PARP(84)=0.25D0
IF (M13.GE.1) THEN
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 82, PARP(82), CHPARP(82)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
WRITE(M11,5050) 83, PARP(83), CHPARP(83)
WRITE(M11,5050) 62, PARP(62), CHPARP(62)
ENDIF
ELSE
IF (M13.GE.1) THEN
WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
WRITE(M11,5050) 81, PARP(81), CHPARP(81)
WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
ENDIF
ENDIF
C...Output
IF (M13.GE.1) THEN
WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
CH40='FSI SCI/GAL selection'
WRITE(M11,6040) 1, MSWI(1), CH40
CH40='FSI SCI/GAL sea quark treatment'
WRITE(M11,6040) 2, MSWI(2), CH40
CH40='FSI SCI/GAL sea quark treatment parm'
WRITE(M11,6050) 1, PARSCI(1), CH40
CH40='FSI SCI/GAL string reco probability R_0'
WRITE(M11,6050) 2, PARSCI(2), CH40
WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
ENDIF
ELSE
IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
ENDIF
C...Output of LEP parameters, common to all models
IF (M13.GE.1) THEN
WRITE(M11,5080)
WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
IF (MSTJ(11).EQ.3) THEN
CH60='Warning: using Peterson fragmentation function'
WRITE(M11,5030) CH60
ENDIF
WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1)
WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2)
WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3)
WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4)
WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5)
WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6)
WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7)
WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
IF (MSTJ(11).LE.3) THEN
WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
ELSE
WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
ENDIF
IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
ENDIF
100 IF (MSTU(13).GE.1) WRITE(M11,6000)
9999 RETURN
5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
& 'Presets for underlying-event (and min-bias)',21x,'*'/' *',
& 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*')
5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
5030 FORMAT(' *',3x,10x,A60,3x,'*')
5035 FORMAT(' *',3x,A70,3x,'*')
5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
END
C*********************************************************************
C...PYEXEC
C...Administrates the fragmentation and decay chain.
SUBROUTINE PYEXEC
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYINT1/MINT(400),VINT(400)
COMMON/PYINT4/MWID(500),WIDS(500,5)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
C...Local array.
DIMENSION PS(2,6),IJOIN(100)
C...Initialize and reset.
MSTU(24)=0
IF(MSTU(12).NE.12345) CALL PYLIST(0)
MSTU(29)=0
MSTU(31)=MSTU(31)+1
MSTU(1)=0
MSTU(2)=0
MSTU(3)=0
IF(MSTU(17).LE.0) MSTU(90)=0
MCONS=1
C...Sum up momentum, energy and charge for starting entries.
NSAV=N
DO 110 I=1,2
DO 100 J=1,6
PS(I,J)=0D0
100 CONTINUE
110 CONTINUE
DO 130 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
DO 120 J=1,4
PS(1,J)=PS(1,J)+P(I,J)
120 CONTINUE
PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
130 CONTINUE
PARU(21)=PS(1,4)
C...Start by all decays of coloured resonances involved in shower.
NORIG=N
DO 140 I=1,NORIG
IF(K(I,1).EQ.3) THEN
KC=PYCOMP(K(I,2))
IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
ENDIF
140 CONTINUE
C...Prepare system for subsequent fragmentation/decay.
CALL PYPREP(0)
IF(MINT(51).NE.0) RETURN
C...Loop through jet fragmentation and particle decays.
MBE=0
150 MBE=MBE+1
IP=0
160 IP=IP+1
KC=0
IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
IF(KC.EQ.0) THEN
C...Deal with any remaining undecayed resonance
C...(normally the task of PYEVNT, so seldom used).
ELSEIF(MWID(KC).NE.0) THEN
IBEG=IP
IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
IBEG=IP+1
170 IBEG=IBEG-1
IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
IF(K(IBEG,1).NE.2) IBEG=IBEG+1
IEND=IP-1
180 IEND=IEND+1
IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
NJOIN=0
DO 190 I=IBEG,IEND
IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
NJOIN=NJOIN+1
IJOIN(NJOIN)=I
ENDIF
190 CONTINUE
ENDIF
CALL PYRESD(IP)
CALL PYPREP(IBEG)
IF(MINT(51).NE.0) RETURN
C...Particle decay if unstable and allowed. Save long-lived particle
C...decays until second pass after Bose-Einstein effects.
ELSEIF(KCHG(KC,2).EQ.0) THEN
IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
& .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
& CALL PYDECY(IP)
C...Decay products may develop a shower.
IF(MSTJ(92).GT.0) THEN
IP1=MSTJ(92)
QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
& 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
MINT(33)=0
CALL PYSHOW(IP1,IP1+1,QMAX)
CALL PYPREP(IP1)
IF(MINT(51).NE.0) RETURN
MSTJ(92)=0
ELSEIF(MSTJ(92).LT.0) THEN
IP1=-MSTJ(92)
MINT(33)=0
CALL PYSHOW(IP1,-3,P(IP,5))
CALL PYPREP(IP1)
IF(MINT(51).NE.0) RETURN
MSTJ(92)=0
ENDIF
C...Jet fragmentation: string or independent fragmentation.
ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
MFRAG=MSTJ(1)
IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
& K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
ENDIF
ENDIF
IF(MFRAG.EQ.1) CALL PYSTRF(IP)
IF(MFRAG.EQ.2) CALL PYINDF(IP)
IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
ENDIF
C...Loop back if enough space left in PYJETS and no error abort.
IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
GOTO 160
ELSEIF(IP.LT.N) THEN
CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
ENDIF
C...Include simple Bose-Einstein effect parametrization if desired.
IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
CALL PYBOEI(NSAV)
GOTO 150
ENDIF
C...Check that momentum, energy and charge were conserved.
DO 210 I=1,N
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
DO 200 J=1,4
PS(2,J)=PS(2,J)+P(I,J)
200 CONTINUE
PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
210 CONTINUE
PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
&PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
&'(PYEXEC:) four-momentum was not conserved')
IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
&'(PYEXEC:) charge was not conserved')
RETURN
END
C*********************************************************************
C...PYPREP
C...Rearranges partons along strings.
C...Special considerations for systems with junctions, with
C...possibility of junction-antijunction annihilation.
C...Allows small systems to collapse into one or two particles.
C...Checks flavours and colour singlet invariant masses.
SUBROUTINE PYPREP(IP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
COMMON/PYCTAG/NCT,MCT(4000,2)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
&/PYPARS/
DATA NERRPR/0/
SAVE NERRPR
C...Local arrays.
DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
&ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
&IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
&IJCP(0:6),TJUOLD(5)
CHARACTER CHTMP*6
C...Function to give four-product.
FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
C...Rearrange parton shower product listing along strings: begin loop.
MSTU(24)=0
NOLD=N
I1=N
NJUNC=0
NPIECE=0
NJJSTR=0
MSTU32=MSTU(32)+1
DO 100 I=MAX(1,IP),N
C...First store junction positions.
IF(K(I,1).EQ.42) THEN
NJUNC=NJUNC+1
IJUNC(NJUNC,0)=I
IJUNC(NJUNC,4)=0
ENDIF
100 CONTINUE
DO 250 MQGST=1,3
DO 240 I=MAX(1,IP),N
C...Special treatment for junctions
IF (K(I,1).LE.0) GOTO 240
IF(K(I,1).EQ.42) THEN
C...MQGST=2: Look for junction-junction strings (not detected in the
C...main search below).
IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
IF (NJJSTR.EQ.0) THEN
NJJSTR = (3*NJUNC-NPIECE)/2
ENDIF
C...Check how many already identified strings end on this junction
ILC=0
DO 110 J=1,NPIECE
IF (IPIECE(J,4).EQ.I) ILC=ILC+1
110 CONTINUE
C...If less than 3, remaining must be to another junction
IF (ILC.LT.3) THEN
IF (ILC.NE.2) THEN
C...Multiple j-j connections not handled yet.
CALL PYERRM(2,
& '(PYPREP:) Too many junction-junction strings.')
MINT(51)=1
RETURN
ENDIF
C...The colour information in the junction is unreadable for the
C...colour space search further down in this routine, so we must
C...start on the colour mother of this junction and then "artificially"
C...prevent the colour mother from connecting here again.
ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
KCS=4
IF (MOD(ITJUNC,2).EQ.0) KCS=5
C...Switch colour if the junction-junction leg is presumably a
C...junction mother leg rather than a junction daughter leg.
IF (ITJUNC.GE.3) KCS=9-KCS
IF (MINT(33).EQ.0) THEN
C...Find the unconnected leg and reorder junction daughter pointers so
C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
C...piece.
IA=MOD(K(I,4),MSTU(5))
IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
ITMP=MOD(K(I,5),MSTU(5))
IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
ELSE
K(I,5)=K(I,5)+(IA-ITMP)
ENDIF
K(I,4)=K(I,4)+(ITMP-IA)
IA=ITMP
ENDIF
IF (ITJUNC.LE.2) THEN
C...Beam baryon junction
K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
C...Else 1 -> 2 decay junction
ELSE
K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
ENDIF
I1BEG = I1
NSTP = 0
GOTO 170
C...Alternatively use colour tag information.
ELSE
C...Find a final state parton with appropriate dangling colour tag.
JCT=0
IA=0
IJUMO=K(I,3)
DO 140 J1=MAX(1,IP),N
IF (K(J1,1).NE.3) GOTO 140
C...Check for matching final-state colour tag
IMATCH=0
DO 120 J2=MAX(1,IP),N
IF (K(J2,1).NE.3) GOTO 120
IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
120 CONTINUE
IF (IMATCH.EQ.1) GOTO 140
C...Check whether this colour tag belongs to the present junction
C...by seeing whether any parton with this colour tag has the same
C...mother as the junction.
JCT=MCT(J1,KCS-3)
IMATCH=0
DO 130 J2=MINT(84)+1,N
IMO2=K(J2,3)
C...First scattering partons have IMO1 = 3 and 4.
IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
& IMO2=IMO2-2
IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
& IMATCH=1
130 CONTINUE
IF (IMATCH.EQ.0) GOTO 140
IA=J1
140 CONTINUE
C...Check for junction-junction strings without intermediate final state
C...glue (not detected above).
IF (IA.EQ.0) THEN
DO 160 MJU=1,NJUNC
IJU2=IJUNC(MJU,0)
IF (IJU2.EQ.I) GOTO 160
ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
C...Only opposite types of junctions can connect to each other.
IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
IS=0
DO 150 J=1,NPIECE
IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
150 CONTINUE
IF (IS.EQ.3) GOTO 160
IB=I
IA=IJU2
160 CONTINUE
ENDIF
C...Switch to other side of adjacent parton and step from there.
KCS=9-KCS
I1BEG = I1
NSTP = 0
GOTO 170
ENDIF
ELSE IF (ILC.NE.3) THEN
ENDIF
ENDIF
ENDIF
C...Look for coloured string endpoint, or (later) leftover gluon.
IF(K(I,1).NE.3) GOTO 240
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 240
KQ=KCHG(KC,2)
IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
C...Pick up loose string end.
KCS=4
IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
IA=I
IB=I
I1BEG=I1
NSTP=0
170 NSTP=NSTP+1
IF(NSTP.GT.4*N) THEN
CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
MINT(51)=1
RETURN
ENDIF
C...Copy undecayed parton. Finished if reached string endpoint.
IF(K(IA,1).EQ.3) THEN
IF(I1.GE.MSTU(4)-MSTU32-5) THEN
CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
MINT(51)=1
MSTU(24)=1
RETURN
ENDIF
I1=I1+1
K(I1,1)=2
IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
K(I1,2)=K(IA,2)
K(I1,3)=IA
K(I1,4)=0
K(I1,5)=0
DO 180 J=1,5
P(I1,J)=P(IA,J)
V(I1,J)=V(IA,J)
180 CONTINUE
K(IA,1)=K(IA,1)+10
IF(K(I1,1).EQ.1) GOTO 240
ENDIF
C...Also finished (for now) if reached junction; then copy to end.
IF(K(IA,1).EQ.42) THEN
NCOPY=I1-I1BEG
IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
MINT(51)=1
MSTU(24)=1
RETURN
ENDIF
IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
DO 200 ICOPY=1,NCOPY
DO 190 J=1,5
K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
190 CONTINUE
200 CONTINUE
ENDIF
C...For junction-junction strings, find end leg and reorder junction
C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
C...junction-junction string piece.
IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
ITMP=MOD(K(IA,4),MSTU(5))
IF (ITMP.NE.IB) THEN
IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
K(IA,5)=K(IA,5)+(ITMP-IB)
ELSE
K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
ENDIF
K(IA,4)=K(IA,4)+(IB-ITMP)
ENDIF
ENDIF
NPIECE=NPIECE+1
C...IPIECE:
C...0: endpoint in original ER
C...1:
C...2:
C...3: Parton immediately next to junction
C...4: Junction
IPIECE(NPIECE,0)=I
IPIECE(NPIECE,1)=MSTU32+1
IPIECE(NPIECE,2)=MSTU32+NCOPY
IPIECE(NPIECE,3)=IB
IPIECE(NPIECE,4)=IA
MSTU32=MSTU32+NCOPY
I1=I1BEG
GOTO 240
ENDIF
C...GOTO next parton in colour space.
IB=IA
IF (MINT(33).EQ.0) THEN
IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
& )).NE.0) THEN
IA=MOD(K(IB,KCS),MSTU(5))
K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
MREV=0
ELSE
IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
& MSTU(5)).EQ.0) KCS=9-KCS
IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
MREV=1
ENDIF
IF(IA.LE.0.OR.IA.GT.N) THEN
CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
IF(NERRPR.LT.5) THEN
NERRPR=NERRPR+1
WRITE(MSTU(11),*) 'started at:', I
WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
WRITE(MSTU(11),*) 'MQGST =',MQGST
CALL PYLIST(4)
ENDIF
MINT(51)=1
RETURN
ENDIF
IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
& ,MSTU(5)).EQ.IB) THEN
IF(MREV.EQ.1) KCS=9-KCS
IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
ELSE
IF(MREV.EQ.0) KCS=9-KCS
IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
ENDIF
IF(IA.NE.I) GOTO 170
C...Use colour tag information
ELSE
C...First create colour tags starting on IB if none already present.
IF (MCT(IB,KCS-3).EQ.0) THEN
CALL PYCTTR(IB,KCS,IB)
IF(MINT(51).NE.0) RETURN
ENDIF
JCT=MCT(IB,KCS-3)
IFOUND=0
C...Find final state tag partner
DO 210 IT=MAX(1,IP),N
IF (IT.EQ.IB) GOTO 210
IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
& .0) THEN
IFOUND=IFOUND+1
IA=IT
ENDIF
210 CONTINUE
C...Just copy and goto next if exactly one partner found.
IF (IFOUND.EQ.1) THEN
GOTO 170
C...When no match found, match is presumably junction.
ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
C...Check whether this colour tag matches a junction
C...by seeing whether any parton with this colour tag has the same
C...mother as a junction.
C...NB: Only type 1 and 2 junctions handled presently.
DO 230 IJU=1,NJUNC
IJUMO=K(IJUNC(IJU,0),3)
ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
C...Colours only connect to junctions, anti-colours to antijunctions:
IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
IMATCH=0
DO 220 J1=MAX(1,IP),N
IF (K(J1,1).LE.0) GOTO 220
C...First scattering partons have IMO1 = 3 and 4.
IMO=K(J1,3)
IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
& IMO=IMO-2
IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
& ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
& IMATCH=1
C...Attempt at handling type > 3 junctions also. Not tested.
IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
& .IJUMO) IMATCH=1
220 CONTINUE
IF (IMATCH.EQ.0) GOTO 230
IA=IJUNC(IJU,0)
IFOUND=IFOUND+1
230 CONTINUE
IF (IFOUND.EQ.1) THEN
GOTO 170
ELSEIF (IFOUND.EQ.0) THEN
WRITE(CHTMP,'(I6)') JCT
CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
& //CHTMP)
IF(NERRPR.LT.5) THEN
NERRPR=NERRPR+1
CALL PYLIST(4)
ENDIF
MINT(51)=1
RETURN
ENDIF
ELSEIF (IFOUND.GE.2) THEN
WRITE(CHTMP,'(I6)') JCT
CALL PYERRM(12
& ,'(PYPREP:) too many occurences of colour line: '//
& CHTMP)
IF(NERRPR.LT.5) THEN
NERRPR=NERRPR+1
CALL PYLIST(4)
ENDIF
MINT(51)=1
RETURN
ENDIF
ENDIF
K(I1,1)=1
240 CONTINUE
250 CONTINUE
C...Junction systems remain.
IJU=0
IJUS=0
IJUCNT=0
MREV=0
IJJSTR=0
260 IJUCNT=IJUCNT+1
IF (IJUCNT.LE.NJUNC) THEN
C...If we are not processing a j-j string, treat this junction as new.
IF (IJJSTR.EQ.0) THEN
IJU=IJUNC(IJUCNT,0)
MREV=0
C...If junction has already been read, ignore it.
IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
C...If we are on a j-j string, goto second j-j junction.
ELSE
IJUCNT=IJUCNT-1
IJU=IJUS
ENDIF
C...Mark selected junction read.
DO 270 J=1,NJUNC
IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
270 CONTINUE
C...Determine junction type
ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
IHK=0
280 IHK=IHK+1
C...Find which quarks belong to given junction.
IHF=0
DO 290 IPC=1,NPIECE
IF (IPIECE(IPC,4).EQ.IJU) THEN
IHF=IHF+1
IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
ENDIF
IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
290 CONTINUE
C...IHK = 3 is special. Either normal string piece, or j-j string.
IF(IHK.EQ.3) THEN
IF (MREV.NE.1) THEN
DO 300 IPC=1,NPIECE
C...If there is a j-j string starting on the present junction which has
C...zero length, insert next junction immediately.
IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
& .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
IJJSTR = 1
GOTO 340
ENDIF
300 CONTINUE
MREV = 1
C...If MREV is 1 and IHK is 3 we are finished with this system.
ELSE
MREV=0
GOTO 260
ENDIF
ENDIF
C...If we've gotten this far, then either IHK < 3, or
C...an interjunction string exists, or just a third normal string.
IJUNC(IJUCNT,IHK)=0
IJJSTR = 0
C..Order pieces belonging to this junction. Also look for j-j.
DO 310 IPC=1,NPIECE
IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
& .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
IJUNC(IJUCNT,IHK)=IPC
IJJSTR = 1
MREV = 0
ENDIF
310 CONTINUE
C...Copy back chains in proper order. MREV=0/1 : descending/ascending
IPC=IJUNC(IJUCNT,IHK)
C...Temporary solution to cover for bug.
IF(IPC.LE.0) THEN
CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
MINT(51)=1
RETURN
ENDIF
DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
I1=I1+1
DO 320 J=1,5
K(I1,J)=K(MSTU(4)-ICP,J)
P(I1,J)=P(MSTU(4)-ICP,J)
V(I1,J)=V(MSTU(4)-ICP,J)
320 CONTINUE
330 CONTINUE
K(I1,1)=2
C...Mark last quark.
IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
C...Do not insert junctions at wrong places.
IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
C...Insert junction.
340 IJUS = IJU
IF (IHK.EQ.3) THEN
C...Shift to end junction if a j-j string has been processed.
IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
MREV= 1
ENDIF
I1=I1+1
DO 350 J=1,5
K(I1,J)=0
P(I1,J)=0.
V(I1,J)=0.
350 CONTINUE
K(I1,1)=41
K(IJUS,1)=K(IJUS,1)+10
K(I1,2)=K(IJUS,2)
K(I1,3)=IJUS
360 IF (IHK.LT.3) GOTO 280
ELSE
CALL PYERRM(12,'(PYPREP:) Unknown junction type')
MINT(51)=1
RETURN
ENDIF
IF (IJUCNT.NE.NJUNC) GOTO 260
ENDIF
N=I1
C...Rearrange three strings from junction, e.g. in case one has been
C...shortened by shower, so the last is the largest-energy one.
IF(NJUNC.GE.1) THEN
C...Find systems with exactly one junction.
MJUN1=0
NBEG=NOLD+1
DO 470 I=NOLD+1,N
IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
ELSEIF(K(I,1).EQ.41) THEN
MJUN1=MJUN1+1
ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
MJUN1=0
NBEG=I+1
ELSE
NEND=I
C...Sum up energy-momentum in each junction string.
DO 370 J=1,5
PJU(1,J)=0D0
PJU(2,J)=0D0
PJU(3,J)=0D0
370 CONTINUE
NJU=0
DO 390 I1=NBEG,NEND
IF(K(I1,2).NE.21) THEN
NJU=NJU+1
IJUR(NJU)=I1
ENDIF
DO 380 J=1,5
PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
380 CONTINUE
390 CONTINUE
C...Find which of them has highest energy (minus mass) in rest frame.
DO 400 J=1,5
PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
400 CONTINUE
PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
& PJU(4,3)**2))
DO 410 I2=1,3
PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
& PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
410 CONTINUE
IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
C...Decide how to rearrange so that new last has highest energy.
IF(PJU(1,6).LT.PJU(2,6)) THEN
IRNG(1,1)=IJUR(1)
IRNG(1,2)=IJUR(2)-1
IRNG(2,1)=IJUR(4)
IRNG(2,2)=IJUR(3)+1
IRNG(4,1)=IJUR(3)-1
IRNG(4,2)=IJUR(2)
ELSE
IRNG(1,1)=IJUR(4)
IRNG(1,2)=IJUR(3)+1
IRNG(2,1)=IJUR(2)
IRNG(2,2)=IJUR(3)-1
IRNG(4,1)=IJUR(2)-1
IRNG(4,2)=IJUR(1)
ENDIF
IRNG(3,1)=IJUR(3)
IRNG(3,2)=IJUR(3)
C...Copy in correct order below bottom of current event record.
I2=N
DO 440 II=1,4
DO 430 I1=IRNG(II,1),IRNG(II,2),
& ISIGN(1,IRNG(II,2)-IRNG(II,1))
I2=I2+1
IF(I2.GE.MSTU(4)-MSTU32-5) THEN
CALL PYERRM(11,
& '(PYPREP:) no more memory left in PYJETS')
MINT(51)=1
MSTU(24)=1
RETURN
ENDIF
DO 420 J=1,5
K(I2,J)=K(I1,J)
P(I2,J)=P(I1,J)
V(I2,J)=V(I1,J)
420 CONTINUE
IF(K(I2,1).EQ.1) K(I2,1)=2
430 CONTINUE
440 CONTINUE
K(I2,1)=1
C...Copy back up, overwriting but now in correct order.
DO 460 I1=NBEG,NEND
I2=I1-NBEG+N+1
DO 450 J=1,5
K(I1,J)=K(I2,J)
P(I1,J)=P(I2,J)
V(I1,J)=V(I2,J)
450 CONTINUE
460 CONTINUE
ENDIF
MJUN1=0
NBEG=I+1
ENDIF
470 CONTINUE
C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
C...to two q-qbar systems.
C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
IF (MSTJ(19).NE.1) THEN
MJUN1 = 0
JJGLUE = 0
NBEG = NOLD+1
C...Force collapse when MSTJ(19)=2.
IF (MSTJ(19).EQ.2) THEN
DELMJJ = 1D9
DELMQQ = 0D0
ENDIF
C...Find systems with exactly two junctions.
DO 700 I=NOLD+1,N
C...Count junctions
IF (K(I,1).EQ.41) THEN
MJUN1 = MJUN1+1
C...Check for interjunction gluons
IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
JJGLUE = 1
ENDIF
ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
C...If end of system reached with either zero or one junction, restart
C...with next system.
MJUN1 = 0
JJGLUE = 0
NBEG = I+1
ELSEIF(K(I,1).EQ.1) THEN
C...If end of system reached with exactly two junctions, compute string
C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
C...length measure for the (q-qbar)(q-qbar) topology.
NEND=I
C...Loop down through chain.
ISID=0
DO 480 I1=NBEG,NEND
C...Store string piece division locations in event record
IF (K(I1,2).NE.21) THEN
ISID = ISID+1
IJCP(ISID) = I1
ENDIF
480 CONTINUE
C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
ISW=0
IF (PYR(0).LT.0.5D0) ISW=1
C...Randomly choose which qqbar string gets the jj gluons.
IGS=1
IF (PYR(0).GT.0.5D0) IGS=2
C...Only compute string lengths when no topology forced.
IF (MSTJ(19).EQ.0) THEN
C...Repeat following for each junction
DO 570 IJU=1,2
C...Initialize iterative procedure for finding JRF
IJRFIT=0
DO 490 IX=1,3
TJUOLD(IX)=0D0
490 CONTINUE
TJUOLD(4)=1D0
C...Start iteration. Sum up momenta in string pieces
500 DO 540 IJS=1,3
C...JD=-1 for first junction, +1 for second junction.
C...Find out where piece starts and ends and which direction to go.
JD=2*IJU-3
IF (IJS.LE.2) THEN
IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
IB = IJCP((IJU-1)*7 - JD*IJS)
ELSEIF (IJS.EQ.3) THEN
JD =-JD
IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
IB = IJCP((IJU-1)*7 + JD*(IJS+3))
ENDIF
C...Initialize junction pull 4-vector.
DO 510 J=1,5
PUL(IJS,J)=0D0
510 CONTINUE
C...Initialize weight
PWT = 0D0
PWTOLD = 0D0
C...Sum up (weighted) momenta along each string piece
DO 530 ISP=IA,IB,JD
C...If present parton not last in chain
IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
C...If last parton was a junction, store present weight
IF (K(ISP-JD,2).EQ.88) THEN
PWTOLD = PWT
C...If last parton was a quark, reset to stored weight.
ELSEIF (K(ISP-JD,2).NE.21) THEN
PWT = PWTOLD
ENDIF
ENDIF
C...Skip next parton if weight already large
IF (PWT.GT.10D0) GOTO 530
C...Compute momentum in TJUOLD frame:
TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
& )*P(ISP,3)
BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
DO 520 J=1,3
TMP=P(ISP,J)+TJUOLD(J)*BFC
PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
520 CONTINUE
C...Boosted energy
TMP=TJUOLD(4)*P(ISP,4)+TDP
PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
C...Update weight
PWT=PWT+TMP/PARJ(48)
C...Put |p| rather than m in 5th slot
PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
& +PUL(IJS,3)**2)
530 CONTINUE
540 CONTINUE
C...Compute boost
IJRFIT=IJRFIT+1
CALL PYJURF(PUL,T)
C...Combine new boost (T) with old boost (TJUOLD)
TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
DO 550 IX=1,3
TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
& ))
550 CONTINUE
TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
& **2)
C...If last boost small, accept JRF, else iterate.
C...Also prevent possibility of infinite loop.
IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
& IJRFIT.LT.MSTJ(18))THEN
GOTO 500
ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
ENDIF
C...Store final boost, with change of sign since TJJ motion vector.
DO 560 IX=1,3
TJJ(IJU,IX)=-TJUOLD(IX)
560 CONTINUE
TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
& +TJJ(IJU,3)**2)
570 CONTINUE
C...String length measure for (q-qbar)(q-qbar) topology.
C...Note only momenta of nearest partons used (since rest of system
C...identical).
IF (JJGLUE.EQ.0) THEN
DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
& -1,IJCP(5-ISW)+1)
ELSE
C...Put jj gluons on selected string (IGS selected randomly above).
IF (IGS.EQ.1) THEN
DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
& ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
ELSE
DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
& *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
& ,IJCP(5-ISW)+1)
ENDIF
ENDIF
C...String length measure for q-q-j-j-q-q topology.
T1G1=0D0
T2G2=0D0
T1T2=0D0
T1P1=0D0
T1P2=0D0
T2P3=0D0
T2P4=0D0
ISGN=-1
C...Note only momenta of nearest partons used (since rest of system
C...identical).
DO 580 IX=1,4
IF (IX.EQ.4) ISGN=1
T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
IF (JJGLUE.EQ.0) THEN
C...Junction motion vector dot product gives length when inter-junction
C...gluons absent.
T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
ELSE
C...Junction motion vector dot products with gluon momenta give length
C...when inter-junction gluons present.
T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
ENDIF
580 CONTINUE
DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
IF (JJGLUE.EQ.0) THEN
DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
ELSE
DELMJJ=DELMJJ*4D0*T1G1*T2G2
ENDIF
ENDIF
C...If delmjj > delmqq collapse string system to q-qbar q-qbar
C...(Always the case for MSTJ(19)=2 due to initialization above)
IF (DELMJJ.GT.DELMQQ) THEN
C...Put new system at end of event record
NCOP=N
DO 650 IST=1,2
DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
NCOP=NCOP+1
DO 590 IX=1,5
P(NCOP,IX)=P(ICOP,IX)
K(NCOP,IX)=K(ICOP,IX)
590 CONTINUE
600 CONTINUE
IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
C...Insert inter-junction gluon string piece (reversed)
NJJGL=0
DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
NJJGL=NJJGL+1
NCOP=NCOP+1
DO 610 IX=1,5
P(NCOP,IX)=P(ICOP,IX)
K(NCOP,IX)=K(ICOP,IX)
610 CONTINUE
620 CONTINUE
ENDIF
IFC=-2*IST+3
DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
NCOP=NCOP+1
DO 630 IX=1,5
P(NCOP,IX)=P(ICOP,IX)
K(NCOP,IX)=K(ICOP,IX)
630 CONTINUE
640 CONTINUE
K(NCOP,1)=1
650 CONTINUE
C...Copy system back in right order
DO 670 ICOP=NBEG,NEND-2
DO 660 IX=1,5
P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
660 CONTINUE
670 CONTINUE
C...Shift down rest of event record
DO 690 ICOP=NEND+1,N
DO 680 IX=1,5
P(ICOP-2,IX)=P(ICOP,IX)
K(ICOP-2,IX)=K(ICOP,IX)
680 CONTINUE
690 CONTINUE
C...Update length of event record.
N=N-2
ENDIF
MJUN1=0
NBEG=I+1
ENDIF
700 CONTINUE
ENDIF
ENDIF
C...Done if no checks on small-mass systems.
IF(MSTJ(14).LT.0) RETURN
IF(MSTJ(14).EQ.0) GOTO 1140
C...Find lowest-mass colour singlet jet system.
NS=N
710 NSIN=N-NS
PDMIN=1D0+PARJ(32)
IC=0
DO 770 I=MAX(1,IP),N
IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
NSIN=NSIN+1
IC=I
DO 720 J=1,4
DPS(J)=P(I,J)
720 CONTINUE
MSTJ(93)=1
DPS(5)=PYMASS(K(I,2))
ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
DO 730 J=1,4
DPS(J)=DPS(J)+P(I,J)
730 CONTINUE
MSTJ(93)=1
DPS(5)=DPS(5)+PYMASS(K(I,2))
ELSEIF(K(I,1).EQ.2) THEN
DO 740 J=1,4
DPS(J)=DPS(J)+P(I,J)
740 CONTINUE
ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
DO 750 J=1,4
DPS(J)=DPS(J)+P(I,J)
750 CONTINUE
MSTJ(93)=1
DPS(5)=DPS(5)+PYMASS(K(I,2))
PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
& DPS(5)
IF(PD.LT.PDMIN) THEN
PDMIN=PD
DO 760 J=1,5
DPC(J)=DPS(J)
760 CONTINUE
IC1=IC
IC2=I
ENDIF
IC=0
ELSE
NSIN=NSIN+1
ENDIF
770 CONTINUE
C...Done if lowest-mass system above threshold for string frag.
IF(PDMIN.GE.PARJ(32)) GOTO 1140
C...Fill small-mass system as cluster.
NSAV=N
PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
K(N+1,1)=11
K(N+1,2)=91
K(N+1,3)=IC1
P(N+1,1)=DPC(1)
P(N+1,2)=DPC(2)
P(N+1,3)=DPC(3)
P(N+1,4)=DPC(4)
P(N+1,5)=PECM
C...Set up history, assuming cluster -> 2 hadrons.
NBODY=2
K(N+1,4)=N+2
K(N+1,5)=N+3
K(N+2,1)=1
K(N+3,1)=1
IF(MSTU(16).NE.2) THEN
K(N+2,3)=N+1
K(N+3,3)=N+1
ELSE
K(N+2,3)=IC1
K(N+3,3)=IC2
ENDIF
K(N+2,4)=0
K(N+3,4)=0
K(N+2,5)=0
K(N+3,5)=0
V(N+1,5)=0D0
V(N+2,5)=0D0
V(N+3,5)=0D0
C...Find total flavour content - complicated by presence of junctions.
NQ=0
NDIQ=0
DO 780 I=IC1,IC2
IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
NQ=NQ+1
KFQ(NQ)=K(I,2)
IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
ENDIF
780 CONTINUE
C...If several diquarks, split up one to give even number of flavours.
IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
I1=3
IF(IABS(KFQ(3)).LT.1000) I1=1
KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
KFQ(I1)=KFQ(I1)/1000
NQ=4
NDIQ=NDIQ-1
ENDIF
C...If four quark ends, join two to diquark.
IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
I1=1
I2=2
IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
& 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
KFQ(I2)=KFQ(4)
NQ=3
NDIQ=1
ENDIF
C...If two quark ends, plus quark or diquark, join quarks to diquark.
IF(NQ.EQ.3) THEN
I1=1
I2=2
IF(IABS(KFQ(I1)).GT.1000) I1=3
IF(IABS(KFQ(I2)).GT.1000) I2=3
KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
& 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
KFQ(I2)=KFQ(3)
NQ=2
NDIQ=NDIQ+1
ENDIF
C...Form two particles from flavours of lowest-mass system, if feasible.
NTRY = 0
790 NTRY = NTRY + 1
C...Open string with two specified endpoint flavours.
IF(NQ.EQ.2) THEN
KC1=PYCOMP(KFQ(1))
KC2=PYCOMP(KFQ(2))
IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
IF(KQ1+KQ2.NE.0) GOTO 1140
C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
800 K1=KFQ(1)
IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
MSTU(125)=0
CALL PYDCYK(K1,0,KFLN,K(N+2,2))
CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
C...Open string with four specified flavours.
ELSEIF(NQ.EQ.4) THEN
KC1=PYCOMP(KFQ(1))
KC2=PYCOMP(KFQ(2))
KC3=PYCOMP(KFQ(3))
KC4=PYCOMP(KFQ(4))
IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
C...Combine flavours pairwise to form two hadrons.
810 I1=1
I2=2
IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
& IABS(KFQ(2)).GT.1000)) I2=3
IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
& IABS(KFQ(3)).GT.1000))) I2=4
I3=3
IF(I2.EQ.3) I3=2
I4=10-I1-I2-I3
CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
C...Closed string.
ELSE
IF(IABS(K(IC2,2)).NE.21) GOTO 1140
C...No room for popcorn mesons in closed string -> 2 hadrons.
MSTU(125)=0
820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
ENDIF
P(N+2,5)=PYMASS(K(N+2,2))
P(N+3,5)=PYMASS(K(N+3,2))
C...If it does not work: try again (a number of times), give up (if no
C...place to shuffle momentum or too many flavours), or form one hadron.
IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
GOTO 790
ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
GOTO 1140
ELSE
GOTO 890
END IF
END IF
C...Perform two-particle decay of jet system.
C...First step: find reference axis in decaying system rest frame.
C...(Borrow slot N+2 for temporary direction.)
DO 830 J=1,4
P(N+2,J)=P(IC1,J)
830 CONTINUE
DO 850 I=IC1+1,IC2-1
IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
& KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
DO 840 J=1,4
P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
840 CONTINUE
ENDIF
850 CONTINUE
CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
&-DPC(3)/DPC(4))
THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
PHI1=PYANGL(P(N+2,1),P(N+2,2))
C...Second step: generate isotropic/anisotropic decay.
PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
&(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
860 UE(3)=PYR(0)
IF(PARJ(21).LE.0.01D0) UE(3)=1D0
PT2=(1D0-UE(3)**2)*PA**2
IF(MSTJ(16).LE.0) THEN
PREV=0.5D0
ELSE
IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
PR1=P(N+2,5)**2+PT2
PR2=P(N+3,5)**2+PT2
ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
PREVCF=PARJ(42)
IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
ENDIF
IF(PYR(0).LT.PREV) UE(3)=-UE(3)
PHI=PARU(2)*PYR(0)
UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
DO 870 J=1,3
P(N+2,J)=PA*UE(J)
P(N+3,J)=-PA*UE(J)
870 CONTINUE
P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
C...Third step: move back to event frame and set production vertex.
CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
&DPC(3)/DPC(4))
DO 880 J=1,4
V(N+1,J)=V(IC1,J)
V(N+2,J)=V(IC1,J)
V(N+3,J)=V(IC2,J)
880 CONTINUE
N=N+3
GOTO 1120
C...Else form one particle, if possible.
890 NBODY=1
K(N+1,5)=N+2
DO 900 J=1,4
V(N+1,J)=V(IC1,J)
V(N+2,J)=V(IC1,J)
900 CONTINUE
C...Select hadron flavour from available quark flavours.
910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
GOTO 1140
ELSEIF(NQ.EQ.2) THEN
CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
ELSE
KFLN=1+INT((2D0+PARJ(2))*PYR(0))
CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
ENDIF
IF(K(N+2,2).EQ.0) GOTO 910
P(N+2,5)=PYMASS(K(N+2,2))
C...Use old algorithm for E/p conservation? (EN)
IF (MSTJ(16).LE.0) GOTO 1080
C...Find the string piece closest to the cluster by a loop
C...over the undecayed partons not in present cluster. (EN)
DGLOMI=1D30
IBEG=0
I0=0
NJUNC=0
DO 940 I1=MAX(1,IP),N-1
IF(K(I1,1).EQ.1) NJUNC=0
IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
IF(K(I1,1).EQ.41) GOTO 940
IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
I0=0
ELSEIF(K(I1,1).EQ.2) THEN
IF(I0.EQ.0) I0=I1
I2=I1
920 I2=I2+1
IF(K(I2,1).EQ.41) GOTO 940
IF(K(I2,1).GT.10) GOTO 920
IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
& NJUNC.EQ.0) GOTO 940
IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
& K(I2,1).NE.1)) GOTO 940
C...Define velocity vectors e1, e2, ecl and differences e3, e4.
DO 930 J=1,3
E1(J)=P(I1,J)/P(I1,4)
E2(J)=P(I2,J)/P(I2,4)
ECL(J)=P(N+1,J)/P(N+1,4)
E3(J)=E2(J)-E1(J)
E4(J)=ECL(J)-E1(J)
930 CONTINUE
C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
E3S=E3(1)**2+E3(2)**2+E3(3)**2
E4S=E4(1)**2+E4(2)**2+E4(3)**2
E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
IF(E34.LE.0D0) THEN
DDMIN=E4S
ELSEIF(E34.LT.E3S) THEN
DDMIN=E4S-E34**2/E3S
ELSE
DDMIN=E4S-2D0*E34+E3S
ENDIF
C...Is this the smallest so far?
IF(DDMIN.LT.DGLOMI) THEN
DGLOMI=DDMIN
IBEG=I0
IPCS=I1
ENDIF
ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
I0=0
ENDIF
940 CONTINUE
C... Check if there are any strings to connect to the new gluon. (EN)
IF (IBEG.EQ.0) GOTO 1080
C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
IF (P(N+1,5).GE.P(N+2,5)) THEN
C...Construct 'gluon' that is needed to put hadron on the mass shell.
FRAC=P(N+2,5)/P(N+1,5)
DO 950 J=1,5
P(N+2,J)=FRAC*P(N+1,J)
PG(J)=(1D0-FRAC)*P(N+1,J)
950 CONTINUE
C... Copy string with new gluon put in.
N=N+2
I=IBEG-1
960 I=I+1
IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
N=N+1
DO 970 J=1,5
K(N,J)=K(I,J)
P(N,J)=P(I,J)
V(N,J)=V(I,J)
970 CONTINUE
K(I,1)=K(I,1)+10
K(I,4)=N
K(I,5)=N
K(N,3)=I
IF(I.EQ.IPCS) THEN
N=N+1
DO 980 J=1,5
K(N,J)=K(N-1,J)
P(N,J)=PG(J)
V(N,J)=V(N-1,J)
980 CONTINUE
K(N,2)=21
K(N,3)=NSAV+1
ENDIF
IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
GOTO 1120
C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
C...from string piece endpoints.
ELSE
C...Begin by copying string that should give energy to cluster.
N=N+2
I=IBEG-1
990 I=I+1
IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
N=N+1
DO 1000 J=1,5
K(N,J)=K(I,J)
P(N,J)=P(I,J)
V(N,J)=V(I,J)
1000 CONTINUE
K(I,1)=K(I,1)+10
K(I,4)=N
K(I,5)=N
K(N,3)=I
IF(I.EQ.IPCS) I1=N
IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
I2=I1+1
C...Set initial Phad.
DO 1010 J=1,4
P(NSAV+2,J)=P(NSAV+1,J)
1010 CONTINUE
C...Calculate Pg, a part of which will be added to Phad later. (EN)
1020 IF(MSTJ(16).EQ.1) THEN
ALPHA=1D0
BETA=1D0
ELSE
ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
ENDIF
DO 1030 J=1,4
PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
1030 CONTINUE
PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
C..Solve 2nd order equation, use the best (smallest) solution. (EN)
PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
& P(NSAV+2,3)**2
PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
& P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
C...If all gluon energy eaten, zero it and take a step back.
ITER=0
IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
ITER=1
DO 1040 J=1,4
P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
P(I1,J)=0D0
1040 CONTINUE
P(I1,5)=0D0
K(I1,1)=K(I1,1)+10
I1=I1-1
IF(K(I1,1).EQ.41) ITER=-1
ENDIF
IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
ITER=1
DO 1050 J=1,4
P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
P(I2,J)=0D0
1050 CONTINUE
P(I2,5)=0D0
K(I2,1)=K(I2,1)+10
I2=I2+1
IF(K(I2,1).EQ.41) ITER=-1
ENDIF
IF(ITER.EQ.1) GOTO 1020
C...If also all endpoint energy eaten, revert to old procedure.
IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
& (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
DO 1060 I=NSAV+3,N
IM=K(I,3)
K(IM,1)=K(IM,1)-10
K(IM,4)=0
K(IM,5)=0
1060 CONTINUE
N=NSAV
GOTO 1080
ENDIF
C... Construct the collapsed hadron and modified string partons.
DO 1070 J=1,4
P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
1070 CONTINUE
P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
C...Finished with string collapse in new scheme.
GOTO 1120
ENDIF
C... Use old algorithm; by choice or when in trouble.
1080 CONTINUE
C...Find parton/particle which combines to largest extra mass.
IR=0
HA=0D0
HSM=0D0
DO 1100 MCOMB=1,3
IF(IR.NE.0) GOTO 1100
DO 1090 I=MAX(1,IP),N
IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
& .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
& GOTO 1090
HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
IF(HSR.GT.HSM) THEN
IR=I
HA=HCR
HSM=HSR
ENDIF
1090 CONTINUE
1100 CONTINUE
C...Shuffle energy and momentum to put new particle on mass shell.
IF(IR.NE.0) THEN
HB=PECM**2+HA
HC=P(N+2,5)**2+HA
HD=P(IR,5)**2+HA
HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
& (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
DO 1110 J=1,4
P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
1110 CONTINUE
N=N+2
ELSE
CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
RETURN
ENDIF
C...Mark collapsed system and store daughter pointers. Iterate.
1120 DO 1130 I=IC1,IC2
IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
& KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
K(I,1)=K(I,1)+10
IF(MSTU(16).NE.2) THEN
K(I,4)=NSAV+1
K(I,5)=NSAV+1
ELSE
K(I,4)=NSAV+2
K(I,5)=NSAV+1+NBODY
ENDIF
ENDIF
IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
1130 CONTINUE
IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
C...Check flavours and invariant masses in parton systems.
1140 NP=0
KFN=0
KQS=0
NJU=0
DO 1150 J=1,5
DPS(J)=0D0
1150 CONTINUE
DO 1180 I=MAX(1,IP),N
IF(K(I,1).EQ.41) NJU=NJU+1
IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 1180
KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
IF(KQ.EQ.0) GOTO 1180
NP=NP+1
IF(KQ.NE.2) THEN
KFN=KFN+1
KQS=KQS+KQ
MSTJ(93)=1
DPS(5)=DPS(5)+PYMASS(K(I,2))
ENDIF
DO 1160 J=1,4
DPS(J)=DPS(J)+P(I,J)
1160 CONTINUE
IF(K(I,1).EQ.1) THEN
NFERR=0
IF(NJU.EQ.0.AND.NP.NE.1) THEN
IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
ELSEIF(NJU.EQ.1) THEN
IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
ELSEIF(NJU.EQ.2) THEN
IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
ELSEIF(NJU.GE.3) THEN
NFERR=1
ENDIF
IF(NFERR.EQ.1) THEN
CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
MINT(51)=1
RETURN
ENDIF
IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
& (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
& '(PYPREP:) too small mass in jet system')
NP=0
KFN=0
KQS=0
NJU=0
DO 1170 J=1,5
DPS(J)=0D0
1170 CONTINUE
ENDIF
1180 CONTINUE
RETURN
END
C*********************************************************************
C...PYSTRF
C...Handles the fragmentation of an arbitrary colour singlet
C...jet system according to the Lund string fragmentation model.
SUBROUTINE PYSTRF(IP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Local arrays. All MOPS variables ends with MO
DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
&IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
&TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
&INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
&PBST(3,5),TJUOLD(5)
C...Function: four-product of two vectors.
FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
&DP(I,3)*DP(J,3)
C...Reset counters.
MSTJ(91)=0
NSAV=N
MSTU90=MSTU(90)
NP=0
KQSUM=0
DO 100 J=1,5
DPS(J)=0D0
100 CONTINUE
MJU(1)=0
MJU(2)=0
NTRYFN=0
IJUORI(1)=0
IJUORI(2)=0
C...Identify parton system.
I=IP-1
110 I=I+1
IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
IF(MSTU(21).GE.1) RETURN
ENDIF
IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 110
KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) RETURN
ENDIF
C...Take copy of partons to be considered. Check flavour sum.
NP=NP+1
DO 120 J=1,5
K(N+NP,J)=K(I,J)
P(N+NP,J)=P(I,J)
IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
120 CONTINUE
DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
K(N+NP,3)=I
IF(KQ.NE.2) KQSUM=KQSUM+KQ
IF(K(I,1).EQ.41) THEN
IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
MJU(1)=N+NP
IJUORI(1)=I
ELSE
MJU(2)=N+NP
IJUORI(2)=I
ENDIF
ENDIF
IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
IF(MOD(KQSUM,3).NE.0) THEN
CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
IF(MSTU(21).GE.1) RETURN
ENDIF
IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
C...Boost copied system to CM frame (for better numerical precision).
IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
MBST=0
MSTU(33)=1
CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
& -DPS(3)/DPS(4))
ELSE
MBST=1
HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
DO 130 I=N+1,N+NP
HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
IF(P(I,3).GT.0D0) THEN
HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
ELSE
HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
ENDIF
130 CONTINUE
ENDIF
C...Search for very nearby partons that may be recombined.
NTRYR=0
NTRYWR=0
PARU12=PARU(12)
PARU13=PARU(13)
MJU(3)=MJU(1)
MJU(4)=MJU(2)
NR=NP
NRMIN=2
IF(MJU(1).GT.0) NRMIN=NRMIN+2
IF(MJU(2).GT.0) NRMIN=NRMIN+2
140 IF(NR.GT.NRMIN) THEN
PDRMIN=2D0*PARU12
DO 150 I=N+1,N+NR
IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
I1=I+1
IF(I.EQ.N+NR) I1=N+1
IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
& GOTO 150
IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
& GOTO 150
PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
& P(I1,2)**2+P(I1,3)**2))
PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
IF(PDR.LT.PDRMIN) THEN
IR=I
PDRMIN=PDR
ENDIF
150 CONTINUE
C...Recombine very nearby partons to avoid machine precision problems.
IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
DO 160 J=1,4
P(N+1,J)=P(N+1,J)+P(N+NR,J)
160 CONTINUE
P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
& P(N+1,3)**2))
NR=NR-1
GOTO 140
ELSEIF(PDRMIN.LT.PARU12) THEN
DO 170 J=1,4
P(IR,J)=P(IR,J)+P(IR+1,J)
170 CONTINUE
P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
& P(IR,3)**2))
IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
DO 190 I=IR+1,N+NR-1
K(I,1)=K(I+1,1)
K(I,2)=K(I+1,2)
DO 180 J=1,5
P(I,J)=P(I+1,J)
180 CONTINUE
190 CONTINUE
IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
NR=NR-1
IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
GOTO 140
ENDIF
ENDIF
NTRYR=NTRYR+1
C...Reset particle counter. Skip ahead if no junctions are present;
C...this is usually the case!
NRS=MAX(5*NR+11,NP)
NTRY=0
200 NTRY=NTRY+1
IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
PARU12=4D0*PARU12
PARU13=2D0*PARU13
GOTO 140
ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
I=N+NRS
MSTU(90)=MSTU90
IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
& ' junction strings not handled by MSTJ(12)>3 options')
DO 640 JT=1,2
NJS(JT)=0
IF(MJU(JT).EQ.0) GOTO 640
JS=3-2*JT
C++SKANDS
C...Find and sum up momentum on three sides of junction.
C...Begin with previous boost = zero.
IJRFIT=0
DO 210 IX=1,3
TJUOLD(IX)=0D0
210 CONTINUE
C...Prevent IJU (specifically IJU(5)) from containing junk below
DO 215 IU=1,6
IJU(IU)=0
215 CONTINUE
TJUOLD(4)=1D0
220 IU=0
C...Beginning and end of string system in event record.
I1BEG=N+1+(JT-1)*(NR-1)
I1END=N+NR+(JT-1)*(1-NR)
C...Look for junction string piece end points
DO 230 I1=I1BEG,I1END,JS
IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
C...Store junction string piece end points.
C 1-junction systems 2-junction systems
C IU : 1 2 3 4 1 2 3 4 5 6
C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q
IU=IU+1
IJU(IU)=I1
ENDIF
C...Sum over momenta, from junction outwards.
230 CONTINUE
DO 280 IU=1,3
PWT=0D0
C...Initialize junction drag and string piece 4-vectors.
DO 240 J=1,5
PBST(IU,J)=0D0
PJU(IU,J)=0D0
240 CONTINUE
C...First two branches. Inwards out means opposite direction to JS.
C...(JS is 1 for JT=1, -1 for JT=2)
IF (IU.LT.3) THEN
I1A=IJU(IU+1)-JS
I1B=IJU(IU)
IDIR=-JS
C...Last branch (gq or gjgqgq). Direction now reversed.
ELSE
I1A=IJU(IU)+JS
I1B=I1END
IDIR=JS
ENDIF
DO 270 I1=I1A,I1B,IDIR
C...Sum up momentum directions with exponential suppression
C...for use in finding junction rest frame below.
IF (K(I1,2).EQ.88) THEN
C...gjgqgq type system encountered. Use current PWT as start
C...for both strings.
PWTOLD=PWT
ELSE
IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
C...Sum up string piece (boosted) 4-momenta.
DO 250 J=1,4
PJU(IU,J)=PJU(IU,J)+P(I1,J)
250 CONTINUE
C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
C...boost is zero, see above). Skip parton if suppression factor large.
IF (PWT.GT.10D0) GOTO 270
C...Compute momentum in current frame:
TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
DO 260 J=1,3
PTMP=P(I1,J)+TJUOLD(J)*BFC
PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
260 CONTINUE
C...Boosted energy
PTMP=TJUOLD(4)*P(I1,4)+TDP
PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
PWT=PWT+PTMP/PARJ(48)
ENDIF
270 CONTINUE
C...Put |p| rather than m in 5th slot.
PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
280 CONTINUE
C...Calculate boost from present frame to next JRF candidate.
IJRFIT=IJRFIT+1
CALL PYJURF(PBST,TJU)
C...After some iterations do not take full step in new direction.
IF(IJRFIT.GT.5) THEN
REDUCE=0.8D0**(IJRFIT-5)
TJU(1)=REDUCE*TJU(1)
TJU(2)=REDUCE*TJU(2)
TJU(3)=REDUCE*TJU(3)
TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
ENDIF
C...Combine new boost (TJU) with old boost (TJUOLD)
TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
DO 290 IX=1,3
TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
290 CONTINUE
TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
C...If last boost small, accept JRF, else iterate.
C...Also prevent possibility of infinite loop.
IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
& IJRFIT.LT.MSTJ(18)) THEN
GOTO 220
ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
ENDIF
C...Now store total boost in TJU and change perception.
C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
C...TJU = junction motion vector in string CM, so the sign changes.
DO 300 J=1,3
TJU(J)=-TJUOLD(J)
300 CONTINUE
TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
C--SKANDS
C...Calculate string piece energies in junction rest frame.
DO 310 IU=1,3
PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
& TJU(3)*PJU(IU,3)
PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
& TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
310 CONTINUE
C...Start preparing for fragmentation of two strings from junction.
ISTA=I
NTRYER=0
320 NTRYER=NTRYER+1
I=ISTA
DO 620 IU=1,2
NS=IABS(IJU(IU+1)-IJU(IU))
C...Junction strings: find longitudinal string directions.
DO 350 IS=1,NS
IS1=IJU(IU)+JS*(IS-1)
IS2=IJU(IU)+JS*IS
DO 330 J=1,5
DP(1,J)=0.5D0*P(IS1,J)
IF(IS.EQ.1) DP(1,J)=P(IS1,J)
DP(2,J)=0.5D0*P(IS2,J)
IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
& (PJU(IU,5)/PBST(IU,5))
330 CONTINUE
IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
& PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
DP(3,5)=DFOUR(1,1)
DP(4,5)=DFOUR(2,2)
DHKC=DFOUR(1,2)
IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
DP(3,5)=0D0
DP(4,5)=0D0
DHKC=DFOUR(1,2)
ENDIF
DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
IN1=N+NR+4*IS-3
P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
DO 340 J=1,4
P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
340 CONTINUE
350 CONTINUE
C...Junction strings: initialize flavour, momentum and starting pos.
ISAV=I
MSTU91=MSTU(90)
360 NTRY=NTRY+1
IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
PARU12=4D0*PARU12
PARU13=2D0*PARU13
GOTO 140
ELSEIF(NTRY.GT.100) THEN
CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
I=ISAV
MSTU(90)=MSTU91
IRANKJ=0
IE(1)=K(N+1+(JT/2)*(NP-1),3)
IF (MOD(JT+IU,2).NE.0) THEN
IE(1)=K(IJU(IU),3)
IF (NP-NR.NE.0) THEN
C...If gluons have disappeared. Original IJU must be used.
IT=IP
NE=1
370 IT=IT+1
IF (K(IT,2).NE.21) THEN
NE=NE+1
ENDIF
IF (NE.EQ.IU+4*(JT-1)) THEN
IE(1)=IT
ELSEIF (IT.LE.IP+NP) THEN
GOTO 370
ELSE
CALL PYERRM(14,'(PYSTRF:) '//
& 'Original IJU could not be reconstructed!')
ENDIF
ENDIF
ENDIF
IN(4)=N+NR+1
IN(5)=IN(4)+1
IN(6)=N+NR+4*NS+1
DO 390 JQ=1,2
DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
P(IN1,1)=2-JQ
P(IN1,2)=JQ-1
P(IN1,3)=1D0
380 CONTINUE
390 CONTINUE
KFL(1)=K(IJU(IU),2)
PX(1)=0D0
PY(1)=0D0
GAM(1)=0D0
DO 400 J=1,5
PJU(IU+3,J)=0D0
400 CONTINUE
C...Junction strings: find initial transverse directions.
DO 410 J=1,4
DP(1,J)=P(IN(4),J)
DP(2,J)=P(IN(4)+1,J)
DP(3,J)=0D0
DP(4,J)=0D0
410 CONTINUE
DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
DHC12=DFOUR(1,2)
DHCX1=DFOUR(3,1)/DHC12
DHCX2=DFOUR(3,2)/DHC12
DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
DHCY1=DFOUR(4,1)/DHC12
DHCY2=DFOUR(4,2)/DHC12
DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
DO 420 J=1,4
DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
P(IN(6),J)=DP(3,J)
P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
& DHCYX*DP(3,J))
420 CONTINUE
C...Junction strings: produce new particle, origin.
430 I=I+1
IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) RETURN
ENDIF
IRANKJ=IRANKJ+1
K(I,1)=1
K(I,3)=IE(1)
K(I,4)=0
K(I,5)=0
C...Junction strings: generate flavour, hadron, pT, z and Gamma.
440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
IF(K(I,2).EQ.0) GOTO 360
IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
& IABS(KFL(3)).GT.10) THEN
IF(PYR(0).GT.PARJ(19)) GOTO 440
ENDIF
P(I,5)=PYMASS(K(I,2))
CALL PYPTDI(KFL(1),PX(3),PY(3))
PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
& MSTU(90).LT.8) THEN
MSTU(90)=MSTU(90)+1
MSTU(90+MSTU(90))=I
PARU(90+MSTU(90))=Z
ENDIF
GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
DO 450 J=1,3
IN(J)=IN(3+J)
450 CONTINUE
C...Junction strings: stepping within 'low' string region.
IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
& P(IN(1),5)**2.GE.PR(1)) THEN
P(IN(1)+2,4)=Z*P(IN(1)+2,3)
P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
DO 460 J=1,4
P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
460 CONTINUE
GOTO 560
C...Has used up energy of junction string, i.e. no more hadrons in it.
ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
DO 470 J=1,5
P(I,J)=0D0
470 CONTINUE
GOTO 600
C...Stepping from 'low' string region
ELSEIF(IN(1)+1.EQ.IN(2)) THEN
P(IN(2)+2,4)=P(IN(2)+2,3)
P(IN(2)+2,1)=1D0
IN(2)=IN(2)+4
IF(IN(2).GT.N+NR+4*NS) GOTO 360
IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
P(IN(1)+2,4)=P(IN(1)+2,3)
P(IN(1)+2,1)=0D0
IN(1)=IN(1)+4
ENDIF
ENDIF
C...Junction strings: find new transverse directions.
480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
& IN(1).GT.IN(2)) GOTO 360
IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
DO 490 J=1,4
DP(1,J)=P(IN(1),J)
DP(2,J)=P(IN(2),J)
DP(3,J)=0D0
DP(4,J)=0D0
490 CONTINUE
DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
DHC12=DFOUR(1,2)
IF(DHC12.LE.1D-2) THEN
P(IN(1)+2,4)=P(IN(1)+2,3)
P(IN(1)+2,1)=0D0
IN(1)=IN(1)+4
GOTO 480
ENDIF
IN(3)=N+NR+4*NS+5
DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
DHCX1=DFOUR(3,1)/DHC12
DHCX2=DFOUR(3,2)/DHC12
DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
DHCY1=DFOUR(4,1)/DHC12
DHCY2=DFOUR(4,2)/DHC12
DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
DO 500 J=1,4
DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
P(IN(3),J)=DP(3,J)
P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
& DHCYX*DP(3,J))
500 CONTINUE
C...Express pT with respect to new axes, if sensible.
PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
PX(3)=PXP
PY(3)=PYP
ENDIF
ENDIF
C...Junction strings: sum up known four-momentum, coefficients for m2.
DO 530 J=1,4
DHG(J)=0D0
P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
& PY(3)*P(IN(3)+1,J)
DO 510 IN1=IN(4),IN(1)-4,4
P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
510 CONTINUE
DO 520 IN2=IN(5),IN(2)-4,4
P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
520 CONTINUE
530 CONTINUE
DHM(1)=FOUR(I,I)
DHM(2)=2D0*FOUR(I,IN(1))
DHM(3)=2D0*FOUR(I,IN(2))
DHM(4)=2D0*FOUR(IN(1),IN(2))
C...Junction strings: find coefficients for Gamma expression.
DO 550 IN2=IN(1)+1,IN(2),4
DO 540 IN1=IN(1),IN2-1,4
DHC=2D0*FOUR(IN1,IN2)
DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
540 CONTINUE
550 CONTINUE
C...Junction strings: solve (m2, Gamma) equation system for energies.
DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
IF(ABS(DHS1).LT.1D-4) GOTO 360
DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
& (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
& ABS(DHS1)-DHS2/DHS1)
IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
& (DHM(2)+DHM(4)*P(IN(2)+2,4))
C...Junction strings: step to new region if necessary.
IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
P(IN(2)+2,4)=P(IN(2)+2,3)
P(IN(2)+2,1)=1D0
IN(2)=IN(2)+4
IF(IN(2).GT.N+NR+4*NS) GOTO 360
IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
P(IN(1)+2,4)=P(IN(1)+2,3)
P(IN(1)+2,1)=0D0
IN(1)=IN(1)+4
ENDIF
GOTO 480
ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
P(IN(1)+2,4)=P(IN(1)+2,3)
P(IN(1)+2,1)=0D0
IN(1)=IN(1)+4
GOTO 480
ENDIF
C...Junction strings: particle four-momentum, remainder, loop back.
560 DO 570 J=1,4
P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
& P(IN(2)+2,4)*P(IN(2),J)
PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
570 CONTINUE
IF(P(I,4).LT.P(I,5)) GOTO 360
PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
& TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
KFL(1)=-KFL(3)
PX(1)=-PX(3)
PY(1)=-PY(3)
GAM(1)=GAM(3)
IF(IN(3).NE.IN(6)) THEN
DO 580 J=1,4
P(IN(6),J)=P(IN(3),J)
P(IN(6)+1,J)=P(IN(3)+1,J)
580 CONTINUE
ENDIF
DO 590 JQ=1,2
IN(3+JQ)=IN(JQ)
P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
590 CONTINUE
GOTO 430
ENDIF
C...Junction strings: save quantities left after each string.
IF(IABS(KFL(1)).GT.10) GOTO 360
600 I=I-1
KFJH(IU)=KFL(1)
DO 610 J=1,4
PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
610 CONTINUE
C...Junction strings: loopback if much unused energy in both strings.
PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
& TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
620 CONTINUE
IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
& EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
& EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
& .AND.NTRYER.LT.10) GOTO 320
C...Junction strings: put together to new effective string endpoint.
NJS(JT)=I-ISTA
KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
IF(KFJH(1).EQ.KFJH(2)) KFLS=3
KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
& 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
DO 630 J=1,4
PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
630 CONTINUE
PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
& PJS(JT,3)**2))
PJS(JT+2,5)=0D0
640 CONTINUE
C...Open versus closed strings. Choose breakup region for latter.
650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
NS=MJU(2)-MJU(1)
NB=MJU(1)-N
ELSEIF(MJU(1).NE.0) THEN
NS=N+NR-MJU(1)
NB=MJU(1)-N
ELSEIF(MJU(2).NE.0) THEN
NS=MJU(2)-N
NB=1
ELSEIF(IABS(K(N+1,2)).NE.21) THEN
NS=NR-1
NB=1
ELSE
NS=NR+1
W2SUM=0D0
DO 660 IS=1,NR
P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
W2SUM=W2SUM+P(N+NR+IS,1)
660 CONTINUE
W2RAN=PYR(0)*W2SUM
NB=0
670 NB=NB+1
W2SUM=W2SUM-P(N+NR+NB,1)
IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
ENDIF
C...Find longitudinal string directions (i.e. lightlike four-vectors).
DO 700 IS=1,NS
IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
IS2=N+IS+NB-NR*((IS+NB-1)/NR)
DO 680 J=1,5
DP(1,J)=P(IS1,J)
IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
DP(2,J)=P(IS2,J)
IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
680 CONTINUE
IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
& DP(1,2)**2-DP(1,3)**2))
IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
& DP(2,2)**2-DP(2,3)**2))
DP(3,5)=DFOUR(1,1)
DP(4,5)=DFOUR(2,2)
DHKC=DFOUR(1,2)
IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
IN1=N+NR+4*IS-3
P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
DO 690 J=1,4
P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
690 CONTINUE
700 CONTINUE
C...Begin initialization: sum up energy, set starting position.
ISAV=I
MSTU91=MSTU(90)
710 NTRY=NTRY+1
IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
PARU12=4D0*PARU12
PARU13=2D0*PARU13
GOTO 140
ELSEIF(NTRY.GT.100) THEN
CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
I=ISAV
MSTU(90)=MSTU91
DO 730 J=1,4
P(N+NRS,J)=0D0
DO 720 IS=1,NR
P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
720 CONTINUE
730 CONTINUE
DO 750 JT=1,2
IRANK(JT)=0
IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
IF(NS.GT.NR) IRANK(JT)=1
IBARRK(JT)=0
IE(JT)=K(N+1+(JT/2)*(NP-1),3)
IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
IN(3*JT+2)=IN(3*JT+1)+1
IN(3*JT+3)=N+NR+4*NS+2*JT-1
DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
P(IN1,1)=2-JT
P(IN1,2)=JT-1
P(IN1,3)=1D0
740 CONTINUE
750 CONTINUE
C.. MOPS variables and switches
NRVMO=0
XBMO=1D0
MSTU(121)=0
MSTU(122)=0
C...Initialize flavour and pT variables for open string.
IF(NS.LT.NR) THEN
PX(1)=0D0
PY(1)=0D0
IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
PX(2)=-PX(1)
PY(2)=-PY(1)
DO 760 JT=1,2
KFL(JT)=K(IE(JT),2)
IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
MSTJ(93)=1
PMQ(JT)=PYMASS(KFL(JT))
GAM(JT)=0D0
760 CONTINUE
C...Closed string: random initial breakup flavour, pT and vertex.
ELSE
KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
IBMO=0
770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
C.. Closed string: first vertex diq attempt => enforced second
C.. vertex diq
IF(IABS(KFL(1)).GT.10)THEN
IBMO=1
MSTU(121)=0
GOTO 770
ENDIF
IF(IBMO.EQ.1) MSTU(121)=-1
KFL(2)=-KFL(1)
CALL PYPTDI(KFL(1),PX(1),PY(1))
PX(2)=-PX(1)
PY(2)=-PY(1)
PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
ZR=PR3/(Z*P(N+NR+1,5)**2)
IF(ZR.GE.1D0) GOTO 780
DO 790 JT=1,2
MSTJ(93)=1
PMQ(JT)=PYMASS(KFL(JT))
GAM(JT)=PR3*(1D0-Z)/Z
IN1=N+NR+3+4*(JT/2)*(NS-1)
P(IN1,JT)=1D0-Z
P(IN1,3-JT)=JT-1
P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
P(IN1+1,JT)=ZR
P(IN1+1,3-JT)=2-JT
P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
790 CONTINUE
ENDIF
C.. MOPS variables
DO 800 JT=1,2
XTMO(JT)=1D0
PM2QMO(JT)=PMQ(JT)**2
IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
800 CONTINUE
C...Find initial transverse directions (i.e. spacelike four-vectors).
DO 840 JT=1,2
IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
IN1=IN(3*JT+1)
IN3=IN(3*JT+3)
DO 810 J=1,4
DP(1,J)=P(IN1,J)
DP(2,J)=P(IN1+1,J)
DP(3,J)=0D0
DP(4,J)=0D0
810 CONTINUE
DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
DHC12=DFOUR(1,2)
DHCX1=DFOUR(3,1)/DHC12
DHCX2=DFOUR(3,2)/DHC12
DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
DHCY1=DFOUR(4,1)/DHC12
DHCY2=DFOUR(4,2)/DHC12
DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
DO 820 J=1,4
DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
P(IN3,J)=DP(3,J)
P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
& DHCYX*DP(3,J))
820 CONTINUE
ELSE
DO 830 J=1,4
P(IN3+2,J)=P(IN3,J)
P(IN3+3,J)=P(IN3+1,J)
830 CONTINUE
ENDIF
840 CONTINUE
C...Remove energy used up in junction string fragmentation.
IF(MJU(1)+MJU(2).GT.0) THEN
DO 860 JT=1,2
IF(NJS(JT).EQ.0) GOTO 860
DO 850 J=1,4
P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
850 CONTINUE
860 CONTINUE
PARJST=PARJ(33)
IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
WMIN=PARJST+PMQ(1)+PMQ(2)
WREM2=FOUR(N+NRS,N+NRS)
IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
NTRYWR=NTRYWR+1
IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
GOTO 140
ENDIF
ENDIF
C...Produce new particle: side, origin.
870 I=I+1
IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) RETURN
ENDIF
C.. New side priority for popcorn systems
IF(MSTU(121).LE.0)THEN
JT=1.5D0+PYR(0)
IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
ENDIF
JR=3-JT
JS=3-2*JT
IRANK(JT)=IRANK(JT)+1
K(I,1)=1
K(I,4)=0
K(I,5)=0
C...Generate flavour, hadron and pT.
880 K(I,3)=IE(JT)
CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
IF(K(I,2).EQ.0) GOTO 710
MU90MO=MSTU(90)
IF(MSTU(121).EQ.-1) GOTO 910
IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
&IABS(KFL(3)).GT.10) THEN
IF(PYR(0).GT.PARJ(19)) GOTO 880
ENDIF
IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
&K(I,3)=IJUORI(JT)
P(I,5)=PYMASS(K(I,2))
CALL PYPTDI(KFL(JT),PX(3),PY(3))
PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
C...Final hadrons for small invariant mass.
MSTJ(93)=1
PMQ(3)=PYMASS(KFL(3))
PARJST=PARJ(33)
IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
&WMIN-0.5D0*PARJ(36)*PMQ(3)
WREM2=FOUR(N+NRS,N+NRS)
IF(WREM2.LT.0.10D0) GOTO 710
IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
&PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
C...Choose z, which gives Gamma. Shift z for heavy flavours.
CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
&MSTU(90).LT.8) THEN
MSTU(90)=MSTU(90)+1
MSTU(90+MSTU(90))=I
PARU(90+MSTU(90))=Z
ENDIF
KFL1A=IABS(KFL(1))
KFL2A=IABS(KFL(2))
IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
&MOD(KFL2A/1000,10)).GE.4) THEN
PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
ENDIF
GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
C.. MOPS baryon model modification
XTMO3=(1D0-Z)*XTMO(JT)
IF(IABS(KFL(3)).LE.10) NRVMO=0
IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
GTSTMO=1D0
PTSTMO=1D0
RTSTMO=PYR(0)
IF(IABS(KFL(JT)).LE.10)THEN
XBMO=MIN(XTMO3,1D0-(2D-10))
GBMO=GAM(3)
PMMO=0D0
PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
GTSTMO=1D0-PARF(192)**PGMO
ELSE
IF(IRANK(JT).EQ.1) THEN
GBMO=GAM(JT)
PMMO=0D0
XBMO=1D0
ENDIF
IF(XBMO.LT.1D0-(1D-10))THEN
PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
PGMO=PGNMO
ENDIF
IF(MSTJ(12).GE.5)THEN
PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
PMMO=PMNMO
ENDIF
ENDIF
C.. MOPS Accepting popcorn system hadron.
IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
NRVMO=I-N-NR
IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
CALL PYERRM(11,
& '(PYSTRF:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) RETURN
ENDIF
IMO=I
KFLMO=KFL(JT)
PMQMO=PMQ(JT)
PXMO=PX(JT)
PYMO=PY(JT)
GAMMO=GAM(JT)
IRMO=IRANK(JT)
XMO=XTMO(JT)
DO 900 J=1,9
IF(J.LE.5) THEN
DO 890 LINE=1,I-N-NR
P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
890 CONTINUE
ENDIF
INMO(J)=IN(J)
900 CONTINUE
ENDIF
ELSE
C..Reject popcorn system, flag=-1 if enforcing new one
MSTU(121)=-1
IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
ENDIF
ENDIF
C..Lift restoring string outside MOPS block
910 IF(MSTU(121).LT.0) THEN
IF(MSTU(121).EQ.-2) MSTU(121)=0
MSTU(90)=MU90MO
NRVMO=0
IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
I=IMO
KFL(JT)=KFLMO
PMQ(JT)=PMQMO
PX(JT)=PXMO
PY(JT)=PYMO
GAM(JT)=GAMMO
IRANK(JT)=IRMO
XTMO(JT)=XMO
DO 930 J=1,9
IF(J.LE.5) THEN
DO 920 LINE=1,I-N-NR
P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
920 CONTINUE
ENDIF
IN(J)=INMO(J)
930 CONTINUE
GOTO 880
ENDIF
XTMO(JT)=XTMO3
C.. MOPS end of modification
DO 940 J=1,3
IN(J)=IN(3*JT+J)
940 CONTINUE
C...Stepping within or from 'low' string region easy.
IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
&P(IN(1),5)**2.GE.PR(JT)) THEN
P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
DO 950 J=1,4
P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
950 CONTINUE
GOTO 1040
ELSEIF(IN(1)+1.EQ.IN(2)) THEN
P(IN(JR)+2,4)=P(IN(JR)+2,3)
P(IN(JR)+2,JT)=1D0
IN(JR)=IN(JR)+4*JS
IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
P(IN(JT)+2,4)=P(IN(JT)+2,3)
P(IN(JT)+2,JT)=0D0
IN(JT)=IN(JT)+4*JS
ENDIF
ENDIF
C...Find new transverse directions (i.e. spacelike string vectors).
960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
&IN(1).GT.IN(2)) GOTO 710
IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
DO 970 J=1,4
DP(1,J)=P(IN(1),J)
DP(2,J)=P(IN(2),J)
DP(3,J)=0D0
DP(4,J)=0D0
970 CONTINUE
DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
DHC12=DFOUR(1,2)
IF(DHC12.LE.1D-2) THEN
P(IN(JT)+2,4)=P(IN(JT)+2,3)
P(IN(JT)+2,JT)=0D0
IN(JT)=IN(JT)+4*JS
GOTO 960
ENDIF
IN(3)=N+NR+4*NS+5
DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
DHCX1=DFOUR(3,1)/DHC12
DHCX2=DFOUR(3,2)/DHC12
DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
DHCY1=DFOUR(4,1)/DHC12
DHCY2=DFOUR(4,2)/DHC12
DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
DO 980 J=1,4
DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
P(IN(3),J)=DP(3,J)
P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
& DHCYX*DP(3,J))
980 CONTINUE
C...Express pT with respect to new axes, if sensible.
PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
& FOUR(IN(3*JT+3)+1,IN(3)))
PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
& FOUR(IN(3*JT+3)+1,IN(3)+1))
IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
PX(3)=PXP
PY(3)=PYP
ENDIF
ENDIF
C...Sum up known four-momentum. Gives coefficients for m2 expression.
DO 1010 J=1,4
DHG(J)=0D0
P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
& PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
990 CONTINUE
DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1000 CONTINUE
1010 CONTINUE
DHM(1)=FOUR(I,I)
DHM(2)=2D0*FOUR(I,IN(1))
DHM(3)=2D0*FOUR(I,IN(2))
DHM(4)=2D0*FOUR(IN(1),IN(2))
C...Find coefficients for Gamma expression.
DO 1030 IN2=IN(1)+1,IN(2),4
DO 1020 IN1=IN(1),IN2-1,4
DHC=2D0*FOUR(IN1,IN2)
DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1020 CONTINUE
1030 CONTINUE
C...Solve (m2, Gamma) equation system for energies taken.
DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
IF(ABS(DHS1).LT.1D-4) GOTO 710
DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
&(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
&ABS(DHS1)-DHS2/DHS1)
IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
&(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
C...Step to new region if necessary.
IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
P(IN(JR)+2,4)=P(IN(JR)+2,3)
P(IN(JR)+2,JT)=1D0
IN(JR)=IN(JR)+4*JS
IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
P(IN(JT)+2,4)=P(IN(JT)+2,3)
P(IN(JT)+2,JT)=0D0
IN(JT)=IN(JT)+4*JS
ENDIF
GOTO 960
ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
P(IN(JT)+2,4)=P(IN(JT)+2,3)
P(IN(JT)+2,JT)=0D0
IN(JT)=IN(JT)+4*JS
GOTO 960
ENDIF
C...Four-momentum of particle. Remaining quantities. Loop back.
1040 DO 1050 J=1,4
P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
P(N+NRS,J)=P(N+NRS,J)-P(I,J)
1050 CONTINUE
IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
&P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
&GOTO 200
IF(P(I,4).LT.P(I,5)) GOTO 710
KFL(JT)=-KFL(3)
PMQ(JT)=PMQ(3)
PX(JT)=-PX(3)
PY(JT)=-PY(3)
GAM(JT)=GAM(3)
IF(IN(3).NE.IN(3*JT+3)) THEN
DO 1060 J=1,4
P(IN(3*JT+3),J)=P(IN(3),J)
P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
1060 CONTINUE
ENDIF
DO 1070 JQ=1,2
IN(3*JT+JQ)=IN(JQ)
P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
1070 CONTINUE
IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
&IBARRK(JT)=0
GOTO 870
C...Final hadron: side, flavour, hadron, mass.
1080 I=I+1
K(I,1)=1
K(I,3)=IE(JR)
K(I,4)=0
K(I,5)=0
CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
IF(K(I,2).EQ.0) GOTO 710
IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
&IBARRK(JT)=0
IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
&K(I,3)=IJUORI(JT)
IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
&K(I,3)=IJUORI(JR)
P(I,5)=PYMASS(K(I,2))
PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
C...Final two hadrons: find common setup of four-vectors.
JQ=1
IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
&P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
& PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
ENDIF
C...Solve kinematics for final two hadrons, if possible.
WREM2=2D0*DHR1*DHR2*DHC12
FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
IF(FD.GE.1D0) GOTO 710
FA=WREM2+PR(JT)-PR(JR)
FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
PREVCF=PARJ(42)
IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
FB=SIGN(FB,JS*(PYR(0)-PREV))
KFL1A=IABS(KFL(1))
KFL2A=IABS(KFL(2))
IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
&MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
&4D0*WREM2*PR(JT))),DBLE(JS))
DO 1090 J=1,4
P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
& P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
& DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
P(I,J)=P(N+NRS,J)-P(I-1,J)
1090 CONTINUE
IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2
DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
NTRYFN=NTRYFN+1
IF(NTRYFN.LT.100) GOTO 140
CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
ENDIF
C...Mark jets as fragmented and give daughter pointers.
N=I-NRS+1
DO 1100 I=NSAV+1,NSAV+NP
IM=K(I,3)
K(IM,1)=K(IM,1)+10
IF(MSTU(16).NE.2) THEN
K(IM,4)=NSAV+1
K(IM,5)=NSAV+1
ELSE
K(IM,4)=NSAV+2
K(IM,5)=N
ENDIF
1100 CONTINUE
C...Document string system. Move up particles.
NSAV=NSAV+1
K(NSAV,1)=11
K(NSAV,2)=92
K(NSAV,3)=IP
K(NSAV,4)=NSAV+1
K(NSAV,5)=N
DO 1110 J=1,4
P(NSAV,J)=DPS(J)
V(NSAV,J)=V(IP,J)
1110 CONTINUE
P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
V(NSAV,5)=0D0
DO 1130 I=NSAV+1,N
DO 1120 J=1,5
K(I,J)=K(I+NRS-1,J)
P(I,J)=P(I+NRS-1,J)
V(I,J)=0D0
1120 CONTINUE
1130 CONTINUE
MSTU91=MSTU(90)
DO 1140 IZ=MSTU90+1,MSTU91
MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
PARU9T(IZ)=PARU(90+IZ)
1140 CONTINUE
MSTU(90)=MSTU90
C...Order particles in rank along the chain. Update mother pointer.
DO 1160 I=NSAV+1,N
DO 1150 J=1,5
K(I-NSAV+N,J)=K(I,J)
P(I-NSAV+N,J)=P(I,J)
1150 CONTINUE
1160 CONTINUE
I1=NSAV
DO 1190 I=N+1,2*N-NSAV
IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
I1=I1+1
DO 1170 J=1,5
K(I1,J)=K(I,J)
P(I1,J)=P(I,J)
1170 CONTINUE
IF(MSTU(16).NE.2) K(I1,3)=NSAV
DO 1180 IZ=MSTU90+1,MSTU91
IF(MSTU9T(IZ).EQ.I) THEN
MSTU(90)=MSTU(90)+1
MSTU(90+MSTU(90))=I1
PARU(90+MSTU(90))=PARU9T(IZ)
ENDIF
1180 CONTINUE
1190 CONTINUE
DO 1220 I=2*N-NSAV,N+1,-1
IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
I1=I1+1
DO 1200 J=1,5
K(I1,J)=K(I,J)
P(I1,J)=P(I,J)
1200 CONTINUE
IF(MSTU(16).NE.2) K(I1,3)=NSAV
DO 1210 IZ=MSTU90+1,MSTU91
IF(MSTU9T(IZ).EQ.I) THEN
MSTU(90)=MSTU(90)+1
MSTU(90+MSTU(90))=I1
PARU(90+MSTU(90))=PARU9T(IZ)
ENDIF
1210 CONTINUE
1220 CONTINUE
C...Boost back particle system. Set production vertices.
IF(MBST.EQ.0) THEN
MSTU(33)=1
CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
& DPS(3)/DPS(4))
ELSE
DO 1230 I=NSAV+1,N
HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
IF(P(I,3).GT.0D0) THEN
HHPEZ=(P(I,4)+P(I,3))*HHBZ
P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
ELSE
HHPEZ=(P(I,4)-P(I,3))/HHBZ
P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
ENDIF
1230 CONTINUE
ENDIF
DO 1250 I=NSAV+1,N
DO 1240 J=1,4
V(I,J)=V(IP,J)
1240 CONTINUE
1250 CONTINUE
RETURN
END
C*********************************************************************
C...PYJURF
C...From three given input vectors in PJU the boost VJU from
C...the "lab frame" to the junction rest frame is constructed.
SUBROUTINE PYJURF(PJU,VJU)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...Input, output and local arrays.
DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
DATA TWOPI/6.283186D0/
C...Calculate masses and other invariants.
DO 100 J=1,4
PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
100 CONTINUE
PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
PSUM(5)=SQRT(PSUM2)
DO 120 I=1,3
DO 110 J=1,3
A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
& PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
110 CONTINUE
120 CONTINUE
C...Pick I to be most massive parton and J to be the one closest to I.
ITRY=0
I=1
IF(A(2,2).GT.A(1,1)) I=2
IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
130 ITRY=ITRY+1
J=1+MOD(I,3)
K=1+MOD(J,3)
IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
K=1+MOD(I,3)
J=1+MOD(K,3)
ENDIF
PMI2=A(I,I)
PMJ2=A(J,J)
PMK2=A(K,K)
AIJ=A(I,J)
AIK=A(I,K)
AJK=A(J,K)
C...Trivial find new parton energies if all three partons are massless.
IF(PMI2.LT.1D-4) THEN
PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
C...Else find momentum range for parton I and values at extremes.
ELSE
PAIMIN=0D0
PEIMIN=SQRT(PMI2)
PEJMIN=AIJ/PEIMIN
PEKMIN=AIK/PEIMIN
PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
HI=PEIMAX**2-0.25D0*PAIMAX**2
PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
& 0.5D0*PAIMAX*AIJ)/HI
PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
& 0.5D0*PAIMAX*AIK)/HI
PEJMAX=SQRT(PAJMAX**2+PMJ2)
PEKMAX=SQRT(PAKMAX**2+PMK2)
FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
C...If unexpected values at upper endpoint then pick another parton.
IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
I1=1+MOD(I,3)
IF(A(I1,I1).GE.1D-4) THEN
I=I1
GOTO 130
ENDIF
ITRY=ITRY+1
I1=1+MOD(I,3)
IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
I=I1
GOTO 130
ENDIF
ENDIF
C..Start binary + linear search to find solution inside range.
ITER=0
ITMIN=0
ITMAX=0
PAI=0.5D0*(PAIMIN+PAIMAX)
140 ITER=ITER+1
C...Derive momentum of other two partons and distance to root.
PEI=SQRT(PAI**2+PMI2)
HI=PEI**2-0.25D0*PAI**2
PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
PEJ=SQRT(PAJ**2+PMJ2)
PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
PEK=SQRT(PAK**2+PMK2)
FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
C...Pick next I momentum to explore, hopefully closer to root.
IF(FNOW.GT.0D0) THEN
PAIMIN=PAI
FMIN=FNOW
ITMIN=ITMIN+1
ELSE
PAIMAX=PAI
FMAX=FNOW
ITMAX=ITMAX+1
ENDIF
IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
& THEN
PAI=0.5D0*(PAIMIN+PAIMAX)
GOTO 140
ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
& ABS(FNOW).GT.1D-12*PSUM2) THEN
PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
GOTO 140
ENDIF
ENDIF
C...Now know energies in junction rest frame.
PENEW(I)=PEI
PENEW(J)=PEJ
PENEW(K)=PEK
C...Boost (copy of) partons to their rest frame.
VXCM=-PSUM(1)/PSUM(5)
VYCM=-PSUM(2)/PSUM(5)
VZCM=-PSUM(3)/PSUM(5)
GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
DO 150 I=1,3
FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
PCM(I,1)=PJU(I,1)+FAC2*VXCM
PCM(I,2)=PJU(I,2)+FAC2*VYCM
PCM(I,3)=PJU(I,3)+FAC2*VZCM
PCM(I,4)=PJU(I,4)*GAMCM+FAC1
PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
150 CONTINUE
C...Construct difference vectors and boost to junction rest frame.
DO 160 J=1,3
PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
160 CONTINUE
PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
VXJU=C4*PCM(4,1)+C5*PCM(5,1)
VYJU=C4*PCM(4,2)+C5*PCM(5,2)
VZJU=C4*PCM(4,3)+C5*PCM(5,3)
GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
C...Add two boosts, giving final result.
FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
VJU(1)=VXJU+FCM*VXCM
VJU(2)=VYJU+FCM*VYCM
VJU(3)=VZJU+FCM*VZCM
VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
VJU(5)=1D0
C...In case of error in reconstruction: revert to CM frame of system.
CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
&(PCM(1,5)*PCM(2,5))
CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
&(PCM(1,5)*PCM(3,5))
CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
&(PCM(2,5)*PCM(3,5))
ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
DO 170 I=1,3
FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
170 CONTINUE
CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
&(PCM(1,5)*PCM(2,5))
CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
&(PCM(1,5)*PCM(3,5))
CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
&(PCM(2,5)*PCM(3,5))
ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
VJU(1)=VXCM
VJU(2)=VYCM
VJU(3)=VZCM
VJU(4)=GAMCM
ENDIF
RETURN
END
C*********************************************************************
C...PYINDF
C...Handles the fragmentation of a jet system (or a single
C...jet) according to independent fragmentation models.
SUBROUTINE PYINDF(IP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Local arrays.
DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
&KFLO(2),PXO(2),PYO(2),WO(2)
C.. MOPS error message
IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
&' are not treated as expected in independent fragmentation')
C...Reset counters. Identify parton system and take copy. Check flavour.
NSAV=N
MSTU90=MSTU(90)
NJET=0
KQSUM=0
DO 100 J=1,5
DPS(J)=0D0
100 CONTINUE
I=IP-1
110 I=I+1
IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
IF(MSTU(21).GE.1) RETURN
ENDIF
IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
KC=PYCOMP(K(I,2))
IF(KC.EQ.0) GOTO 110
KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
IF(KQ.EQ.0) GOTO 110
NJET=NJET+1
IF(KQ.NE.2) KQSUM=KQSUM+KQ
DO 120 J=1,5
K(NSAV+NJET,J)=K(I,J)
P(NSAV+NJET,J)=P(I,J)
DPS(J)=DPS(J)+P(I,J)
120 CONTINUE
K(NSAV+NJET,3)=I
IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
&K(I+1,1).EQ.2)) GOTO 110
IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
IF(MSTU(21).GE.1) RETURN
ENDIF
C...Boost copied system to CM frame. Find CM energy and sum flavours.
IF(NJET.NE.1) THEN
MSTU(33)=1
CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
& -DPS(2)/DPS(4),-DPS(3)/DPS(4))
ENDIF
PECM=0D0
DO 130 J=1,3
NFI(J)=0
130 CONTINUE
DO 140 I=NSAV+1,NSAV+NJET
PECM=PECM+P(I,4)
KFA=IABS(K(I,2))
IF(KFA.LE.3) THEN
NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
ELSEIF(KFA.GT.1000) THEN
KFLA=MOD(KFA/1000,10)
KFLB=MOD(KFA/100,10)
IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
ENDIF
140 CONTINUE
C...Loop over attempts made. Reset counters.
NTRY=0
150 NTRY=NTRY+1
IF(NTRY.GT.200) THEN
CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
N=NSAV+NJET
MSTU(90)=MSTU90
DO 160 J=1,3
NFL(J)=NFI(J)
IFET(J)=0
KFLF(J)=0
160 CONTINUE
C...Loop over jets to be fragmented.
DO 230 IP1=NSAV+1,NSAV+NJET
MSTJ(91)=0
NSAV1=N
MSTU91=MSTU(90)
C...Initial flavour and momentum values. Jet along +z axis.
KFLH=IABS(K(IP1,2))
IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
KFLO(2)=0
WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
C...Initial values for quark or diquark jet.
170 IF(IABS(K(IP1,2)).NE.21) THEN
NSTR=1
KFLO(1)=K(IP1,2)
CALL PYPTDI(0,PXO(1),PYO(1))
WO(1)=WF
C...Initial values for gluon treated like random quark jet.
ELSEIF(MSTJ(2).LE.2) THEN
NSTR=1
IF(MSTJ(2).EQ.2) MSTJ(91)=1
KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
CALL PYPTDI(0,PXO(1),PYO(1))
WO(1)=WF
C...Initial values for gluon treated like quark-antiquark jet pair,
C...sharing energy according to Altarelli-Parisi splitting function.
ELSE
NSTR=2
IF(MSTJ(2).EQ.4) MSTJ(91)=1
KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
KFLO(2)=-KFLO(1)
CALL PYPTDI(0,PXO(1),PYO(1))
PXO(2)=-PXO(1)
PYO(2)=-PYO(1)
WO(1)=WF*PYR(0)**(1D0/3D0)
WO(2)=WF-WO(1)
ENDIF
C...Initial values for rank, flavour, pT and W+.
DO 220 ISTR=1,NSTR
180 I=N
MSTU(90)=MSTU91
IRANK=0
KFL1=KFLO(ISTR)
PX1=PXO(ISTR)
PY1=PYO(ISTR)
W=WO(ISTR)
C...New hadron. Generate flavour and hadron species.
190 I=I+1
IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
IF(MSTU(21).GE.1) RETURN
ENDIF
IRANK=IRANK+1
K(I,1)=1
K(I,3)=IP1
K(I,4)=0
K(I,5)=0
200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
IF(K(I,2).EQ.0) GOTO 180
IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
IF(PYR(0).GT.PARJ(19)) GOTO 200
ENDIF
C...Find hadron mass. Generate four-momentum.
P(I,5)=PYMASS(K(I,2))
CALL PYPTDI(KFL1,PX2,PY2)
P(I,1)=PX1+PX2
P(I,2)=PY1+PY2
PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
CALL PYZDIS(KFL1,KFL2,PR,Z)
MZSAV=0
IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
MZSAV=1
MSTU(90)=MSTU(90)+1
MSTU(90+MSTU(90))=I
PARU(90+MSTU(90))=Z
ENDIF
P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
& P(I,3).LE.0.001D0) THEN
IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
P(I,3)=0.0001D0
P(I,4)=SQRT(PR)
Z=P(I,4)/W
ENDIF
C...Remaining flavour and momentum.
KFL1=-KFL2
PX1=-PX2
PY1=-PY2
W=(1D0-Z)*W
DO 210 J=1,5
V(I,J)=0D0
210 CONTINUE
C...Check if pL acceptable. Go back for new hadron if enough energy.
IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
I=I-1
IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
ENDIF
IF(W.GT.PARJ(31)) GOTO 190
N=I
220 CONTINUE
IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
C...Rotate jet to new direction.
THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
PHI=PYANGL(P(IP1,1),P(IP1,2))
MSTU(33)=1
CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
K(K(IP1,3),4)=NSAV1+1
K(K(IP1,3),5)=N
C...End of jet generation loop. Skip conservation in some cases.
230 CONTINUE
IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
C...Subtract off produced hadron flavours, finished if zero.
DO 240 I=NSAV+NJET+1,N
KFA=IABS(K(I,2))
KFLA=MOD(KFA/1000,10)
KFLB=MOD(KFA/100,10)
KFLC=MOD(KFA/10,10)
IF(KFLA.EQ.0) THEN
IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
ELSE
IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
ENDIF
240 CONTINUE
NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
&NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
IF(NREQ.EQ.0) GOTO 320
C...Take away flavour of low-momentum particles until enough freedom.
NREM=0
250 IREM=0
P2MIN=PECM**2
DO 260 I=NSAV+NJET+1,N
P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
260 CONTINUE
IF(IREM.EQ.0) GOTO 150
K(IREM,1)=7
KFA=IABS(K(IREM,2))
KFLA=MOD(KFA/1000,10)
KFLB=MOD(KFA/100,10)
KFLC=MOD(KFA/10,10)
IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
IF(K(IREM,1).EQ.8) GOTO 250
IF(KFLA.EQ.0) THEN
ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
ELSE
IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
ENDIF
NREM=NREM+1
NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
&NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
IF(NREQ.GT.NREM) GOTO 250
DO 270 I=NSAV+NJET+1,N
IF(K(I,1).EQ.8) K(I,1)=1
270 CONTINUE
C...Find combination of existing and new flavours for hadron.
280 NFET=2
IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
IF(NREQ.LT.NREM) NFET=1
IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
DO 290 J=1,NFET
IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
KFLF(J)=ISIGN(1,NFL(1))
IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
290 CONTINUE
IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
&GOTO 280
IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
&IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
&.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
IF(NFET.LE.2) KFLF(3)=0
IF(KFLF(3).NE.0) THEN
KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
& 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
& KFLFC=KFLFC+ISIGN(2,KFLFC)
ELSE
KFLFC=KFLF(1)
ENDIF
CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
IF(KF.EQ.0) GOTO 280
DO 300 J=1,MAX(2,NFET)
NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
300 CONTINUE
C...Store hadron at random among free positions.
NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
DO 310 I=NSAV+NJET+1,N
IF(K(I,1).EQ.7) NPOS=NPOS-1
IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
K(I,1)=1
K(I,2)=KF
P(I,5)=PYMASS(K(I,2))
P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
310 CONTINUE
NREM=NREM-1
NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
&NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
IF(NREM.GT.0) GOTO 280
C...Compensate for missing momentum in global scheme (3 options).
320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
DO 340 J=1,3
PSI(J)=0D0
DO 330 I=NSAV+NJET+1,N
PSI(J)=PSI(J)+P(I,J)
330 CONTINUE
340 CONTINUE
PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
PWS=0D0
DO 350 I=NSAV+NJET+1,N
IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
& PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
350 CONTINUE
DO 370 I=NSAV+NJET+1,N
IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
& PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
DO 360 J=1,3
P(I,J)=P(I,J)-PSI(J)*PW/PWS
360 CONTINUE
P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
370 CONTINUE
C...Compensate for missing momentum withing each jet separately.
ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
DO 390 I=N+1,N+NJET
K(I,1)=0
DO 380 J=1,5
P(I,J)=0D0
380 CONTINUE
390 CONTINUE
DO 410 I=NSAV+NJET+1,N
IR1=K(I,3)
IR2=N+IR1-NSAV
K(IR2,1)=K(IR2,1)+1
PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
& (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
DO 400 J=1,3
P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
400 CONTINUE
P(IR2,4)=P(IR2,4)+P(I,4)
P(IR2,5)=P(IR2,5)+PLS
410 CONTINUE
PSS=0D0
DO 420 I=N+1,N+NJET
IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
420 CONTINUE
DO 440 I=NSAV+NJET+1,N
IR1=K(I,3)
IR2=N+IR1-NSAV
PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
& (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
DO 430 J=1,3
P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
& PLS*P(IR1,J)
430 CONTINUE
P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
440 CONTINUE
ENDIF
C...Scale momenta for energy conservation.
IF(MOD(MSTJ(3),5).NE.0) THEN
PMS=0D0
PES=0D0
PQS=0D0
DO 450 I=NSAV+NJET+1,N
PMS=PMS+P(I,5)
PES=PES+P(I,4)
PQS=PQS+P(I,5)**2/P(I,4)
450 CONTINUE
IF(PMS.GE.PECM) GOTO 150
NECO=0
460 NECO=NECO+1
PFAC=(PECM-PQS)/(PES-PQS)
PES=0D0
PQS=0D0
DO 480 I=NSAV+NJET+1,N
DO 470 J=1,3
P(I,J)=PFAC*P(I,J)
470 CONTINUE
P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
PES=PES+P(I,4)
PQS=PQS+P(I,5)**2/P(I,4)
480 CONTINUE
IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
ENDIF
C...Origin of produced particles and parton daughter pointers.
490 DO 500 I=NSAV+NJET+1,N
IF(MSTU(16).NE.2) K(I,3)=NSAV+1
IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
500 CONTINUE
DO 510 I=NSAV+1,NSAV+NJET
I1=K(I,3)
K(I1,1)=K(I1,1)+10
IF(MSTU(16).NE.2) THEN
K(I1,4)=NSAV+1
K(I1,5)=NSAV+1
ELSE
K(I1,4)=K(I1,4)-NJET+1
K(I1,5)=K(I1,5)-NJET+1
IF(K(I1,5).LT.K(I1,4)) THEN
K(I1,4)=0
K(I1,5)=0
ENDIF
ENDIF
510 CONTINUE
C...Document independent fragmentation system. Remove copy of jets.
NSAV=NSAV+1
K(NSAV,1)=11
K(NSAV,2)=93
K(NSAV,3)=IP
K(NSAV,4)=NSAV+1
K(NSAV,5)=N-NJET+1
DO 520 J=1,4
P(NSAV,J)=DPS(J)
V(NSAV,J)=V(IP,J)
520 CONTINUE
P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
V(NSAV,5)=0D0
DO 540 I=NSAV+NJET,N
DO 530 J=1,5
K(I-NJET+1,J)=K(I,J)
P(I-NJET+1,J)=P(I,J)
V(I-NJET+1,J)=V(I,J)
530 CONTINUE
540 CONTINUE
N=N-NJET+1
DO 550 IZ=MSTU90+1,MSTU(90)
MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
550 CONTINUE
C...Boost back particle system. Set production vertices.
IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
&DPS(2)/DPS(4),DPS(3)/DPS(4))
DO 570 I=NSAV+1,N
DO 560 J=1,4
V(I,J)=V(IP,J)
560 CONTINUE
570 CONTINUE
RETURN
END
C*********************************************************************
C...PYDECY
C...Handles the decay of unstable particles.
SUBROUTINE PYDECY(IP)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
C...Local arrays.
DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
&WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
CHARACTER CIDC*4
DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
C...Functions: momentum in two-particle decays and four-product.
PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
C...Initial values.
NTRY=0
NSAV=N
KFA=IABS(K(IP,2))
KFS=ISIGN(1,K(IP,2))
KC=PYCOMP(KFA)
MSTJ(92)=0
C...Choose lifetime and determine decay vertex.
IF(K(IP,1).EQ.5) THEN
V(IP,5)=0D0
ELSEIF(K(IP,1).NE.4) THEN
V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
ENDIF
DO 100 J=1,4
VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
100 CONTINUE
C...Determine whether decay allowed or not.
MOUT=0
IF(MSTJ(22).EQ.2) THEN
IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
ELSEIF(MSTJ(22).EQ.3) THEN
IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
ELSEIF(MSTJ(22).EQ.4) THEN
IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
ENDIF
IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
K(IP,1)=4
RETURN
ENDIF
C...Interface to external tau decay library (for tau polarization).
IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
C...Starting values for pointers and momenta.
ITAU=IP
DO 110 J=1,4
PTAU(J)=P(ITAU,J)
PCMTAU(J)=P(ITAU,J)
110 CONTINUE
C...Iterate to find position and code of mother of tau.
IMTAU=ITAU
120 IMTAU=K(IMTAU,3)
IF(IMTAU.EQ.0) THEN
C...If no known origin then impossible to do anything further.
KFORIG=0
IORIG=0
ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
C...If tau -> tau + gamma then add gamma energy and loop.
IF(K(K(IMTAU,4),2).EQ.22) THEN
DO 130 J=1,4
PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
130 CONTINUE
ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
DO 140 J=1,4
PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
140 CONTINUE
ENDIF
GOTO 120
ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
C...If coming from weak decay of hadron then W is not stored in record,
C...but can be reconstructed by adding neutrino momentum.
KFORIG=-ISIGN(24,K(ITAU,2))
IORIG=0
DO 160 II=K(IMTAU,4),K(IMTAU,5)
IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
DO 150 J=1,4
PCMTAU(J)=PCMTAU(J)+P(II,J)
150 CONTINUE
ENDIF
160 CONTINUE
ELSE
C...If coming from resonance decay then find latest copy of this
C...resonance (may not completely agree).
KFORIG=K(IMTAU,2)
IORIG=IMTAU
DO 170 II=IMTAU+1,IP-1
IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
& ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
170 CONTINUE
DO 180 J=1,4
PCMTAU(J)=P(IORIG,J)
180 CONTINUE
ENDIF
C...Boost tau to rest frame of production process (where known)
C...and rotate it to sit along +z axis.
DO 190 J=1,3
DBETAU(J)=PCMTAU(J)/PCMTAU(4)
190 CONTINUE
IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
& -DBETAU(2),-DBETAU(3))
PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
C...Call tau decay routine (if meaningful) and fill extra info.
IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
DO 200 II=NSAV+1,NSAV+NDECAY
K(II,1)=1
K(II,3)=IP
K(II,4)=0
K(II,5)=0
200 CONTINUE
N=NSAV+NDECAY
ENDIF
C...Boost back decay tau and decay products.
DO 210 J=1,4
P(ITAU,J)=PTAU(J)
210 CONTINUE
IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
& DBETAU(2),DBETAU(3))
C...Skip past ordinary tau decay treatment.
MMAT=0
MBST=0
ND=0
GOTO 630
ENDIF
ENDIF
C...B-Bbar mixing: flip sign of meson appropriately.
MMIX=0
IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
XBBMIX=PARJ(76)
IF(KFA.EQ.531) XBBMIX=PARJ(77)
IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
IF(MMIX.EQ.1) KFS=-KFS
ENDIF
C...Check existence of decay channels. Particle/antiparticle rules.
KCA=KC
IF(MDCY(KC,2).GT.0) THEN
MDMDCY=MDME(MDCY(KC,2),2)
IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
ENDIF
IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
CALL PYERRM(9,'(PYDECY:) no decay channel defined')
RETURN
ENDIF
IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
IF(KCHG(KC,3).EQ.0) THEN
KFSP=1
KFSN=0
IF(PYR(0).GT.0.5D0) KFS=-KFS
ELSEIF(KFS.GT.0) THEN
KFSP=1
KFSN=0
ELSE
KFSP=0
KFSN=1
ENDIF
C...Sum branching ratios of allowed decay channels.
220 NOPE=0
BRSU=0D0
DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
& KFSN*MDME(IDL,1).NE.3) GOTO 230
IF(MDME(IDL,2).GT.100) GOTO 230
NOPE=NOPE+1
BRSU=BRSU+BRAT(IDL)
230 CONTINUE
IF(NOPE.EQ.0) THEN
CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
RETURN
ENDIF
C...Select decay channel among allowed ones.
240 RBR=BRSU*PYR(0)
IDL=MDCY(KCA,2)-1
250 IDL=IDL+1
IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
&KFSN*MDME(IDL,1).NE.3) THEN
IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
ELSEIF(MDME(IDL,2).GT.100) THEN
IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
ELSE
IDC=IDL
RBR=RBR-BRAT(IDL)
IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
ENDIF
C...Start readout of decay channel: matrix element, reset counters.
MMAT=MDME(IDC,2)
260 NTRY=NTRY+1
IF(MOD(NTRY,200).EQ.0) THEN
WRITE(CIDC,'(I4)') IDC
C...Do not print warning for some well-known special cases.
IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
& CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
& CIDC)
GOTO 240
ENDIF
IF(NTRY.GT.1000) THEN
CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
I=N
NP=0
NQ=0
MBST=0
IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
DO 270 J=1,4
PV(1,J)=0D0
IF(MBST.EQ.0) PV(1,J)=P(IP,J)
270 CONTINUE
IF(MBST.EQ.1) PV(1,4)=P(IP,5)
PV(1,5)=P(IP,5)
PS=0D0
PSQ=0D0
MREM=0
MHADDY=0
IF(KFA.GT.80) MHADDY=1
C.. Random flavour and popcorn system memory.
IRNDMO=0
JTMO=0
MSTU(121)=0
MSTU(125)=10
C...Read out decay products. Convert to standard flavour code.
JTMAX=5
IF(MDME(IDC+1,2).EQ.101) JTMAX=10
DO 280 JT=1,JTMAX
IF(JT.LE.5) KP=KFDP(IDC,JT)
IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
IF(KP.EQ.0) GOTO 280
KPA=IABS(KP)
KCP=PYCOMP(KPA)
IF(KPA.GT.80) MHADDY=1
IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
KFP=KP
ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
KFP=KFS*KP
ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
KFP=-KFS*MOD(KFA/10,10)
ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
KFP=KFS*(100*MOD(KFA/10,100)+3)
ELSEIF(KPA.EQ.81) THEN
KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
ELSEIF(KP.EQ.82) THEN
CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
IF(KFP.EQ.0) GOTO 260
KFP=-KFP
IRNDMO=1
MSTJ(93)=1
IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
ELSEIF(KP.EQ.-82) THEN
KFP=MSTU(124)
ENDIF
IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
C...Add decay product to event record or to quark flavour list.
KFPA=IABS(KFP)
KQP=KCHG(KCP,2)
IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
NQ=NQ+1
KFLO(NQ)=KFP
C...set rndmflav popcorn system pointer
IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
MSTJ(93)=2
PSQ=PSQ+PYMASS(KFLO(NQ))
ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
& MOD(NQ,2).EQ.1) THEN
NQ=NQ-1
PS=PS-P(I,5)
K(I,1)=1
KFI=K(I,2)
CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
IF(K(I,2).EQ.0) GOTO 260
MSTJ(93)=1
P(I,5)=PYMASS(K(I,2))
PS=PS+P(I,5)
ELSE
I=I+1
NP=NP+1
IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
K(I,1)=1+MOD(NQ,2)
IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
K(I,2)=KFP
K(I,3)=IP
K(I,4)=0
K(I,5)=0
P(I,5)=PYMASS(KFP)
PS=PS+P(I,5)
ENDIF
280 CONTINUE
C...Check masses for resonance decays.
IF(MHADDY.EQ.0) THEN
IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
ENDIF
C...Choose decay multiplicity in phase space model.
290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
PSP=PS
CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
300 NTRY=NTRY+1
C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
IF(IRNDMO.EQ.0) THEN
MSTU(121)=0
JTMO=0
ELSEIF(IRNDMO.EQ.1) THEN
IRNDMO=2
ELSE
GOTO 260
ENDIF
IF(NTRY.GT.1000) THEN
CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
IF(MSTU(21).GE.1) RETURN
ENDIF
IF(MMAT.LE.20) THEN
GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
& SIN(PARU(2)*PYR(0))
ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
ELSE
ND=MMAT-20
ENDIF
C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
MSTU(125)=ND-NQ/2
IF(MSTU(121).GT.MSTU(125)) GOTO 300
C...Form hadrons from flavour content.
DO 310 JT=1,NQ
KFL1(JT)=KFLO(JT)
310 CONTINUE
IF(ND.EQ.NP+NQ/2) GOTO 330
DO 320 I=N+NP+1,N+ND-NQ/2
C.. Stick to started popcorn system, else pick side at random
JT=JTMO
IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
IF(K(I,2).EQ.0) GOTO 300
MSTU(125)=MSTU(125)-1
JTMO=0
IF(MSTU(121).GT.0) JTMO=JT
KFL1(JT)=-KFL2
320 CONTINUE
330 JT=2
JT2=3
JT3=4
IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
& ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
IF(JT.EQ.3) JT2=2
IF(JT.EQ.4) JT3=2
CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
C...Check that sum of decay product masses not too large.
PS=PSP
DO 340 I=N+NP+1,N+ND
K(I,1)=1
K(I,3)=IP
K(I,4)=0
K(I,5)=0
P(I,5)=PYMASS(K(I,2))
PS=PS+P(I,5)
340 CONTINUE
IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
C...Rescale energy to subtract off spectator quark mass.
ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
& .AND.NP.GE.3) THEN
PS=PS-P(N+NP,5)
PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
DO 350 J=1,5
P(N+NP,J)=PQT*PV(1,J)
PV(1,J)=(1D0-PQT)*PV(1,J)
350 CONTINUE
IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
ND=NP-1
MREM=1
C...Fully specified final state: check mass broadening effects.
ELSE
IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
ND=NP
ENDIF
C...Determine position of grandmother, number of sisters.
NM=0
KFAS=0
MSGN=0
IF(MMAT.EQ.3) THEN
IM=K(IP,3)
IF(IM.LT.0.OR.IM.GE.IP) IM=0
IF(IM.NE.0) KFAM=IABS(K(IM,2))
IF(IM.NE.0) THEN
DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
IF(K(IL,3).EQ.IM) NM=NM+1
IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
360 CONTINUE
IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
& MOD(KFAM/1000,10).NE.0) NM=0
IF(NM.EQ.2) THEN
KFAS=IABS(K(ISIS,2))
IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
& MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
ENDIF
ENDIF
ENDIF
C...Kinematics of one-particle decays.
IF(ND.EQ.1) THEN
DO 370 J=1,4
P(N+1,J)=P(IP,J)
370 CONTINUE
GOTO 630
ENDIF
C...Calculate maximum weight ND-particle decay.
PV(ND,5)=P(N+ND,5)
IF(ND.GE.3) THEN
WTMAX=1D0/WTCOR(ND-2)
PMAX=PV(1,5)-PS+P(N+ND,5)
PMIN=0D0
DO 380 IL=ND-1,1,-1
PMAX=PMAX+P(N+IL,5)
PMIN=PMIN+P(N+IL+1,5)
WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
380 CONTINUE
ENDIF
C...Find virtual gamma mass in Dalitz decay.
390 IF(ND.EQ.2) THEN
ELSEIF(MMAT.EQ.2) THEN
PMES=4D0*PMAS(11,1)**2
PMRHO2=PMAS(131,1)**2
PGRHO2=PMAS(131,2)**2
400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
& (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
& ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
IF(WT.LT.PYR(0)) GOTO 400
PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
C...M-generator gives weight. If rejected, try again.
ELSE
410 RORD(1)=1D0
DO 440 IL1=2,ND-1
RSAV=PYR(0)
DO 420 IL2=IL1-1,1,-1
IF(RSAV.LE.RORD(IL2)) GOTO 430
RORD(IL2+1)=RORD(IL2)
420 CONTINUE
430 RORD(IL2+1)=RSAV
440 CONTINUE
RORD(ND)=0D0
WT=1D0
DO 450 IL=ND-1,1,-1
PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
& (PV(1,5)-PS)
WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
450 CONTINUE
IF(WT.LT.PYR(0)*WTMAX) GOTO 410
ENDIF
C...Perform two-particle decays in respective CM frame.
460 DO 480 IL=1,ND-1
PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
UE(3)=2D0*PYR(0)-1D0
PHI=PARU(2)*PYR(0)
UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
DO 470 J=1,3
P(N+IL,J)=PA*UE(J)
PV(IL+1,J)=-PA*UE(J)
470 CONTINUE
P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
480 CONTINUE
C...Lorentz transform decay products to lab frame.
DO 490 J=1,4
P(N+ND,J)=PV(ND,J)
490 CONTINUE
DO 530 IL=ND-1,1,-1
DO 500 J=1,3
BE(J)=PV(IL,J)/PV(IL,4)
500 CONTINUE
GA=PV(IL,4)/PV(IL,5)
DO 520 I=N+IL,N+ND
BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
DO 510 J=1,3
P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
510 CONTINUE
P(I,4)=GA*(P(I,4)+BEP)
520 CONTINUE
530 CONTINUE
C...Check that no infinite loop in matrix element weight.
NTRY=NTRY+1
IF(NTRY.GT.800) GOTO 560
C...Matrix elements for omega and phi decays.
IF(MMAT.EQ.1) THEN
WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
& -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
& +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
ELSEIF(MMAT.EQ.2) THEN
Index: trunk/code/medium-params.2tev.dat
===================================================================
--- trunk/code/medium-params.2tev.dat (revision 504)
+++ trunk/code/medium-params.2tev.dat (revision 505)
@@ -1,9 +1,8 @@
TAUI 0.6
#TI 0.36
TI 0.485
TC 0.17
MDSCALEFAC 0.9
MDFACTOR 0.45
CENTRMIN 0.
CENTRMAX 10.
-BOOST T
Index: trunk/code/jewel-2.4.0.f
===================================================================
--- trunk/code/jewel-2.4.0.f (revision 504)
+++ trunk/code/jewel-2.4.0.f (revision 505)
@@ -1,8242 +1,8243 @@
PROGRAM JEWEL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
integer j,i,kk,poissonian
integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
double precision sumofweightstot,wdisctot,scalefac
double precision gettemp,r,tau
character*2 b1,b2
call init()
SUMOFWEIGHTSTOT=0.d0
WDISCTOT=0.d0
C--e+ + e- event generation
if (collider.eq.'EEJJ') then
b1 = 'e+'
b2 = 'e-'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
&' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--e+ + e- event loop
DO 100 J=1,NSIM
call genevent(j,b1,b2)
100 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb'
write(logfid,*)'sum of event weights in e+ + e- channel:',
& sumofweights-wdisc
write(logfid,*)
else
C--hadronic event generation
if (isochannel.eq.'PP') then
nsimpp = nsim
nsimpn = 0
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'PN') then
nsimpp = 0
nsimpn = nsim
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'NP') then
nsimpp = 0
nsimpn = 0
nsimnp = nsim
nsimnn = 0
elseif (isochannel.eq.'NN') then
nsimpp = 0
nsimpn = 0
nsimnp = 0
nsimnn = nsim
else
nsimpp = poissonian(1.d0*nsim*nproton**2/mass**2)
nsimpn = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnp = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnn = poissonian(1.d0*nsim*(mass-nproton)**2/mass**2)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
scalefac = nsim*1.d0/(nsimsum*1.d0)
nsimpp = int(nsimpp*scalefac)
nsimpn = int(nsimpn*scalefac)
nsimnp = int(nsimnp*scalefac)
nsimnn = int(nsimnn*scalefac)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
endif
C--loop over channels
do 101 kk=1,4
if (kk.eq.1) then
b1 = 'p+'
b2 = 'p+'
nsimchn = nsimpp
elseif (kk.eq.2) then
b1 = 'p+'
b2 = 'n0'
nsimchn = nsimpn
elseif (kk.eq.3) then
b1 = 'n0'
b2 = 'p+'
nsimchn = nsimnp
else
b1 = 'n0'
b2 = 'n0'
nsimchn = nsimnn
endif
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsimchn,' events in ',
&b1,' + ',b2,' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--event loop
DO 102 J=1,nsimchn
call genevent(j,b1,b2)
102 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
& PARI(1),'mb'
write(logfid,*)'sum of event weights in ',b1,' + ',b2,
& ' channel:',sumofweights-wdisc
write(logfid,*)
101 continue
endif
C--finish
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
WRITE(HPMCFID,*)
CLOSE(HPMCFID,status='keep')
write(logfid,*)
write(logfid,*)'mean number of scatterings:',
& NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of effective scatterings:',
& NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings:',
& NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from IS shower:',
& nspliti/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from FS shower:',
& nsplitf/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'fraction of rejected IS splittings:',
& nisfail/nistry
write(logfid,*)'fraction of rejected FS splittings:',
& nfsfail/nfstry
write(logfid,*)'fraction of rejected momentum transfers:',
& ntrej/nttot
write(logfid,*)
write(logfid,*)'number of extrapolations in splitting integral: ',
& noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting partonic PDFs: ',
& noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting cross sections: ',
& noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in Sudakov form factor: ',
& noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
write(logfid,*)
write(logfid,*)'number of good events: ',ngood
write(logfid,*)'total number of discarded events: ',NDISC
write(logfid,*)'number of events for which conversion '//
&'to hepmc failed: ',NSTRANGE
call printtime
close(logfid,status='keep')
C--write random number generator state to file and close it
CALL PYRGET(2,-1)
CLOSE(2,status='keep')
END
***********************************************************************
***********************************************************************
*** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES ****************
***********************************************************************
***********************************************************************
***********************************************************************
*** subroutine init
***********************************************************************
subroutine init()
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
common/pdfas/pdfalphas
double precision pdfalphas
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2)
&,SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
INTEGER NJOB,ios,pos,i,j,jj,intmass
DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr
character firstchar
CHARACTER*2 SNSET
CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer,
&label,value
CHARACTER*120 HEPMCFILE,LOGFILE,FILENAME2
CHARACTER(LEN=100) filename
LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST
logical readran
data maxnscatcen/22990/
HPMCFID = 4
logfid = 3
C--default settings
nsim = 10000
njob = 0
logfile = 'out.log'
hepmcfile = 'out.hepmc'
filesplit = 'splitint.dat'
pdffile = 'pdfs.dat'
xsecfile = 'xsecs.dat'
filemed = 'medium-params.dat'
nf = 3
lqcd = 0.4
q0 = 1.5
ptmin = 5.
ptmax = 350.
etamax = 3.1
collider = 'PPJJ'
isochannel = 'XX'
channel = 'MUON'
sqrts = 2760
pdfset = 13100
pdfalphas = 0.118
mass = 208
nproton = 82
weighted = .true.
weightex = 5.
angord = .true.
allhad = .false.
hadro = .true.
hadrotype = 0
shorthepmc = .true.
compress = .true.
writescatcen = .false.
writedummies = .false.
scatrecoil = .false.
recsoftcut = 0.
rechardcut = 5.
kinmode = 1
recmode = 0
readran = .false.
if (iargc().eq.0) then
write(*,*)'No parameter file given, '//
&'will run with default settings.'
else
call getarg(1,filename)
write(*,*)'Reading parameters from ',filename
open(unit=1,file=filename,status='old',err=110)
do 120 i=1,1000
read(1, '(A)', iostat=ios) buffer
if(ios.ne.0) goto 130
firstchar = buffer(1:1)
if (firstchar.eq.'#') goto 120
pos=scan(buffer,' ')
label=buffer(1:pos)
value=buffer(pos+1:)
if(label.eq."NEVENT")then
read(value,*,iostat=ios) nsim
elseif(label.eq."NJOB")then
read(value,*,iostat=ios) njob
elseif(label.eq."LOGFILE")then
read(value,'(a)',iostat=ios) logfile
elseif(label.eq."HEPMCFILE")then
read(value,'(a)',iostat=ios) hepmcfile
elseif(label.eq."SPLITINTFILE")then
read(value,'(a)',iostat=ios) filesplit
elseif(label.eq."PDFFILE")then
read(value,'(a)',iostat=ios) pdffile
elseif(label.eq."XSECFILE")then
read(value,'(a)',iostat=ios) xsecfile
elseif(label.eq."MEDIUMPARAMS")then
read(value,'(a)',iostat=ios) filemed
elseif(label.eq."NF")then
read(value,*,iostat=ios) nf
elseif(label.eq."LAMBDAQCD")then
read(value,*,iostat=ios) lqcd
elseif(label.eq."Q0")then
read(value,*,iostat=ios) q0
elseif(label.eq."PTMIN")then
read(value,*,iostat=ios) ptmin
elseif(label.eq."PTMAX")then
read(value,*,iostat=ios) ptmax
elseif(label.eq."ETAMAX")then
read(value,*,iostat=ios) etamax
elseif(label.eq."PROCESS")then
read(value,*,iostat=ios) collider
elseif(label.eq."ISOCHANNEL")then
read(value,*,iostat=ios) isochannel
elseif(label.eq."CHANNEL")then
read(value,*,iostat=ios) channel
elseif(label.eq."SQRTS")then
read(value,*,iostat=ios) sqrts
elseif(label.eq."PDFSET")then
read(value,*,iostat=ios) pdfset
elseif(label.eq."PDFALPHAS")then
read(value,*,iostat=ios) pdfalphas
elseif(label.eq."MASS")then
read(value,*,iostat=ios) mass
elseif(label.eq."NPROTON")then
read(value,*,iostat=ios) nproton
elseif(label.eq."WEIGHTED")then
read(value,*,iostat=ios) weighted
elseif(label.eq."WEXPO")then
read(value,*,iostat=ios) weightex
elseif(label.eq."ANGORD")then
read(value,*,iostat=ios) angord
elseif(label.eq."KEEPRECOILS")then
read(value,*,iostat=ios) allhad
elseif(label.eq."SCATRECOIL")then
read(value,*,iostat=ios) scatrecoil
elseif(label.eq."HADRO")then
read(value,*,iostat=ios) hadro
elseif(label.eq."HADROTYPE")then
read(value,*,iostat=ios) hadrotype
elseif(label.eq."SHORTHEPMC")then
read(value,*,iostat=ios) shorthepmc
elseif(label.eq."COMPRESS")then
read(value,*,iostat=ios) compress
elseif(label.eq."WRITESCATCEN")then
read(value,*,iostat=ios) writescatcen
elseif(label.eq."WRITEDUMMIES")then
read(value,*,iostat=ios) writedummies
elseif(label.eq."RECSOFTCUT")then
read(value,*,iostat=ios) recsoftcut
elseif(label.eq."RECHARDCUT")then
read(value,*,iostat=ios) rechardcut
elseif(label.eq."KINMODE")then
read(value,*,iostat=ios) kinmode
elseif(label.eq."RECMODE")then
read(value,*,iostat=ios) recmode
elseif(label.eq."READRAN")then
read(value,*,iostat=ios) readran
else
write(*,*)'unknown label ',label
endif
120 continue
110 write(*,*)
& 'Unable to open parameter file, will exit the run.'
call exit(1)
130 close(1,status='keep')
write(*,*)'...done'
endif
lps = lqcd
! scatrecoil = .false.
! if (.not.hadro) shorthepmc = .true.
if (recmode.eq.2) then
allhad = .false.
scatrecoil = .false.
endif
SCALEFACM=1.
ptfac=1.
ftfac=1.d0
if (ptmin.lt.3.d0) ptmin = 3.d0
if (.not.writescatcen) writedummies = .false.
OPEN(unit=logfid,file=LOGFILE,status='unknown')
MSTU(11)=logfid
call printtime
call printlogo(logfid)
write(logfid,*)
write(logfid,*)'parameters of the run:'
write(logfid,*)'NEVENT = ',nsim
write(logfid,*)'NJOB = ',njob
write(logfid,*)'LOGFILE = ',logfile
write(logfid,*)'HEPMCFILE = ',hepmcfile
write(logfid,*)'SPLITINTFILE = ',filesplit
write(logfid,*)'PDFFILE = ',pdffile
write(logfid,*)'XSECFILE = ',xsecfile
write(logfid,*)'MEDIUMPARAMS = ',filemed
write(logfid,*)'NF = ',nf
write(logfid,*)'LAMBDAQCD = ',lqcd
write(logfid,*)'Q0 = ',q0
write(logfid,*)'PTMIN = ',ptmin
write(logfid,*)'PTMAX = ',ptmax
write(logfid,*)'ETAMAX = ',etamax
write(logfid,*)'PROCESS = ',collider
write(logfid,*)'ISOCHANNEL = ',isochannel
write(logfid,*)'CHANNEL = ',channel
write(logfid,*)'SQRTS = ',sqrts
write(logfid,*)'PDFSET = ',pdfset
write(logfid,*)'PDFALPHAS = ',pdfalphas
write(logfid,*)'MASS = ',mass
write(logfid,*)'NPROTON = ',nproton
write(logfid,*)'WEIGHTED = ',weighted
write(logfid,*)'WEXPO = ',weightex
write(logfid,*)'ANGORD = ',angord
write(logfid,*)'HADRO = ',hadro
write(logfid,*)'HADROTYPE = ',hadrotype
write(logfid,*)'SHORTHEPMC = ',shorthepmc
write(logfid,*)'COMPRESS = ',compress
write(logfid,*)'KEEPRECOILS = ',allhad
write(logfid,*)'SCATRECOIL = ',scatrecoil
write(logfid,*)'RECSOFTCUT = ',recsoftcut
write(logfid,*)'RECHARDCUT = ',rechardcut
write(logfid,*)'WRITESCATCEN = ',writescatcen
write(logfid,*)'WRITEDUMMIES = ',writedummies
write(logfid,*)'KINMODE = ',kinmode
write(logfid,*)'RECMODE = ',recmode
write(logfid,*)
call flush(logfid)
if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
& .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
& .and.(collider.ne.'PPYG')
& .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
& .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
& .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
& .and.(collider.ne.'PPDY')) then
write(logfid,*)'Fatal error: colliding system unknown, '//
& 'will exit now'
call exit(1)
endif
C--initialize medium
intmass = int(mass)
CALL MEDINIT(FILEMED,logfid,etamax,intmass)
CALL MEDNEXTEVT
OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown')
WRITE(HPMCFID,*)
WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05'
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
NPART=2
if(ptmax.gt.0.)then
EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.)
else
EOVEST=sqrts/2.
endif
CALL EIXINT
CALL INSUDAINT(EOVEST)
write(logfid,*)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(SPLITIEXIST)THEN
write(logfid,*)'read splitting integrals from ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='old')
READ(10,*)QMAX,ZMMIN,NPOINT
DO 893 I=1,NPOINT+1
READ(10,*) QVAL(I),ZMVAL(I)
893 CONTINUE
DO 891 I=1,NPOINT+1
DO 892 J=1,NPOINT+1
READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
892 CONTINUE
891 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate splitting functions, '//
&'this may take some time'
CALL SPLITFNCINT(EOVEST)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(.NOT.SPLITIEXIST)THEN
write(logfid,*)'write splitting integrals to ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='new')
WRITE(10,*)QMAX,ZMMIN,NPOINT
DO 896 I=1,NPOINT+1
WRITE(10,*) QVAL(I),ZMVAL(I)
896 CONTINUE
DO 897 I=1,NPOINT+1
DO 898 J=1,NPOINT+1
WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
898 CONTINUE
897 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(PDFEXIST)THEN
write(logfid,*)'read pdfs from ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='old')
DO 872 I=1,2
DO 873 J=1,1000
READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
873 CONTINUE
872 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate pdfs, this may take some time'
CALL PDFINT(EOVEST)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(.NOT.PDFEXIST)THEN
write(logfid,*)'write pdfs to ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='new')
DO 876 I=1,2
DO 877 J=1,1000
WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
877 CONTINUE
876 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(XSECEXIST)THEN
write(logfid,*)'read cross sections from ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='old')
DO 881 J=1,1001
DO 885 JJ=1,101
READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
885 CONTINUE
881 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate cross sections, '//
&'this may take some time'
CALL XSECINT(EOVEST)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(.NOT.XSECEXIST)THEN
write(logfid,*)'write cross sections to ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='new')
DO 883 J=1,1001
DO 884 JJ=1,101
WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
884 CONTINUE
883 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
CALL FLUSH(3)
C--initialise random number generator status
IF(NJOB.GT.0)THEN
MRPY(1)=NJOB*1000
MRPY(2)=0
ENDIF
C--Call PYR once for initialization
R=PYR(0)
C--read random number generator from file if desired
IF(READRAN)THEN
OPEN(unit=2,file='in.ran',access='sequential',
&form='unformatted',status='old')
CALL PYRSET(2,0)
CLOSE(2,status='keep')
WRITE(logfid,*) 'read random number generator status'
ENDIF
C--write random number generator state to file
OPEN(unit=2,file='out.ran',access='sequential',form='unformatted',
&status='unknown')
CALL PYRGET(2,0)
NDISC=0
NGOOD=0
NSTRANGE=0
ERRCOUNT=0
errl = 0
NSCAT=0.d0
NSCATEFF=0.d0
NSPLIT=0.d0
nspliti=0.d0
nsplitf=0.d0
nistry=0.d0
nisfail=0.d0
nfstry=0.d0
nfsfail=0.d0
nttot=0.d0
ntrej=0.d0
ntotspliti=0
noverspliti=0
ntotpdf=0
noverpdf=0
ntotxsec=0
noverxsec=0
ntotsuda=0
noversuda=0
end
***********************************************************************
*** subroutine initpythia
***********************************************************************
subroutine initpythia(beam1,beam2)
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
common/pdfas/pdfalphas
double precision pdfalphas
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
character*2 beam1,beam2
C--initialise PYTHIA
C--keep parton shower history in PYJETS
MSTP(125)=2
C--no multiple interactions
MSTP(81) = 0
C--initial state radiation
MSTP(61)=1
C--switch off final state radiation off partons emitted from space-like shower
! MSTP(63)=0
C--switch off final state radiation
MSTP(71)=0
C--No hadronisation (yet)
MSTP(111)=0
C--Lambda_QCD and Q0
PARJ(81)=LQCD
PARJ(82)=Q0
C--parameter affecting treatment of string corners
PARU(14)=1.
C--Min shat in simulation
CKIN(1)=2.
C--pT-cut
CKIN(3)=PTMIN
CKIN(4)=PTMAX
C...# Tuned flavour parameters:
! PARJ(1) = 0.073
! PARJ(2) = 0.2
! PARJ(3) = 0.94
! PARJ(4) = 0.032
! PARJ(11) = 0.31
! PARJ(12) = 0.4
! PARJ(13) = 0.54
! PARJ(25) = 0.63
! PARJ(26) = 0.12
C...# Fragmentation tune
! MSTJ(11) = 5
! PARJ(21) = 0.325
! PARJ(41) = 0.5
! PARJ(42) = 0.6
! PARJ(47) = 0.67
! PARJ(81) = 0.29
! PARJ(82) = 1.65
C--particles stable if lifetime > PARJ(71), default = 10mm
MSTJ(22)=2
! PARJ(71)=288.
C--switch off pi0 decay
-C MDCY(PYCOMP(111),1)=0
+! MDCY(PYCOMP(111),1)=0
C--use LHAPDF
MSTP(52)=2
C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
C MSTW2008 (LO central) - 21000
MSTP(51)=PDFSET
IF(COLLIDER.EQ.'PPYQ')THEN
MSEL=0
MSUB(29)=1
ELSEIF(COLLIDER.EQ.'PPYG')THEN
MSEL=0
MSUB(14)=1
MSUB(115)=1
ELSEIF(COLLIDER.EQ.'PPYJ')THEN
MSEL=0
MSUB(14)=1
MSUB(29)=1
MSUB(115)=1
ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')
& .or.(COLLIDER.EQ.'PPZG')
& .or.(collider.eq.'PPDY'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1
IF(COLLIDER.EQ.'PPDY') MSUB(1)=1
MDME(174,1)=0 !Z decay into d dbar',
MDME(175,1)=0 !Z decay into u ubar',
MDME(176,1)=0 !Z decay into s sbar',
MDME(177,1)=0 !Z decay into c cbar',
MDME(178,1)=0 !Z decay into b bbar',
MDME(179,1)=0 !Z decay into t tbar',
MDME(182,1)=0 !Z decay into e- e+',
MDME(183,1)=0 !Z decay into nu_e nu_ebar',
MDME(184,1)=0 !Z decay into mu- mu+',
MDME(185,1)=0 !Z decay into nu_mu nu_mubar',
MDME(186,1)=0 !Z decay into tau- tau+',
MDME(187,1)=0 !Z decay into nu_tau nu_taubar',
if (channel.EQ.'ELEC')THEN
MDME(182,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(184,1)=1
ENDIF
ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')
& .or.(COLLIDER.EQ.'PPWG'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1
MDME(190,1)=0 ! W+ decay into dbar u,
MDME(191,1)=0 ! W+ decay into dbar c,
MDME(192,1)=0 ! W+ decay into dbar t,
MDME(194,1)=0 ! W+ decay into sbar u,
MDME(195,1)=0 ! W+ decay into sbar c,
MDME(196,1)=0 ! W+ decay into sbar t,
MDME(198,1)=0 ! W+ decay into bbar u,
MDME(199,1)=0 ! W+ decay into bbar c,
MDME(200,1)=0 ! W+ decay into bbar t,
MDME(202,1)=0 ! W+ decay into b'bar u,
MDME(203,1)=0 ! W+ decay into b'bar c,
MDME(204,1)=0 ! W+ decay into b'bar t,
MDME(206,1)=0 ! W+ decay into e+ nu_e,
MDME(207,1)=0 ! W+ decay into mu+ nu_mu,
MDME(208,1)=0 ! W+ decay into tau+ nu_tau,
MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau,
if (channel.EQ.'ELEC')THEN
MDME(206,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(207,1)=1
ENDIF
ELSE
C--All QCD processes are active
MSEL=1
ENDIF
! MSEL=0
! MSUB(11)=1
! MSUB(12)=1
! MSUB(53)=1
! MSUB(13)=1
! MSUB(68)=1
! MSUB(28)=1
C--weighted events
IF(WEIGHTED) MSTP(142)=1
C--number of errors to be printed
MSTU(22)=MAX(10,INT(5.*NSIM/100.))
C--number of lines in event record
MSTU(4)=23000
! MSTU(5)=23000
MSTU(5)=10000
C--initialisation call
IF(COLLIDER.EQ.'EEJJ')THEN
OFFSET=9
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR.
& (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN
OFFSET=8
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or.
& (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN
OFFSET=10
CALL PYINIT('CMS',beam1,beam2,sqrts)
elseif (collider.eq.'PPDY') then
CALL PYINIT('CMS',beam1,beam2,sqrts)
ENDIF
end
***********************************************************************
*** subroutine genevent
***********************************************************************
subroutine genevent(j,b1,b2)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Variables local to this program
INTEGER NOLD,PID,IPART,LME1,LME2,j,i,LME1ORIG,LME2ORIG,llep1,
&llep2,lv
integer nnew,lprev,l1,l2,l3,lstart,jj,ii,ntmp,slen
DOUBLE PRECISION PYR,ENI,QMAX1,R,GETMASS,PYP,Q1,Q2,P21,P22,ETOT,
&QMAX2,POLD,EN1,EN2,BETA(3),ENEW1,ENEW2,emax,lambda,x1,x2,x3,
&MEWEIGHT,PSWEIGHT,WEIGHT,EPS1,EPS2,THETA1,THETA2,Z1,Z2,
&getltimemax,pi,m1,m2,pymass
character*2 b1,b2
CHARACTER*2 TYPE1,TYPE2
LOGICAL FIRSTTRIP,WHICH1,WHICH2,ISDIQUARK,isparton,recomb
logical onlyzeros
DATA PI/3.141592653589793d0/
N=0
COLMAX=600
DISCARD=.FALSE.
DO 91 I=1,23000
MV(I,1)=0.d0
MV(I,2)=0.d0
MV(I,3)=0.d0
MV(I,4)=0.d0
MV(I,5)=0.d0
ZA(I)=0.d0
ZD(I)=0.d0
THETAA(I)=0.d0
QQBARD(I)=.FALSE.
91 CONTINUE
nscatcen = 0
CALL MEDNEXTEVT
C--initialisation with matrix element
C--production vertex
CALL PICKVTX(X0,Y0)
LTIME=GETLTIMEMAX()
99 CALL PYEVNT
! call pylist(2)
NPART=N-OFFSET
EVWEIGHT=PARI(10)
SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
GOTO 102
ELSE
NGOOD=NGOOD+1
ENDIF
C--DY: don't have to do anything
if (collider.eq.'PPDY') then
CALL PYEXEC
call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
goto 102
endif
C--prepare event record
C--special treatment for Jeweling intial state radiation (currently only available for di-jets)
if (collider.eq.'PPJJ') then
! write(logfid,*)'begin special treatment'
! call pevrec(2,.false.)
C--find non-strongly interacting particles and move them up first
nnew=8
do 300 i=107,n
if ((k(i,1).le.2).and.(.not.isparton(k(i,2)))) then
k(i,1)=11
nnew=nnew+1
call copyline(i,nnew,0)
endif
300 continue
C--walk backwards from ME to beam and set production vertices and times
do 400 i=0,1
lstart=105+i
lambda=1.d0/(ftfac*p(lstart,4)*0.2/p(lstart,5)**2)
mv(lstart,4)=log(1.d0-pyr(0))/lambda
mv(lstart,5)=0.d0
mv(lstart,1)=x0 +
& mv(lstart,4)*p(lstart,1)/max(pyp(lstart,8),p(lstart,4))
mv(lstart,2)=y0 +
& mv(lstart,4)*p(lstart,2)/max(pyp(lstart,8),p(lstart,4))
mv(lstart,3)=
& mv(lstart,4)*p(lstart,3)/max(pyp(lstart,8),p(lstart,4))
lprev=lstart
l1=k(lprev,3)
do while (k(lprev,3).gt.4)
do 302 jj=105,n
if (k(jj,3).eq.l1) l2=jj
302 continue
if ((k(l1,3).eq.3).or.(k(l1,3).eq.4)) then
mv(l1,1)=1.d6
mv(l1,2)=1.d6
if (k(l1,3).eq.3) then
mv(l1,3)=1.d6
else
mv(l1,3)=-1.d6
endif
mv(l1,4)=-1.d6
mv(l1,5)=mv(lprev,4)
else
lambda=1.d0/(ftfac*p(l1,4)*0.2/p(l1,5)**2)
mv(l1,4)=mv(lprev,4) + log(1.d0-pyr(0))/lambda
mv(l1,5)=mv(lprev,4)
mv(l1,1)=mv(lprev,1) +
& (mv(l1,4)-mv(l1,5))*p(l1,1)/max(pyp(l1,8),p(l1,4))
mv(l1,2)=mv(lprev,2) +
& (mv(l1,4)-mv(l1,5))*p(l1,2)/max(pyp(l1,8),p(l1,4))
mv(l1,3)=mv(lprev,3) +
& (mv(l1,4)-mv(l1,5))*p(l1,3)/max(pyp(l1,8),p(l1,4))
endif
mv(l2,4)=mv(lprev,4)
if (p(l2,5).eq.pymass(k(l2,2))) then
mv(l2,5)=ltime
else
lambda=1.d0/(ftfac*p(l2,4)*0.2/p(l2,5)**2)
mv(l2,5)=mv(lprev,4) - log(1.d0-pyr(0))/lambda
endif
mv(l2,1)=mv(lprev,1)
mv(l2,2)=mv(lprev,2)
mv(l2,3)=mv(lprev,3)
lprev=l1
l1=k(lprev,3)
end do
400 continue
! call pevrec(3,.false.)
C--order all singlets from triplet to antitriplet
do 401 i=lstart,n
if ((k(i,1).eq.2).and.
& ((k(i,2).lt.0).or.isdiquark(k(i,2)))) then
ntmp=n
do 402 jj=i,n
ntmp=ntmp+1
call copyline(jj,ntmp,1)
k(ntmp,3)=k(jj,3)
if (k(jj,1).eq.1) goto 403
402 continue
403 do 404 jj=0,ntmp-n-1
call copyline(ntmp-jj,i+jj,1)
k(i+jj,3)=k(ntmp-jj,3)
if (jj.eq.ntmp-n-1) then
k(i+jj,1)=1
else
k(i+jj,1)=2
endif
404 continue
! write(logfid,*)'had to change order of singlets'
! call pevrec(3,.false.)
endif
401 continue
C--undo final state splittings
lstart=0
do 303 i=107,n
if ((lstart.eq.0).and.(k(i,1).le.2)) lstart=i
if (k(i,1).le.2) then
do 310 jj=1,5
mv(i,jj)=mv(k(i,3),jj)
310 continue
k(i,3)=k(k(i,3),3)
endif
303 continue
! write(logfid,*)'start undoing FS splittings'
! call pevrec(3,.false.)
recomb=.true.
do while (recomb)
recomb=.false.
do 304 i=lstart,n
if (k(i,3).gt.106) then
onlyzeros=.true.
do 307 jj=i+1,n
if (k(i,3).eq.k(jj,3)) then
l1=i
l2=jj
recomb=.true.
goto 308
else
if ((jj.gt.i+1).and.(k(jj,1).gt.0)) onlyzeros=.false.
endif
307 continue
endif
304 continue
308 if (recomb) then
if (onlyzeros) then
! write(logfid,*)'normal recombination step',l1,l2
if (k(k(l1,3),2).eq.21) then
zd(l1)=p(l1,4)/p(k(l1,3),4)
if (k(l1,2).ne.21) then
qqbard(l1)=.true.
else
qqbard(l1)=.false.
endif
else
if (k(l1,2).eq.21) then
zd(l1)=p(l2,4)/p(k(l2,3),4)
else
zd(l1)=p(l1,4)/p(k(l1,3),4)
endif
qqbard(l1)=.false.
endif
do 305 i=1,5
p(l1,i)=p(k(l1,3),i)
305 continue
k(l1,2)=k(k(l1,3),2)
k(l1,3)=k(k(l1,3),3)
if (k(l1,2).eq.21) k(l1,1)=2
if (k(l2,1).eq.1) k(l1,1)=1
k(l2,1)=0
else
C--have to change order in which singlets appear
! write(logfid,*)'have to change order of singlets',l1,l2
if (k(l1,1).eq.2) then
ntmp=n
do 405 i=l1,n
ntmp=ntmp+1
call copyline(i,ntmp,1)
k(ntmp,3)=k(i,3)
if (k(i,1).eq.1) goto 406
405 continue
406 continue
slen=ntmp-n
do 407 i=l1+slen,l2
call copyline(i,i-slen,1)
k(i-slen,3)=k(i,3)
407 continue
do 408 i=1,slen
call copyline(n+i,l2-slen+i,1)
k(l2-slen+i,3)=k(n+i,3)
408 continue
else
do 410 i=1,l1-lstart
if ((k(l1-i,2).ne.21).and.(k(l1-i,1).ne.0)) then
l3=l1-i
goto 411
endif
410 continue
411 ntmp=n
do 415 i=l3,l1
ntmp=ntmp+1
call copyline(i,ntmp,1)
k(ntmp,3)=k(i,3)
415 continue
slen=ntmp-n
do 417 i=l3+slen,l2-1
call copyline(i,i-slen,1)
k(i-slen,3)=k(i,3)
417 continue
do 418 i=1,slen
call copyline(n+i,l2-slen-1+i,1)
k(l2-slen-1+i,3)=k(n+i,3)
418 continue
endif
endif
endif
! write(logfid,*)'after one iteration'
! call pevrec(3,.false.)
end do
! write(logfid,*)'before copying everything up'
! call pevrec(3,.false.)
C--copy remaining lines to top of event record
do 309 jj=lstart,n
if(k(jj,1).gt.0) then
if ((k(jj,3).gt.106).and.
& (p(jj,5).ne.pymass(k(jj,2)))) then
do 311 i=1,5
mv(jj,i)=mv(k(jj,3),i)
311 continue
endif
if ((k(jj,3).eq.1).or.(k(jj,3).eq.2)) then
mv(jj,1)=x0
mv(jj,2)=y0
mv(jj,3)=0.d0
mv(jj,4)=0.d0
mv(jj,5)=ltime
endif
nnew=nnew+1
call copyline(jj,nnew,1)
if (k(jj,3).lt.100) k(nnew,3)=k(jj,3)
za(nnew)=1.d0
zd(nnew)=zd(jj)
qqbard(nnew)=qqbard(jj)
thetaa(nnew)=p(nnew,5)/
& (sqrt(zd(nnew)*(1.-zd(nnew)))*p(nnew,4))
endif
309 continue
n=nnew
NPART=N-OFFSET
endif
! write(logfid,*)'end special treatment'
! call pevrec(3,.false.)
-
+! call exit(1)
+
C--end special treatment
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
LME1ORIG=7
LME2ORIG=8
if(abs(k(7,2)).gt.21) then
lv=7
else
lv=8
endif
ELSE
LME1ORIG=OFFSET-1
LME2ORIG=OFFSET
ENDIF
DO 180 IPART=OFFSET+1, OFFSET+NPART
C--find decay leptons in V+jet events
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if(k(ipart,3).eq.offset-1) llep1=ipart
if(k(ipart,3).eq.offset) llep2=ipart
endif
IF(K(IPART,3).EQ.(LME1ORIG))THEN
LME1=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE1='GC'
ELSE
TYPE1='QQ'
ENDIF
ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN
LME2=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE2='GC'
ELSE
TYPE2='QQ'
ENDIF
ELSE
TRIP(IPART)=0
ANTI(IPART)=0
! ZD(IPART)=0.d0
! THETAA(IPART)=0.d0
ENDIF
C--assign colour indices
IF(K(IPART,1).EQ.2)THEN
IF(K(IPART-1,1).EQ.2)THEN
C--in middle of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
C--beginning of colour singlet
IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0))
& .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=0
FIRSTTRIP=.TRUE.
ELSE
TRIP(IPART)=0
ANTI(IPART)=COLMAX+1
FIRSTTRIP=.FALSE.
ENDIF
COLMAX=COLMAX+1
ENDIF
ENDIF
IF(K(IPART,1).EQ.1)THEN
C--end of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=0
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=0
ENDIF
ENDIF
180 CONTINUE
if (k(lme1,1).lt.11) K(LME1,1)=1
if (k(lme2,1).lt.11) K(LME2,1)=1
PID=K(LME1,2)
ENI=MAX(P(LME1,4),P(LME2,4))
DO 183 IPART=OFFSET+1, OFFSET+NPART
IF((IPART.NE.LME1).AND.(IPART.NE.LME2)
& .AND.(K(IPART,1).LT.11)) then
if (p(ipart,5).gt.pymass(k(ipart,2))) then
k(ipart,1)=1
else
if ((isparton(k(ipart,2))).and.
& (abs(pyp(ipart,19)).lt.etamax)) then
if (p(ipart,5).gt.0.d0) call makemassless(ipart,lme1,lme2)
k(ipart,1)=1
else
k(ipart,1)=4
endif
endif
endif
if (k(ipart,2).eq.22) k(ipart,1)=4
183 CONTINUE
! DO 183 IPART=OFFSET+1, OFFSET+NPART
! IF((IPART.NE.LME1).AND.(IPART.NE.LME2))
! & K(IPART,1)=11
! if (k(ipart,2).eq.22) k(ipart,1)=4
! 183 CONTINUE
C--find virtualities and adapt four-vectors
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if (abs(k(lme1,2)).gt.21) then
QMAX1=0.d0
QMAX2=sqrt(pari(18)+p(lme1,5)**2)
else
QMAX1=sqrt(pari(18)+p(lme2,5)**2)
QMAX2=0.d0
endif
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ELSEIF(COLLIDER.EQ.'PPJJ'.OR.COLLIDER.EQ.'PPYJ'
& .OR.COLLIDER.EQ.'PPYQ'.OR.COLLIDER.EQ.'PPYG')THEN
if (k(lme1,1).eq.4) then
qmax1 = 0.d0
else
QMAX1=pari(17)
endif
if (k(lme2,1).eq.4) then
qmax2 = 0.d0
else
QMAX2=pari(17)
endif
! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
EN1=P(LME1,4)
EN2=P(LME2,4)
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
ETOT=P(LME1,4)+P(LME2,4)
IF(COLLIDER.EQ.'EEJJ')THEN
QMAX1=ETOT
QMAX2=ETOT
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
C-- find virtuality
Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
182 if (abs(k(lme1,2)).gt.21) then
m1=p(lme1,5)
else
m1=q1
endif
if (abs(k(lme2,2)).gt.21) then
m2=p(lme2,5)
else
m2=q2
endif
ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2
P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0)
& .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0)
& )THEN
IF(Q1.GT.Q2)THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ELSE
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
GOTO 182
ENDIF
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=m1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=m2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
C--correct to ME for first parton
IF(COLLIDER.EQ.'EEJJ')THEN
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
IF(Q1.GT.0.d0)THEN
C--generate z value
X1=Z1*(ETOT**2+Q1**2)/ETOT**2
X2=(ETOT**2-Q1**2)/ETOT**2
X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ENDIF
ENDIF
C--correct to ME for second parton
IF(Q2.GT.0.d0)THEN
C--generate z value
X1=(ETOT**2-Q2**2)/ETOT**2
X2=Z2*(ETOT**2+Q2**2)/ETOT**2
X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
ENDIF
186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2
P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=Q1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=Q2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
ENDIF
C--transfer recoil to decay leptons in V+jet
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
beta(1)=p(lv,1)/p(lv,4)
beta(2)=p(lv,2)/p(lv,4)
beta(3)=p(lv,3)/p(lv,4)
CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if (abs(k(lme1,2)).gt.21) then
beta(1)=p(lme1,1)/p(lme1,4)
beta(2)=p(lme1,2)/p(lme1,4)
beta(3)=p(lme1,3)/p(lme1,4)
else
beta(1)=p(lme2,1)/p(lme2,4)
beta(2)=p(lme2,2)/p(lme2,4)
beta(3)=p(lme2,3)/p(lme2,4)
endif
CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3))
endif
C--store initial parton pt and mass for output
if (k(lme1,1).eq.1) then
inpt(1) = pyp(lme1,10)
! inpt(1) = p(lme1,4)*sin(pyp(lme1,13))
inmass(1) = p(lme1,5)
inphi(1) = pyp(lme1,15)
ineta(1) = pyp(lme1,19)
inpt(2) = pyp(lme2,10)
! inpt(2) = p(lme2,4)*sin(pyp(lme2,13))
inmass(2) = p(lme2,5)
inphi(2) = pyp(lme2,15)
ineta(2) = pyp(lme2,19)
if (k(lme1,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme2,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z1
inz(2) = z2
if(z1.gt.0.d0) then
intheta(1) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(1) = 0.d0
endif
if(z2.gt.0.d0) then
intheta(2) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(2) = 0.d0
endif
else
inpt(1) = pyp(lme2,10)
! inpt(1) = p(lme2,4)*sin(pyp(lme2,13))
inmass(1) = p(lme2,5)
inphi(1) = pyp(lme2,15)
ineta(1) = pyp(lme2,19)
inpt(2) = pyp(lme1,10)
! inpt(2) = p(lme1,4)*sin(pyp(lme1,13))
inmass(2) = p(lme1,5)
inphi(2) = pyp(lme1,15)
ineta(2) = pyp(lme1,19)
if (k(lme2,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme1,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z2
inz(2) = z1
if(z2.gt.0.d0) then
intheta(1) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(1) = 0.d0
endif
if(z1.gt.0.d0) then
intheta(2) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(2) = 0.d0
endif
endif
ZA(LME1)=1.d0
ZA(LME2)=1.d0
THETAA(LME1)=P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
THETAA(LME2)=P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
ZD(LME1)=Z1
ZD(LME2)=Z2
QQBARD(LME1)=WHICH1
QQBARD(LME2)=WHICH2
MV(LME1,1)=X0
MV(LME1,2)=Y0
MV(LME1,3)=0.d0
MV(LME1,4)=0.d0
IF(P(LME1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME1,4)*0.2/Q1**2)
MV(LME1,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME1,5)=LTIME
ENDIF
MV(LME2,1)=X0
MV(LME2,2)=Y0
MV(LME2,3)=0.d0
MV(LME2,4)=0.d0
IF(P(LME2,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME2,4)*0.2/Q2**2)
MV(LME2,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME2,5)=LTIME
ENDIF
! write(logfid,*)'before parton shower'
! call pevrec(3,.true.)
C--develop parton shower
CALL MAKECASCADE
IF(DISCARD) THEN
NGOOD=NGOOD-1
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
write(logfid,*)'discard event',J
GOTO 102
ENDIF
! write(logfid,*)'after parton shower'
! call pevrec(2,.true.)
IF(.NOT.ALLHAD)THEN
DO 86 I=1,N
IF(K(I,1).EQ.3) K(I,1)=22
86 CONTINUE
ENDIF
IF(HADRO)THEN
CALL MAKESTRINGS(HADROTYPE)
! call combinegluons()
IF(DISCARD) THEN
write(logfid,*)'discard event',J
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
CALL PYEXEC
IF(MSTU(30).NE.ERRCOUNT)THEN
write(logfid,*)'PYTHIA discards event',J,
& ' (error number',MSTU(30),')'
ERRCOUNT=MSTU(30)
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
ENDIF
! DO 888 I=1,N
! IF(K(I,2).EQ.94)THEN
! NGOOD=NGOOD-1
! NSTRANGE=NSTRANGE+1
! NDISC=NDISC+1
! call pevrec(2,.false.)
! GOTO 102
! ENDIF
! 888 CONTINUE
IF(MSTU(30).NE.ERRCOUNT)THEN
ERRCOUNT=MSTU(30)
ELSE
CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
ENDIF
C--write message to log-file
102 IF(NSIM.GT.100)THEN
IF(MOD(J,NSIM/100).EQ.0)THEN
write(logfid,*) 'done with event number ',J,
& PARI(1), (sumofweights-wdisc)/j
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
else
write(logfid,*) 'done with event number ',J
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
call flush(logfid)
end
***********************************************************************
*** subroutine makestrings
***********************************************************************
SUBROUTINE MAKESTRINGS(WHICH)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER WHICH
IF(WHICH.EQ.0)THEN
CALL MAKESTRINGS_VAC
ELSEIF(WHICH.EQ.1)THEN
CALL MAKESTRINGS_MINL
ELSE
WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS'
ENDIF
END
***********************************************************************
*** subroutine makestrings_vac
***********************************************************************
SUBROUTINE MAKESTRINGS_VAC
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1
DOUBLE PRECISION EADDEND,PYR,DIR
LOGICAL ISDIQUARK,compressevent,roomleft
DATA EADDEND/10.d0/
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--first do strings with existing (anti)triplets
C--find string end (=quark or antiquark)
43 LQUARK=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR.
& (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN
LQUARK=I
GOTO 41
ENDIF
40 CONTINUE
GOTO 50
41 CONTINUE
C--copy string end to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LQUARK,2)
K(N,3)=LQUARK
K(N,4)=0
K(N,5)=0
P(N,1)=P(LQUARK,1)
P(N,2)=P(LQUARK,2)
P(N,3)=P(LQUARK,3)
P(N,4)=P(LQUARK,4)
P(N,5)=P(LQUARK,5)
K(LQUARK,1)=16
K(LQUARK,4)=N
K(LQUARK,5)=N
TRIP(N)=TRIP(LQUARK)
ANTI(N)=ANTI(LQUARK)
C--append matching colour partner
LMATCH=0
DO 44 J=1,10000000
DO 42 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0))
& .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
IF(K(I,2).EQ.21)THEN
K(N,1)=2
GOTO 44
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
42 CONTINUE
C--no matching colour partner found
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event',n,trip(n),anti(n),i
call pevrec(2,.true.)
discard = .true.
return
44 CONTINUE
C--now take care of purely gluonic remainder system
C-----------------------------------------
C--find gluon where anti-triplet is not matched
50 LLOOSE=0
DO 45 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
DO 46 J=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
IF(ANTI(I).EQ.TRIP(J)) GOTO 45
ENDIF
46 CONTINUE
LLOOSE=I
GOTO 47
ENDIF
45 CONTINUE
GOTO 51
47 CONTINUE
C--generate artificial triplet end
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
C--copy loose gluon to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LLOOSE,2)
K(N,3)=LLOOSE
K(N,4)=0
K(N,5)=0
P(N,1)=P(LLOOSE,1)
P(N,2)=P(LLOOSE,2)
P(N,3)=P(LLOOSE,3)
P(N,4)=P(LLOOSE,4)
P(N,5)=P(LLOOSE,5)
K(LLOOSE,1)=16
K(LLOOSE,4)=N
K(LLOOSE,5)=N
TRIP(N)=TRIP(LLOOSE)
ANTI(N)=ANTI(LLOOSE)
C--append matching colour partner
LMATCH=0
DO 48 J=1,10000000
DO 49 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(ANTI(I).EQ.TRIP(N)))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
K(N,1)=2
GOTO 48
ENDIF
49 CONTINUE
C--no matching colour partner found, add artificial end point
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
48 CONTINUE
51 CONTINUE
CALL CLEANUP(NOLD1)
END
***********************************************************************
*** subroutine makestrings_minl
***********************************************************************
SUBROUTINE MAKESTRINGS_MINL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1
DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR,
&pyp
DATA MCUT/1.d8/
DATA EADDEND/10.d0/
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
logical compressevent,roomleft
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--find most energetic unfragmented parton in event
43 EMAX=0
LMAX=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN
EMAX=P(I,4)
LMAX=I
ENDIF
40 CONTINUE
C--if there is non, we are done
IF(LMAX.EQ.0) GOTO 50
C--check if highest energy parton is (anti)quark or gluon
IF(K(LMAX,2).EQ.21)THEN
C--split gluon in qqbar pair and store one temporarily in line 1
C--make new line in event record for string end
N=N+2
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF((N-2).GT.NOLD)THEN
DO 47 J=NOLD,N-3
K(N+NOLD-J,1)=K(N+NOLD-J-2,1)
K(N+NOLD-J,2)=K(N+NOLD-J-2,2)
IF(K(N+NOLD-J-2,3).GT.NOLD) THEN
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2
ELSE
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)
ENDIF
K(N+NOLD-J,4)=0
K(N+NOLD-J,5)=0
P(N+NOLD-J,1)=P(N+NOLD-J-2,1)
P(N+NOLD-J,2)=P(N+NOLD-J-2,2)
P(N+NOLD-J,3)=P(N+NOLD-J-2,3)
P(N+NOLD-J,4)=P(N+NOLD-J-2,4)
P(N+NOLD-J,5)=P(N+NOLD-J-2,5)
K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2
K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2
47 CONTINUE
ENDIF
NOLD=NOLD+2
K(LMAX,1)=18
Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG')
IF(Z.GT.0.5)THEN
K(NOLD-1,2)=1
K(NOLD,2)=-1
ELSE
Z=1.-Z
K(NOLD-1,2)=-1
K(NOLD,2)=1
ENDIF
K(NOLD-1,1)=1
K(NOLD-1,3)=LMAX
K(NOLD-1,4)=0
K(NOLD-1,5)=0
P(NOLD-1,1)=(1.-Z)*P(LMAX,1)
P(NOLD-1,2)=(1.-Z)*P(LMAX,2)
P(NOLD-1,3)=(1.-Z)*P(LMAX,3)
P(NOLD-1,4)=(1.-Z)*P(LMAX,4)
P(NOLD-1,5)=P(LMAX,5)
K(NOLD,1)=1
K(NOLD,3)=LMAX
K(NOLD,4)=0
K(NOLD,5)=0
P(NOLD,1)=Z*P(LMAX,1)
P(NOLD,2)=Z*P(LMAX,2)
P(NOLD,3)=Z*P(LMAX,3)
P(NOLD,4)=Z*P(LMAX,4)
P(NOLD,5)=P(LMAX,5)
K(LMAX,1)=18
K(LMAX,4)=NOLD-1
K(LMAX,5)=NOLD
LMAX=NOLD
ENDIF
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LMAX,2)
K(N,3)=LMAX
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMAX,1)
P(N,2)=P(LMAX,2)
P(N,3)=P(LMAX,3)
P(N,4)=P(LMAX,4)
P(N,5)=P(LMAX,5)
K(LMAX,1)=16
K(LMAX,4)=N
K(LMAX,5)=N
LEND=LMAX
C--find closest partner
42 MMIN=1.d10
LMIN=0
DO 41 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1)
& .EQ.4).OR.(K(I,1).EQ.5))
& .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND.
& (K(I,3).NE.K(LEND,3))))
& .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN
MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2)
& -P(I,3)*P(LMAX,3)
IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN
MMIN=MINV
LMIN=I
ENDIF
ENDIF
41 CONTINUE
C--if no closest partner can be found, generate artificial end point for string
IF(LMIN.EQ.0)THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=1
K(N,2)=-K(LEND,2)
K(N,3)=0
K(N,4)=0
K(N,5)=0
P(N,1)=0.d0
P(N,2)=0.d0
IF(PYR(0).LT.0.5)THEN
DIR=1.d0
ELSE
DIR=-1.d0
ENDIF
P(N,3)=DIR*EADDEND
P(N,4)=EADDEND
P(N,5)=0.d0
GOTO 43
ELSE
C--else build closest partner in string
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(LMIN,2)
K(N,3)=LMIN
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMIN,1)
P(N,2)=P(LMIN,2)
P(N,3)=P(LMIN,3)
P(N,4)=P(LMIN,4)
P(N,5)=P(LMIN,5)
K(LMIN,1)=16
K(LMIN,4)=N
K(LMIN,5)=N
IF(K(LMIN,2).EQ.21)THEN
K(N,1)=2
LMAX=LMIN
GOTO 42
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
50 CONTINUE
CALL CLEANUP(NOLD)
END
***********************************************************************
*** subroutine cleanup
***********************************************************************
SUBROUTINE CLEANUP(NFIRST)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
INTEGER NFIRST,NLAST,I,J
NLAST=N
DO 21 I=1,NLAST-NFIRST
DO 22 J=1,5
K(I,J)=K(NFIRST+I,J)
P(I,J)=P(NFIRST+I,J)
V(I,J)=V(NFIRST+I,J)
22 CONTINUE
K(I,3)=0
21 CONTINUE
N=NLAST-NFIRST
END
***********************************************************************
*** subroutine makecascade
***********************************************************************
SUBROUTINE MAKECASCADE
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I
LOGICAL CONT
10 NOLD=N
CONT=.FALSE.
DO 11 I=2,NOLD
if (i.gt.n) goto 10
C--check if parton may evolve, i.e. do splitting or scattering
IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN
CONT=.TRUE.
CALL MAKEBRANCH(I)
IF(DISCARD) GOTO 12
ENDIF
11 CONTINUE
IF(CONT) GOTO 10
12 END
***********************************************************************
*** subroutine makebranch
***********************************************************************
SUBROUTINE MAKEBRANCH(L)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
& scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--local variables
INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold
integer oldstcode
DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT,
&TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR
LOGICAL OVERQ0,QQBARDEC
CHARACTER TYP
LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent
LINE=L
NSTART=0
NEND=0
if ((mv(line,4).lt.0.d0).and.(mv(line,5).gt.0.d0)) then
starttime=0.d0
else
STARTTIME=MV(LINE,4)
endif
TSUM=0.d0
QSUM2=0.d0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
RETRYSPLIT=.FALSE.
MEDIND=.FALSE.
X=0.d0
Q=0.d0
TYPI=0
20 IF(DISCARD) RETURN
IF ((N.GT.20000).and.compress) roomleft = compressevent(line)
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN
IF(MEDIND)THEN
FORMTIME=starttime
ELSE
FORMTIME=MIN(MV(LINE,5),LTIME)
ENDIF
RADIATION=.TRUE.
ELSE
FORMTIME=LTIME
RADIATION=.FALSE.
ENDIF
TLEFT=FORMTIME-STARTTIME
IF(K(LINE,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
MEDIND=.FALSE.
! write(logfid,*)'makebranch: starttime tleft formtime radiation',
! & line, starttime,tleft,formtime,radiation
IF((TLEFT.LE.1.d-10).or.(starttime.lt.0.d0))THEN
C--no scattering
IF(RADIATION)THEN
C--if there is radiation associated with the parton then form it now
C--rotate such that momentum points in z-direction
NOLD=N
nscatcenold=nscatcen
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL MAKESPLITTING(LINE)
C--rotate back
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
IF(DISCARD) RETURN
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(LINE,1)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N-1,2)=MV(LINE,2)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N-1,3)=MV(LINE,3)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
MV(N, 1)=MV(LINE,1)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N, 2)=MV(LINE,2)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N, 3)=MV(LINE,3)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
LINE=N
NSTART=0
NEND=0
if ((mv(n,4).lt.0.d0).and.(mv(n,5).gt.0.d0)) then
starttime=0.d0
else
STARTTIME=MV(N,4)
endif
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ELSE
NSTART=0
NEND=0
STARTTIME=FORMTIME
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ENDIF
ELSE
C--do scattering
C--find delta t for the scattering
DELTAT=TLEFT
OVERQ0=.FALSE.
CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,
& OVERQ0,.FALSE.)
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
C--do initial state splitting if there is one
NOLD=N
LINEOLD=LINE
oldstcode=k(line,1)
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
nscatcenold=nscatcen
25 IF(X.LT.1.d0) THEN
CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT)
IF(DISCARD) RETURN
IF(X.LT.1.d0)THEN
LINE=N
LKINE=N
IF(K(LINE,2).EQ.21)THEN
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ELSE
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ENDIF
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ELSE
LKINE=LINE
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
ENDIF
ENDIF
IF(X.EQ.1.d0)THEN
NEWMASS=0.d0
IF(NEND.GT.0)THEN
CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT,
& NEWMASS,OVERQ0,ZDEC,QQBARDEC)
IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN
MEDIND=.TRUE.
ELSE
MEDIND=.FALSE.
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ENDIF
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
LKINE=LINE
ENDIF
ENDIF
C--do kinematics
RETRYSPLIT=.FALSE.
IF(NEND.GT.0) THEN
nendold=nend
CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT,
& STARTTIME+TSUM,X,ZDEC,QQBARDEC)
IF(RETRYSPLIT) THEN
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
if (x.lt.1.d0) then
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
N=NOLD
LINE=LINEOLD
X=1.d0
K(LINE,1)=oldstcode
! K(LINE,1)=1
nscatcen=nscatcenold
NSPLIT=NSPLIT-EVWEIGHT
nspliti=nspliti-evweight
GOTO 25
else
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
endif
ELSE
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
ELSE
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
! IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE.
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))) RADIATION=.TRUE.
ENDIF
21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))
& .OR.(STARTTIME.LT.LTIME))THEN
GOTO 20
ENDIF
IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4
IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5
END
***********************************************************************
*** subroutine makesplitting
***********************************************************************
SUBROUTINE MAKESPLITTING(L)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,DIR
DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC,
&GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA,
&GETTEMP
LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4)
XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4)
XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4)
IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN
THETA=-1.d0
ELSE
THETA=THETAA(L)
ENDIF
C--on-shell partons cannot split
IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)
& .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3)
& .or.(zd(l).lt.0.d0)) GOTO 31
C--quark or gluon?
IF(K(L,2).EQ.21)THEN
QUARK=.FALSE.
ELSE
QUARK=.TRUE.
QQBAR=.FALSE.
ENDIF
C--if gluon decide on kind of splitting
QQBAR=QQBARD(L)
C--if g->gg splitting decide on colour order
IF(QUARK.OR.QQBAR)THEN
DIR=0
ELSE
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ENDIF
Z=ZD(L)
IF(Z.EQ.0.d0)THEN
write(logfid,*)'makesplitting: z=0',L,p(l,5)
call pevrec(2,.false.)
goto 36
ENDIF
GOTO 35
C--generate z value
36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN
C--additional z constraint due to angular ordering
QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2)
IF(QH.GT.1)THEN
write(logfid,*)L,': reject event: angular ordering
& conflict in medium'
CALL PYLIST(2)
DISCARD=.TRUE.
GOTO 31
ENDIF
EPS=0.5-0.5*SQRT(1.-QH)
ELSE
EPS=0d0
ENDIF
IF(QUARK)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ')
ELSE
IF(QQBAR)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG')
ELSE
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG')
ENDIF
ENDIF
35 CONTINUE
C--maximum virtualities for daughters
BMAX1=MIN(P(L,5),Z*P(L,4))
CMAX1=MIN(P(L,5),(1.-Z)*P(L,4))
C--generate mass of quark or gluon (particle b) from Sudakov FF
30 IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
C--generate mass gluon (particle c) from Sudakov FF
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
C--quark (parton b) momentum
182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3))
PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2
C--if kinematics doesn't work out, generate new virtualities
C for daughters
C--massive phase space weight
IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0)
& .OR.((MB+MC).GT.P(L,5)))THEN
IF(MB.GT.MC)THEN
IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
ELSE
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
ENDIF
GOTO 182
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(QQBAR)THEN
K(N-1,2)=-1
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1-Z)*P(L,4)
P(N-1,5)=MC
ZA(N-1)=1.-Z
IF(ZDECC.GT.0.d0)THEN
THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4))
ELSE
THETAA(N-1)=0.d0
ENDIF
ZD(N-1)=ZDECC
QQBARD(N-1)=QQBARDECC
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(QUARK)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(QQBAR)THEN
K(N,2)=1
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
K(N,2)=21
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=Z*P(L,4)
P(N,5)=MB
ZA(N)=Z
IF(ZDECB.GT.0.d0)THEN
THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4))
ELSE
THETAA(N)=0.d0
ENDIF
ZD(N)=ZDECB
QQBARD(N)=QQBARDECB
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(PTS)*COS(PHIQ)
P(N,2)=SQRT(PTS)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N,5)=0.d0
ENDIF
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nsplitf=nsplitf+evweight
31 CONTINUE
END
***********************************************************************
*** subroutine makeinsplit
***********************************************************************
SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,TYPI,NOLD,DIR
DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
&PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC
LOGICAL QQBARDEC
CHARACTER*2 TYP2,TYPC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
IF(TYPI.EQ.21)THEN
TYP2='GG'
TYPC='GC'
ELSE
TYP2='QG'
TYPC='QQ'
ENDIF
ELSE
IF(TYPI.EQ.21)THEN
TYP2='GQ'
TYPC='QQ'
ELSE
TYP2='QQ'
TYPC='GC'
ENDIF
ENDIF
C--if g->gg decide on colour configuration
IF(TYP2.EQ.'GG')THEN
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
DIR=0
ENDIF
MB2=VIRT**2
MB2=P(L,5)**2-MB2
! MB2=-VIRT**2
MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0,
& (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4),
& .FALSE.,ZDEC,QQBARDEC)**2
C--rotate such that momentum points in z-direction
NOLD=N
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
MC2=0.d0
IF(K(L,1).EQ.2) zdec = -1.d0
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
X=1.d0
RETURN
ENDIF
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(TYP2.EQ.'QG')THEN
K(N-1,2)=-TYPI
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ENDIF
ELSEIF(TYP2.EQ.'GQ')THEN
K(N-1,2)=K(L,2)
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=COLMAX+1
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1.-X)*P(L,4)
P(N-1,5)=SQRT(MC2)
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(TYP2.EQ.'QG')THEN
K(N,2)=TYPI
IF(K(N,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=ANTI(L)
ENDIF
ELSEIF(TYPI.NE.21)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSE
K(N,2)=21
IF(K(N-1,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(K(N-1,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ELSE
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=X*P(L,4)
IF(MB2.LT.0.d0)THEN
P(N,5)=-SQRT(-MB2)
ELSE
P(N,5)=SQRT(MB2)
ENDIF
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(KT2)*COS(PHIQ)
P(N,2)=SQRT(KT2)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(L,5)=TIME-TAURAD
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
MV(N,5)=TIME
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=ZDEC
QQBARD(N-1)=QQBARDEC
ZA(N)=1.d0
THETAA(N)=-1.d0
ZD(N)=0.d0
QQBARD(N)=.FALSE.
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nspliti=nspliti+evweight
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
END
***********************************************************************
*** subroutine doinstatescat
***********************************************************************
SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0,
& RETRYSPLIT)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT,
&WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT,
&XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS,
&GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD,
&GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT,
&pyp
LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT,
&QQBARDUM
CHARACTER TYP
CHARACTER*2 TYP2
DATA PI/3.141592653589793d0/
DATA COUNTMAX/10000/
COUNTER=0
XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4)
YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4)
ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4)
TSC=TSTART
MD1=GETMD(XSC,YSC,ZSC,TSC)
MS1=GETMS(XSC,YSC,ZSC,TSC)
IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN
write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC),
&GETNEFF(XSC,YSC,ZSC,TSC)
ENDIF
C--check for scattering
NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT)
IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116
C--decide whether there will be radiation
PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc)
IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN
NORAD=.TRUE.
ELSE
NORAD=.FALSE.
ENDIF
C--decide whether q or g is to be scattered
IF(K(L,2).EQ.21)THEN
TYP='G'
TYP2='GC'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','Q',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'G','C',xsc,ysc,zsc,tsc,0)
ELSE
TYP='Q'
TYP2='QQ'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','G',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'Q','C',xsc,ysc,zsc,tsc,0)
ENDIF
IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN
write(logfid,*)'error: flavour change probability=',
& PFCHANGE,'for ',TYP
ENDIF
IF(PYR(0).LT.PFCHANGE)THEN
FCHANGE=.TRUE.
ELSE
FCHANGE=.FALSE.
ENDIF
IF (NORAD) FCHANGE=.FALSE.
C--set TYPI
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
TYPI=INT(SIGN(2.d0,PYR(0)-0.5))
ELSE
TYPI=K(L,2)
ENDIF
ELSE
IF(FCHANGE)THEN
TYPI=21
ELSE
TYPI=K(L,2)
ENDIF
ENDIF
LOW=Q0**2/SCALEFACM**2
TMAX=4.*(P(L,4)**2-P(L,5)**2)
XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX)
IF(SIGMATOT.EQ.0.d0) GOTO 116
RTAU=PYR(0)
C--generate a trial emission
C--pick a x value from splitting function
112 COUNTER=COUNTER+1
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG')
ENDIF
ELSE
IF(FCHANGE)THEN
X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ENDIF
ENDIF
IF(NORAD) X=1.d0
C--initialisation
TMAXNEW=(X*P(L,4))**2
PHI=0.d0
TLEFT=DELTAT
TNOW=TSTART
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=-1.d-10
OVERQ0=.FALSE.
Q=P(L,5)
QOLD=P(L,5)
TAUEST=DELTAT
C--generate first momentum transfer
DELTAL=DT
NSTART=1
NEND=1
TNOW=TNOW+DELTAL
TSUM=DELTAL
TLEFT=TLEFT-DELTAL
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 118
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE.
C--get new virtuality
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
C--estimate formation time
111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN
TAUEST=DELTAT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
C--find number, position and momentum transfers of further scatterings
NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL)
IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN
C--add a momentum transfer
NEND=NEND+1
IF(NEND.GE.100)THEN
nend=nend-1
goto 114
ENDIF
TNOW=TNOW+DELTAL
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
C--update phase
IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4))
ENDIF
C--get new momentum transfer
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
COUNT2=0
119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 119
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF((-QSUM2.GT.LOW)
& .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE.
C--get new virtuality
QOLD=Q
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
GOTO 111
ENDIF
C--do reweighting
114 TMAXNEW=X**2*P(L,4)**2
IF(NORAD)THEN
WEIGHT=1.d0
Q=0.d0
X=1.d0
ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN
WEIGHT=0.d0
ELSEIF(-QSUM2.GT.P(L,4)**2)THEN
WEIGHT=0.d0
ELSE
IF(TYP.EQ.'G')THEN
FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg',
& FMAX
ENDIF
ENDIF
ENDIF
ELSE
FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq',
& FMAX
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))
& write(logfid,*)'error: weight=',WEIGHT
115 IF(PYR(0).GT.WEIGHT)THEN
IF(COUNTER.LT.COUNTMAX)THEN
GOTO 112
ELSE
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
RETURN
ENDIF
ENDIF
C--found meaningful configuration, now do final checks
C--check if phase is unity and weight with 1/Nscat
IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0)))
& .AND.(.NOT.NORAD))THEN
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
ELSE
IF(.NOT.NORAD)THEN
TLEFT=TLEFT-TAUEST
TNOW=TNOW+TAUEST
TSUM=TSUM+TAUEST
ENDIF
DELTAT=TSUM
ENDIF
RETURN
C--exit in case of failure
116 Q=0.d0
X=1.d0
NSTART=0
NEND=0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
OVERQ0=.FALSE.
TYPI=K(L,2)
RETURN
END
***********************************************************************
*** subroutine dofistatescat
***********************************************************************
SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS,
& OVERQ0,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--local variables
INTEGER L,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD,
&GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI,
&TAUEST,LOW,Z,pyp
LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR
CHARACTER TYP
DATA COUNTMAX/100/
DELTAL=0.d0
IF(-QSUM2.GT.P(L,4)**2)
& write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2
IF(K(L,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
LOW=Q0**2/SCALEFACM**2
TSUM=0.d0
PHI=0.d0
DELTAT=0.d0
C--check for radiation with first (given) momentum transfer
Q2OLD=0.d0
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ELSE
NEWMASS=P(L,5)
ENDIF
RTAU=PYR(0)
TLEFT=DTLEFT
222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN
TAUEST=TLEFT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL)
IF(.NOT.NOSCAT)THEN
C--do scattering
NEND=NEND+1
IF(NEND.gt.countmax)THEN
nend=nend-1
goto 218
ENDIF
IF(NSTART.EQ.0) NSTART=1
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4))
ENDIF
ALLQS(NEND,6)=TNOW+TSUM
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 219
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--figure out new virtuality
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ENDIF
GOTO 222
ENDIF
C--no more scattering
218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then
if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then
if (nend.eq.countmax) then
deltat=tsum
else if (TLEFT.LT.TAUEST) then
DELTAT=TSUM+tleft
else
DELTAT=TSUM+tauest
endif
NEWMASS=P(L,5)
ELSE
DELTAT=TSUM+TAUEST
ENDIF
else
DELTAT=0.d0
NSTART=1
NEND=1
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
NEWMASS=P(L,5)
endif
return
END
***********************************************************************
*** function getnewmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X,
& ZDEC,QQBARDEC)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L
DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
&GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD
LOGICAL IN,QQBARDEC,QQBAROLD
CHARACTER*2 TYP
IF(x*P(L,4).LT.Q0)THEN
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
IF (-Q2.LT.Q0**2)THEN
GETNEWMASS=0.d0
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
TYP='GC'
ELSE
TYP='QQ'
ENDIF
IF(SQRT(-QOLD2).LE.Q0)THEN
IF(IN)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
ELSE
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
ENDIF
GETNEWMASS=MIN(GETNEWMASS,X*P(L,4))
RETURN
ENDIF
Z=1.d0
QA=1.d0
IF(MAX(P(L,5),MASS).GT.0.d0)THEN
IF(-Q2.GT.-QOLD2)THEN
ZOLD=ZDEC
QQBAROLD=QQBARDEC
QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF(QTMP.LT.SQRT(-QOLD2))THEN
GETNEWMASS=MASS
ZDEC=ZOLD
QQBARDEC=QQBAROLD
ELSE
GETNEWMASS=QTMP
ENDIF
ELSE
PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
IF(PYR(0).LT.PKEEP)THEN
IF(P(L,5).LT.SQRT(-Q2))THEN
GETNEWMASS=MASS
ELSE
55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55
ENDIF
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
ELSE
IF(-Q2.GT.-QOLD2)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
if(getnewmass.lt.SQRT(-QOLD2))then
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
endif
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
GETNEWMASS=MIN(GETNEWMASS,x*P(L,4))
END
***********************************************************************
*** function getpnorad1
***********************************************************************
DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER LINE
DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT,
&SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd
md1 = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
ms1 = avmom(5)
shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4)
& -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3))
pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2
up = 4.*pcms2
LOW=Q0**2/SCALEFACM**2
IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN
GETPNORAD1=1.d0
RETURN
ENDIF
IF(K(LINE,2).EQ.21)THEN
CCOL=3./2.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'G','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=-1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'GB'))/SIGMATOT
ELSE
CCOL=2./3.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'Q','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'QB'))/SIGMATOT
ENDIF
IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN
write(logfid,*)'error: P_norad=',GETPNORAD1,
& P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1
ENDIF
END
***********************************************************************
*** subroutine getqvec
***********************************************************************
SUBROUTINE GETQVEC(L,J,DT,X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i
DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4),
&T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS,
&savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2,
&avmom(5)
CHARACTER TYPS
DATA PI/3.141592653589793d0/
DATA COUNTMAX/1000/
IF (J.GT.10000)THEN
discard = .true.
return
ENDIF
COUNTER=0
COUNT2=0
XSC=MV(L,1)+DT*P(L,1)/P(L,4)
YSC=MV(L,2)+DT*P(L,2)/P(L,4)
ZSC=MV(L,3)+DT*P(L,3)/P(L,4)
TSC=MV(L,4)+DT
md = GETMD(XSC,YSC,ZSC,TSC)
call AVSCATCEN(xsc,ysc,zsc,tsc,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
do 210 i=1,5
savemom(i) = p(l,i)
210 continue
xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8)
p(l,1) = xi*p(l,1)
p(l,2) = xi*p(l,2)
p(l,3) = xi*p(l,3)
p(l,4) = max(x*p(l,4),p(l,5))
444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
&K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5))
MV(1,1)=XSC
MV(1,2)=YSC
MV(1,3)=ZSC
MV(1,4)=TSC
TYPS='Q'
IF(K(1,2).EQ.21)TYPS='G'
shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4)
& -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3))
pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat)
& -savemom(5)**2
maxt = 4.*pcms2
K(1,1)=13
SCATCENTRES(J,1)=K(1,2)
SCATCENTRES(J,2)=P(1,1)
SCATCENTRES(J,3)=P(1,2)
SCATCENTRES(J,4)=P(1,3)
SCATCENTRES(J,5)=P(1,4)
SCATCENTRES(J,6)=P(1,5)
SCATCENTRES(J,7)=MV(1,1)
SCATCENTRES(J,8)=MV(1,2)
SCATCENTRES(J,9)=MV(1,3)
SCATCENTRES(J,10)=MV(1,4)
C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
C--pick a t from differential scattering cross section
204 T=-GETT(0.d0,MAXT,md)
202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5))
NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3))
PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
IF(DABS(PT2).LT.1.d-10) PT2=0.d0
IF(T.EQ.0.d0) PT2=0.d0
IF(PT2.LT.0.d0)THEN
T=0.d0
GOTO 202
ENDIF
PT=SQRT(PT2)
PHI2=PYR(0)*2*PI
NEWMOM(1)=PT*COS(PHI2)
NEWMOM(2)=PT*SIN(PHI2)
P(1,1)=NEWMOM(1)-P(L,1)
P(1,2)=NEWMOM(2)-P(L,2)
P(1,3)=NEWMOM(3)-P(L,3)
P(1,4)=NEWMOM(4)-P(L,4)
P(1,5)=0.d0
C--transformation to lab
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
ALLQS(J,1)=T
ALLQS(J,2)=P(1,1)
ALLQS(J,3)=P(1,2)
ALLQS(J,4)=P(1,3)
ALLQS(J,5)=P(1,4)
QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(QSUM2.GT.0.d0)THEN
QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(COUNTER.GT.COUNTMAX)THEN
write(logfid,*)'GETQVEC unable to find q vector'
ALLQS(J,1)=0.d0
ALLQS(J,2)=0.d0
ALLQS(J,3)=0.d0
ALLQS(J,4)=0.d0
ALLQS(J,5)=0.d0
ELSE
COUNTER=COUNTER+1
GOTO 444
ENDIF
ENDIF
do 211 i=1,5
p(l,i) = savemom(i)
211 continue
END
***********************************************************************
*** subroutine dokinematics
***********************************************************************
SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT,
& TIME,X,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold
DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T,
&NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp,
&m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old,
&newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2,
&ys,p3boost,pboost,m42,localt,oldt,precoil,qmass2,pdummy,pproj
double precision m4,z4,getmass,getms,getmd
double precision thetasub,phisub,rapsub
CHARACTER*2 TYP
LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle,
&softrec,splitrec,isrecoil
DATA PI/3.141592653589793d0/
data pdummy/1.d-6/
if (newm.ne.p(l,5)) then
if (p(l,5).lt.0.d0) then
nistry = nistry+evweight
else
nfstry = nfstry+evweight
endif
endif
IF((N+2*(n2-n1+1)).GT.22990)THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
if (k(l,1).eq.2) then
isrecoil = .true.
else
isrecoil = .false.
endif
firsttime = mv(l,5)
redokin = .false.
nttot=nttot+(n2-n1+1)*evweight
newm2=newm
nold=n
nscatcenold=nscatcen
colmaxold=colmax
statold=k(l,1)
204 DELTAM=NEWM2-P(L,5)
DMLEFT=DELTAM
TTOT=0.d0
DO 220 J=N1,N2
TTOT=TTOT+ALLQS(J,1)
220 CONTINUE
LINE=L
DO 222 J=N1,N2
splitrec = .false.
C--projectile type
IF(K(LINE,2).EQ.21)THEN
TYP='GC'
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
TYP='QQ'
DIR=0
ENDIF
K(1,1)=6
K(1,2)=SCATCENTRES(J,1)
P(1,1)=SCATCENTRES(J,2)
P(1,2)=SCATCENTRES(J,3)
P(1,3)=SCATCENTRES(J,4)
P(1,4)=SCATCENTRES(J,5)
P(1,5)=SCATCENTRES(J,6)
MV(1,1)=SCATCENTRES(J,7)
MV(1,2)=SCATCENTRES(J,8)
MV(1,3)=SCATCENTRES(J,9)
MV(1,4)=SCATCENTRES(J,10)
T=ALLQS(J,1)
if (t.eq.0.d0) then
rejectt = .true.
else
rejectt = .false.
endif
IF(TTOT.EQ.0.d0)THEN
DM=0.d0
ELSE
if (dmleft.lt.0.d0) then
DM=max(DMLEFT*T/TTOT*1.5d0,dmleft)
else
DM=min(DMLEFT*T/TTOT*1.5d0,dmleft)
endif
ENDIF
TTOT=TTOT-ALLQS(J,1)
C--transform to c.m.s. and rotate such that parton momentum is in z-direction
BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4))
BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4))
BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4))
IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0)
& .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN
reshuffle = .false.
else
reshuffle = .true.
endif
! reshuffle = .false.
205 if (.not.reshuffle) then
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
if (kinmode.eq.0)then
m42 = 0.d0
elseif (kinmode.eq.1)then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
maxt = -2.*p(1,5)*p(line,4) - p(1,5)**2 + m42
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
dm = 0.d0
m42 = p(1,5)**2
endif
m12 = -p(line,5)**2
203 newmass = p(line,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) then
enew = p(line,4)
else
enew = p(line,4)+(t+p(1,5)**2-m42)/(2.*p(1,5))
endif
pl = (t+2.*p(line,4)*enew-m12-m32)/(2.*p(line,3))
pt2 = enew**2-pl**2-m32
if (t.eq.0.d0) pt2 = 0.d0
if (dabs(pt2).lt.1.d-8) pt2 = 0.d0
if (pt2.lt.0.d0) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 203
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 203
else
write(logfid,*)' This should not have happened: pt^2<0!'
write(logfid,*)t,enew,pl,pt2
t = 0.d0
m42 = p(1,5)**2
rejectt = .true.
goto 203
endif
endif
pt = sqrt(pt2)
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=pt*cos(phi2)
p(n,2)=pt*sin(phi2)
p(n,3)=pl
p(n,4)=enew
p(n,5)=sign(sqrt(abs(m32)),newmass)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-sqrt(m42)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass (no rs): ',
& p(n-1,5),p(1,5),p(l,5),sqrt(m42),rejectt
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
else
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
reshuffle = .false.
goto 205
endif
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
shat = (p(1,4)+p(line,4))**2
p3old = p(line,3)
maxt = -4.*p(line,3)**2
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
ntrej=ntrej+evweight
endif
theta2 = acos(1.d0+t/(2.*p(line,3)**2))
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=p(line,3)*sin(theta2)*cos(phi2)
p(n,2)=p(line,3)*sin(theta2)*sin(phi2)
p(n,3)=p(line,3)*cos(theta2)
p(n,4)=p(line,4)
p(n,5)=p(line,5)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass: ',
& p(n-1,5),p(1,5),p(l,5)
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
C--outgoing projectile
K(N,1)=K(LINE,1)
if (isrecoil.and.(newm.gt.p(l,5)).and.(p(n,5).gt.q0)
& .and.(j.eq.n2)) then
k(n,1)=1
endif
K(N,2)=K(LINE,2)
! K(N,3)=L
K(N,3)=LINE
K(N,4)=0
K(N,5)=0
ZA(N)=1.d0
THETAA(N)=-1.d0
if ((k(n,1).eq.2).and.(z.eq.0.d0)) then
zd(n) = -1.d0
else
ZD(N)=Z
endif
QQBARD(N)=QQBAR
C--take care of incoming projectile
IF(K(LINE,1).EQ.1)THEN
K(LINE,1)=12
ELSE
write(*,*)line,k(line,1)
K(LINE,1)=14
call pevrec(2,.false.)
call exit(1)
ENDIF
K(LINE,4)=N-1
K(LINE,5)=N
C--temporary status code, will be overwritten later
K(N-1,1)=3
K(N-1,2)=21
K(N-1,3)=0
K(N-1,4)=0
K(N-1,5)=0
if (reshuffle) then
C--adjust mass and re-shuffle momenta
if (kinmode.eq.0) then
m42 = 0.d0
elseif (kinmode.eq.1) then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
206 newmass = p(n,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
E3new = (shat + m32 - m42)/(2.d0*sqrt(shat))
E4new = (shat - m32 + m42)/(2.d0*sqrt(shat))
p32 = E3new**2 - m32
p42 = E4new**2 - m42
if ((p32.lt.0.d0).or.(p42.lt.0.d0).or.
& (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (m42.eq.0.d0) then
p42 = 1.d-4
else
p42 = 0.d0
endif
E4new = sqrt(p42 + m42)
E3new = sqrt(shat) - E4new
p32 = E4new**2 - m42
m32 = E3new**2 - E4new**2 + m42
if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 206
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 206
endif
m42 = p(1,5)**2
E3new = p(n,4)
E4new = p(n-1,4)
p32 = p3old**2
p42 = p3old**2
if (p(n,5).lt.0.d0) then
m32 = -p(n,5)**2
else
m32 = p(n,5)**2
endif
endif
endif
p(n,1) = sqrt(p32)*p(n,1)/p3old
p(n,2) = sqrt(p32)*p(n,2)/p3old
p(n,3) = sqrt(p32)*p(n,3)/p3old
p(n,4) = E3new
p(n,5) = sign(sqrt(abs(m32)),newmass)
tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2-m32
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up projectiles mass (rs):',
& tmp,m32,p(n,5),dm,m42,p32
!---------------------------------
p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old
p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old
p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old
p(n-1,4) = E4new
p(n-1,5) = sqrt(m42)
tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
& -p(n-1,5)**2
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up scattering centres mass (rs):',
& tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or.
& (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or.
& (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) then
write(logfid,*) 'Oups, momentum not conserved (rs)',
& p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3)
write(logfid,*) m42,dm,E3new,E4new
endif
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
! write(*,*)((p(n-1,4)-p(1,4))**2-(p(n-1,1)-p(1,1))**2
! & -(p(n-1,2)-p(1,2))**2-(p(n-1,3)-p(1,3))**2)/t
C--transformation to lab
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
if (.not.allhad) then
k(n-1,1)=13
softrec=.false.
else
C--boost to fluid rest frame
ys = 0.5*log((mv(1,4)+mv(1,3))/(mv(1,4)-mv(1,3)))
p3boost = sinh(-ys)*p(n-1,4) + cosh(-ys)*p(n-1,3)
pboost = sqrt(p3boost**2+p(n-1,1)**2+p(n-1,2)**2)
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
if (pboost.lt.(recsoftcut*3.*localt)) then
softrec = .true.
k(n-1,1)=13
else
softrec = .false.
if (scatrecoil.and.(pboost.GT.(rechardcut*3.*localt))) THEN
K(N-1,1)=2
else
K(N-1,1)=3
ENDIF
endif
endif
if (rejectt) k(n-1,1)=11
C--outgoing projectile
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF(K(N,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=COLMAX+1
ANTI(N)=ANTI(LINE)
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=COLMAX+1
ENDIF
ELSEIF(K(N,2).GT.0)THEN
TRIP(N)=COLMAX+1
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=ANTI(LINE)
ENDIF
C--outgoing scattering centre
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(LINE)
ANTI(N-1)=TRIP(N)
ELSE
TRIP(N-1)=ANTI(N)
ANTI(N-1)=ANTI(LINE)
ENDIF
ELSE
TRIP(N-1)=0
ANTI(N-1)=0
ENDIF
C--outgoing scattering centre
if (splitrec) then
if (k(n-1,1).eq.2) k(n-1,1)=1
ZA(N-1)=1.d0
THETAA(N-1)=P(n-1,5)/(SQRT(Z4*(1.-Z4))*P(n-1,4))
ZD(N-1)=z4
QQBARD(N-1)=qqbardec
else
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=-1.d0
QQBARD(N-1)=.false.
endif
MV(N,4)=MV(1,4)
MV(N-1,4)=MV(1,4)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(line,1)
& +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N-1,2)=MV(line,2)
& +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N-1,3)=MV(line,3)
& +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
MV(N, 1)=MV(line,1)
& +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N, 2)=MV(line,2)
& +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N, 3)=MV(line,3)
& +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
IF(P(N-1,5).GT.P(1,5))THEN
LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2)
MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
IF(J.LT.N2)THEN
MV(N,5)=SCATCENTRES(J+1,10)
ELSE
IF(P(N,5).GT.0.d0)THEN
IF(DELTAM.EQ.0.d0)THEN
ENDTIME=firsttime
ELSE
IF(X.LT.1.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
ENDTIME=TIME
ENDIF
ENDIF
MV(N,5)=ENDTIME
ELSE
MV(N,5)=0.d0
ENDIF
ENDIF
MV(LINE,5)=ALLQS(J,6)
if ((.not.redokin).and.(.not.rejectt)) NSCAT=NSCAT+EVWEIGHT
C--store scattering centre before interaction in separate common block
if (writescatcen.and.(.not.rejectt).and.
& (nscatcen.lt.maxnscatcen)) then
nscatcen = nscatcen+1
if (nscatcen.gt.maxnscatcen) then
write(logfid,*)
&'WARNING: no room left to store further scattering centres'
goto 230
endif
if (recmode.eq.0) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.1) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
! precoil = sqrt(p(n-1,1)**2+p(n-1,2)**2+p(n-1,3)**2)
! dummies(nscatcen,1) = pdummy*p(n-1,1)/precoil
! dummies(nscatcen,2) = pdummy*p(n-1,2)/precoil
! dummies(nscatcen,3) = pdummy*p(n-1,3)/precoil
! dummies(nscatcen,4) = pdummy
C--------------------
c phisub = pyp(n-1,15)
c rapsub = pyp(n-1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = p(n-1,1)*pdummy/p(n-1,4)
dummies(nscatcen,2) = p(n-1,2)*pdummy/p(n-1,4)
dummies(nscatcen,3) = p(n-1,3)*pdummy/p(n-1,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.2) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil = sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
elseif (recmode.eq.3) then
if (softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil=sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
else
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
endif
endif
230 continue
! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then
! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5)
! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5)
! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5)
! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
! write(*,*)t
! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
! write(*,*)
! endif
DMLEFT=DMLEFT-(p(n,5)-P(LINE,5))
LINE=N
tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2
if (abs(tmp).ge.1.d-6)
& write(logfid,*)'dokinematics 4-momentum test failed:',
& tmp,j,p(l,5),p(line,5),p(n,5),reshuffle
222 CONTINUE
if (p(n,5).lt.0.d0) then
nisfail = nisfail+evweight
RETRYSPLIT=.TRUE.
return
endif
if (p(n,5).ne.newm2) then
RETRYSPLIT=.TRUE.
redokin = .true.
nfsfail = nfsfail+evweight
n=nold
colmax=colmaxold
nscatcen=nscatcenold
k(l,1)=statold
if (p(l,5).lt.0.d0) then
newm2 = 0.d0
else
if ((p(l,5).lt.q0).and.(k(l,1).ne.14)) then
if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then
newm2=q0+1.d-6
else
newm2=0.d0
! nisfail = nisfail+evweight
! RETRYSPLIT=.TRUE.
! write(*,*)'dokinematics takes the dubious exit'
! return
endif
else
newm2=p(l,5)
if (k(l,1).eq.14) z = 0.d0
endif
n2=n1
endif
goto 204
endif
if ((k(n,1).eq.1).and.
& ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))))
&write(logfid,*)'dokinematics did not reach sensible mass: ',l,
&p(n,5),newm,p(l,5),newm2
NSCATEFF=NSCATEFF+EVWEIGHT
END
***********************************************************************
*** function getproba
***********************************************************************
DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE,
& T1,INS2)
IMPLICIT NONE
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1
CHARACTER*2 TYPE
LOGICAL INS2
QA=QAA
ZA2=ZAA
EB=EBB
TYP=TYPE
T=T1
INSTATE=INS2
GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2)
& *DERIV(QF,1)
END
***********************************************************************
*** function getsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
& TYPE3,T2,INS)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI,
&HFIRST,T2,GETINSUDAFAST,QB2
CHARACTER*2 TYPE3
LOGICAL INS
DATA EPSI/1.d-4/
QB2=QB1
IF(INS)THEN
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ELSE
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ENDIF
IF(QB2.GE.(QMAX1-1.d-10)) THEN
GETSUDAKOV=1.d0
ELSE
IF(INS)THEN
GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3)
ELSE
QA=QA1
ZA2=ZA1
EB=EB1
TYP=TYPE3
T=T2
INSTATE=.FALSE.
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1)
GETSUDAKOV=EXP(-YSTART)
ENDIF
ENDIF
END
***********************************************************************
*** function getinsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI,
&HFIRST
CHARACTER*2 TYPE3
DATA EPSI/1.d-4/
QB1=QB
IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1
IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12
IF(QB1.GE.(QMAX1-1.d-12)) THEN
GETINSUDAKOV=1.d0
ELSE
TYP=TYPE3
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6)
GETINSUDAKOV=EXP(-YSTART)
ENDIF
END
***********************************************************************
*** function deriv
***********************************************************************
DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
INTEGER W4
DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI,
&GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ,
&MEDDERIV
DATA PI/3.141592653589793d0/
IF(W4.EQ.1)THEN
C--Sudakov integration
IF(INSTATE)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSE
DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL
ENDIF
ELSEIF(W4.EQ.2)THEN
C--P(q->qg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)*
& PQQ(XVAL)/(2.*PI)
ELSEIF(W4.EQ.3)THEN
C--P(g->gg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)
& *PGG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.4)THEN
C--P(g->qq) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)*
& PQG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.5)THEN
DERIV=EXP(-XVAL)/XVAL
ELSEIF(W4.EQ.6)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSEIF(W4.EQ.7)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.8)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PGQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.9)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.10)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)*
& *2.*PGG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.11)THEN
DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ')
& *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL)
ELSEIF(W4.EQ.12)THEN
DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG')
& *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL)
ELSEIF(W4.EQ.13)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC')
& *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.14)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ')
& *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.21)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ')
& /XVAL
ELSEIF(W4.EQ.22)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ')
& /XVAL
ELSEIF(W4.EQ.23)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG')
& /XVAL
ELSEIF(W4.EQ.24)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2.
& *GETINSPLITI(XVAL,'GG')/XVAL
ELSE
DERIV=MEDDERIV(XVAL,W4-100)
ENDIF
END
***********************************************************************
*** function getspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE
DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y,
&SPLITINTGG,SPLITINTQG,A,B,YB(2)
CHARACTER*2 TYPE1
ntotspliti=ntotspliti+1
if (qb.gt.qmax) then
noverspliti=noverspliti+1
if (noverspliti.le.25)
& write(logfid,*)'WARNING in getspliti: need to extrapolate: ',
& qb,qmax
endif
C--find boundaries for z integration
IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)))
ELSE
LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2)
ENDIF
C--find values in array
QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1)
QLINE=MAX(QLMAX,1)
QLINE=MIN(QLINE,NPOINT)
ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/
& (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1)
ZLINE=MAX(ZLMAX,1)
ZLINE=MIN(ZLINE,NPOINT)
IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR.
& (QLINE.LT.1).OR.(ZLINE.LT.1))THEN
write(logfid,*)'ERROR in GETSPLITI: line number out of bound',
& QLINE,ZLINE
ENDIF
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 17 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 16 J=1,2
YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
16 CONTINUE
17 CONTINUE
DO 30 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
30 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=MIN(Y,10.d0)
ELSE
SPLITINTGG=MIN(Y,10.d0)
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
DO 19 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 18 J=1,2
YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
18 CONTINUE
19 CONTINUE
DO 31 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
31 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=NF*MIN(Y,10.d0)
ELSE
SPLITINTQG=NF*MIN(Y,10.d0)
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
DO 21 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 20 J=1,2
YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
20 CONTINUE
21 CONTINUE
DO 32 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
32 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getinspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
UP = 1. - Q0**2/(4.*QB**2)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - LOG(LOG((1.-UP)*QB**2/LPS**2))
& + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + LOW - LOG(LOW) - UP + LOG(UP) )
& *3.*12.*PI/(2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'GG')THEN
GETINSPLITI=Y
ELSE
SPLITINTGG=Y
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 )
& *12.*PI/(2.*2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'QG')THEN
GETINSPLITI=NF*Y
ELSE
SPLITINTQG=NF*Y
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
& + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GQ')THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW))
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getpdf
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN
write(logfid,*)'error in GETPDF: parameter out of bound',X,Q
GETPDF=0.d0
RETURN
ENDIF
IF(TYP.EQ.'QQ')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GQ')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'QG')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GG')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10)
ENDIF
GETPDF=YSTART
ELSE
write(logfid,*)'error: pdf-type ',TYP,' does not exist'
GETPDF=0.d0
ENDIF
END
***********************************************************************
*** function getpdfxint
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER J,Q2CLOSE,Q2LINE
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP
ntotpdf=ntotpdf+1
if (q**2.gt.QINQX(1,1000)) then
noverpdf=noverpdf+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ',
& q**2,QINQX(1,1000)
endif
Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/
& (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1)
Q2LINE=MAX(Q2CLOSE,1)
Q2LINE=MIN(Q2LINE,999)
IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN
write(logfid,*)'ERROR in GETPDFXINT: line number out of bound',
& Q2LINE
ENDIF
IF(TYP.EQ.'QQ')THEN
DO 11 J=1,2
XA(J)=QINQX(1,Q2LINE-1+J)
YA(J)=QINQX(2,Q2LINE-1+J)
11 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
DO 13 J=1,2
XA(J)=GINQX(1,Q2LINE-1+J)
YA(J)=GINQX(2,Q2LINE-1+J)
13 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
DO 15 J=1,2
XA(J)=QINGX(1,Q2LINE-1+J)
YA(J)=QINGX(2,Q2LINE-1+J)
15 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
DO 17 J=1,2
XA(J)=GINGX(1,Q2LINE-1+J)
YA(J)=GINGX(2,Q2LINE-1+J)
17 CONTINUE
ELSE
write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q**2+B
GETPDFXINT=Y
END
***********************************************************************
*** subroutine getpdfxintexact
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION Q,EPSI,YSTART,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
HFIRST=0.01d0
YSTART=0.d0
XMAX=Q
Z=0.d0
IF(TYP.EQ.'QQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21)
ELSEIF(TYP.EQ.'QG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23)
ELSEIF(TYP.EQ.'GQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22)
ELSEIF(TYP.EQ.'GG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24)
ENDIF
GETPDFXINTEXACT=YSTART
END
***********************************************************************
*** function getxsecint
***********************************************************************
DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J
DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B
CHARACTER*2 TYP2
ntotxsec=ntotxsec+1
if (tm.gt.intq1(1000,101)) then
noverxsec=noverxsec+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getxsecint: need to extrapolate: ',
& tm,intq1(1000,101)
endif
TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/
& (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1)
TLINE=MAX(TCLOSE,1)
TLINE=MIN(TLINE,999)
MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/
&(INTQ1(1001,100)-INTQ1(1001,1))+1)
MDLINE=MAX(MDCLOSE,1)
MDLINE=MIN(MDLINE,99)
IF((TLINE.GT.999).OR.(MDLINE.GT.99)
& .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN
write(logfid,*)'ERROR in GETXSECINT: line number out of bound',
& TLINE,MDLINE
ENDIF
IF(TYP2.EQ.'QA')THEN
C--first quark integral
DO 12 I=1,2
X1A(I)=INTQ1(1001,MDLINE-1+I)
X2A(I)=INTQ1(TLINE-1+I,101)
DO 11 J=1,2
YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP2.EQ.'QB')THEN
C--second quark integral
DO 18 I=1,2
X1A(I)=INTQ2(1001,MDLINE-1+I)
X2A(I)=INTQ2(TLINE-1+I,101)
DO 17 J=1,2
YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I)
17 CONTINUE
18 CONTINUE
ELSEIF(TYP2.EQ.'GA')THEN
C--first gluon integral
DO 14 I=1,2
X1A(I)=INTG1(1001,MDLINE-1+I)
X2A(I)=INTG1(TLINE-1+I,101)
DO 13 J=1,2
YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP2.EQ.'GB')THEN
C--second gluon integral
DO 16 I=1,2
X1A(I)=INTG2(1001,MDLINE-1+I)
X2A(I)=INTG2(TLINE-1+I,101)
DO 15 J=1,2
YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I)
15 CONTINUE
16 CONTINUE
ELSE
write(logfid,*)'error in GETXSECINT: unknown integral type ',
& TYP2
ENDIF
DO 19 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*TM+B
19 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=YB(1)
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*MD+B
ENDIF
GETXSECINT=Y
END
***********************************************************************
*** function getinsudafast
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Q1,Q2,GETINSUDARED
CHARACTER*2 TYP
IF(Q2.LE.Q1)THEN
GETINSUDAFAST=1.d0
ELSEIF(Q1.LE.Q0)THEN
GETINSUDAFAST=GETINSUDARED(Q2,TYP)
ELSE
GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP)
ENDIF
IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0
IF(GETINSUDAFAST.LT.(-1.d-10))THEN
write(logfid,*)'ERROR: GETINSUDAFAST < 0:',
& GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP
ENDIF
if (getinsudafast.lt.0.d0) getinsudafast = 0.d0
END
***********************************************************************
*** function getinsudared
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER QCLOSE,QBIN,I
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP2
ntotsuda=ntotsuda+1
if (q.gt.sudaqq(1000,1)) then
noversuda=noversuda+1
if (noversuda.le.25)
& write(logfid,*)'WARNING in getinsudared: need to extrapolate: ',
& q,sudaqq(1000,1)
endif
QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0
& /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1)
QBIN=MAX(QCLOSE,1)
QBIN=MIN(QBIN,999)
IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN
write(logfid,*)
& 'ERROR in GETINSUDARED: line number out of bound',QBIN
ENDIF
IF(TYP2.EQ.'QQ')THEN
DO 16 I=1,2
XA(I)=SUDAQQ(QBIN-1+I,1)
YA(I)=SUDAQQ(QBIN-1+I,2)
16 CONTINUE
ELSEIF(TYP2.EQ.'QG')THEN
DO 17 I=1,2
XA(I)=SUDAQG(QBIN-1+I,1)
YA(I)=SUDAQG(QBIN-1+I,2)
17 CONTINUE
ELSEIF(TYP2.EQ.'GG')THEN
DO 18 I=1,2
XA(I)=SUDAGG(QBIN-1+I,1)
YA(I)=SUDAGG(QBIN-1+I,2)
18 CONTINUE
ELSEIF(TYP2.EQ.'GC')THEN
DO 19 I=1,2
XA(I)=SUDAGC(QBIN-1+I,1)
YA(I)=SUDAGC(QBIN-1+I,2)
19 CONTINUE
ELSE
write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q+B
GETINSUDARED=Y
IF(GETINSUDARED.LT.(-1.d-10))THEN
write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2
ENDIF
if (getinsudared.lt.0.d0) getinsudared = 0.d0
END
***********************************************************************
*** function getsscat
***********************************************************************
DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2,
& x,y,z,t,mode)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
integer mode
DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP,
&LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp,
&x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct
CHARACTER TYPE1,TYPE2
IF(TYPE1.EQ.'Q')THEN
CCOL=2./3.
ELSE
CCOL=3./2.
ENDIF
if (mode.eq.0) then
mdeb = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
& avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 + mp**2 +
& 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
else
if (mode.eq.1) then
mdeb = getmdmin()
else
mdeb = getmdmax()
endif
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)
pproj = sqrt(px**2+py**2+pz**2)
shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
endif
LOW=LW**2
IF(LOW.GT.UP)THEN
GETSSCAT=0.d0
RETURN
ENDIF
IF((TYPE2.EQ.'C').OR.
& ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR.
& ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN
GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB))
! write(*,*)'getsscat 1',GETSSCAT
ELSE
GETSSCAT=0.d0
ENDIF
LOW=Q0**2/SCALEFACM**2
IF(UP.GT.LOW)THEN
IF(TYPE1.EQ.'Q')THEN
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ')
& *3.*SCATPRIMFUNC(UP,MDEB)/2.
GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA')
ENDIF
ELSE
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
& SCATPRIMFUNC(LOW,MDEB))
& - GETXSECINT(UP,MDEB,'GB')
! write(*,*)'getsscat 2',GETSSCAT,CCOL*(SCATPRIMFUNC(UP,MDEB)-
! & SCATPRIMFUNC(LOW,MDEB)),-GETXSECINT(UP,MDEB,'GB')
ENDIF
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG')
& *2.*SCATPRIMFUNC(UP,MDEB)/3.
GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA')
! write(*,*)'getsscat 3',getsscat,-2.*GETXSECINT(UP,MDEB,'GA')
ENDIF
ENDIF
ENDIF
IF(GETSSCAT.LT.-1.d-4) then
write(logfid,*) 'error: cross section < 0',GETSSCAT,'for',
& EN,mp,LW,TYPE1,TYPE2,LW**2,UP,mode
endif
GETSSCAT=MAX(GETSSCAT,0.d0)
END
***********************************************************************
*** function getmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE,
& MAX2,INS,ZDEC,QQBARDEC)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--local variables
DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec,
&q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin,
&gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti,
&r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin
CHARACTER*2 TYPE
LOGICAL INS,QQBARDEC
DATA PI/3.141592653589793d0/
q2min = q0**2
alphmax = alphas(3.*ptfac*q2min/16.,lps)
log14 = log(0.25)
IF(TYPE.EQ.'QQ')THEN
pref=4.*alphmax/(3.*2.*PI)
ELSE
pref=29.*alphmax/(8.*2.*PI)
ENDIF
C--check if phase space available, return 0.d0 otherwise
IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
q2max = qbmax**2
! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2))
! IF(pyr(0).LE.sudaover)THEN
21 if (q2max-qbmin**2.lt.1e-4)then
getmass=qbmin
zdec=0.5
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
endif
return
endif
gmax = pref*log(q2min/(4.*q2max))**2
if (qbmin.gt.0.d0) then
rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax)
else
rmin = 0.d0
endif
r=pyr(0)*(1.d0-rmin)+rmin
arg=gmax+log(r)
if(arg.lt.0.d0)then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
! r=pyr(0)
! gmin = pref*log14**2
! gmax = pref*log(q2min/(4.*q2max))**2
! arg = log(r*exp(gmax)+(1.-r)*exp(gmin))
cand = q2min*exp(sqrt(arg/pref))/4.
eps = q2min/(4.*cand)
if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN
q2max=cand
goto 21
ENDIF
if (ins) then
trueval=getinspliti(sqrt(cand),type)
oest = -2.*pref*log(eps)
weight = trueval/oest
else
C--find true z interval
TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand)
& *SQRT(1.-cand/EP**2)
IF(TRUEEPS.LT.EPS)
& WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS
RZ=PYR(0)
z = 1.-eps**rz
if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then
weight = 0.
else
if (type.eq.'QQ')then
! if (ins) then
! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! endif
oest = 2.*pref/(1.-z)
weight = trueval/oest
else
if (pyr(0).lt.(17./29.)) z = 1.-z
! if (ins)then
! trueval = alphas(ptfac*(1.-z)*cand,lps)
! & *(pgg(z)+pqg(z))/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)
& *(pgg(z)+pqg(z))/(2.*pi)
! endif
oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi)
weight = trueval/oest
endif
thetanew = sqrt(cand/(z*(1.-z)))/ep
if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta))
& weight = 0.d0
endif
endif
IF (WEIGHT.GT.1.d0) WRITE(logfid,*)
& 'problem in getmass: weight> 1',
& WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND
R2=PYR(0)
IF(R2.GT.WEIGHT)THEN
q2max=cand
GOTO 21
ELSE
getmass=sqrt(cand)
if (.not.ins) then
ZDEC=Z
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
ENDIF
endif
ENDIF
END
***********************************************************************
*** function generatez
***********************************************************************
DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
CHARACTER*2 TYPE
IF(TI.EQ.0.d0)THEN
EPS=EPSI
ELSE
EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
& *SQRT(1.-TI/EA**2),EPSI)
ENDIF
IF(EPS.GT.0.5)THEN
GENERATEZ=0.5
GOTO 61
ENDIF
60 R=PYR(0)
IF(TYPE.EQ.'QQ')THEN
X=1.-(1.-EPS)*(EPS/(1.-EPS))**R
R=PYR(0)
IF(R.LT.((1.+X**2)/2.))THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSEIF(TYPE.EQ.'GG')THEN
X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R))
R=PYR(0)
HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X)
IF(R.LT.HELP)THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSE
R=PYR(0)*(1.-2.*EPS)+EPS
R1=PYR(0)/2.
HELP=0.5*(R**2+(1.-R)**2)
IF(R1.LT.HELP)THEN
GENERATEZ=R
ELSE
GOTO 60
ENDIF
ENDIF
61 END
***********************************************************************
*** function scatprimfunc
***********************************************************************
DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
DATA PI/3.141592653589793d0/
SCATPRIMFUNC = 2.*PI*(12.*PI)**2*(
& - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2
& - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2
END
***********************************************************************
*** function intpqq
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2)
& +LOG(1.-Z)))/((33.-2.*NF)*3.)
END
***********************************************************************
*** function intpgglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpgghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpqglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function intpqghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function gett
***********************************************************************
DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
&MDEB,MINT,T
DATA PI/3.141592653589793d0/
TMAX=MAXT+MDEB**2
TMIN=MINT+MDEB**2
IF(TMIN.GT.TMAX) THEN
GETT=0.d0
RETURN
ENDIF
20 R1=PYR(0)
T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX))
R2=PYR(0)
IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN
GETT=T-MDEB**2
ELSE
GOTO 20
ENDIF
! 20 R1 = pyr(0);
! R2 = pyr(0);
! t = abs(mdeb**2*sqrt(-2.*log(R1))*cos(2.*pi*R2))
! if (t.gt.maxt) goto 20
! gett=t
! return
END
***********************************************************************
*** function ei
***********************************************************************
DOUBLE PRECISION FUNCTION EI(X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--local variables
INTEGER K,LINE,LMAX
DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B
DOUBLE PRECISION YSTART,EPSI,HFIRST
DATA EPSI/1.e-5/
IF(DABS(X).GT.VALMAX)
& write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX
IF(X.GE.0.d0)THEN
LMAX=INT(X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 26 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(3,LINE-1+K)
26 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*X+B
ELSE
LMAX=INT(-X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 27 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(2,LINE-1+K)
27 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=-A*X+B
ENDIF
EI=Y
END
***********************************************************************
*** function pqq
***********************************************************************
DOUBLE PRECISION FUNCTION PQQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
END
***********************************************************************
*** function pgq
***********************************************************************
DOUBLE PRECISION FUNCTION PGQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
END
***********************************************************************
*** function pgg
***********************************************************************
DOUBLE PRECISION FUNCTION PGG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
END
***********************************************************************
*** function pqg
***********************************************************************
DOUBLE PRECISION FUNCTION PQG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQG=0.5*(Z**2 + (1.-Z)**2)
END
***********************************************************************
*** function alphas
***********************************************************************
DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,L0,PI,LAMBDA
DATA PI/3.141592653589793d0/
ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
END
***********************************************************************
*** subroutine splitfncint
***********************************************************************
SUBROUTINE SPLITFNCINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER NSTEP,I,J
DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
&LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2
DATA ZMMAX/0.5/
DATA NSTEP/999/
DATA EPSI/1.d-5/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
ZMMIN=Q0/EMAX
LNZMMIN=LOG(ZMMIN)
LNZMMAX=LOG(ZMMAX)
NPOINT=NSTEP
DO 100 I=1,NSTEP+1
Q=(I-1)*(QMAX-Q0)/NSTEP+Q0
QVAL(I)=Q
QQUAD=Q**2
DO 110 J=1,NSTEP+1
ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
ZMVAL(J)=ZM
IF(Q**2.LT.Q0**2)THEN
ZM2=0.5
ELSE
ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2)
ENDIF
ZM=MAX(ZM,ZM2)
IF(ZM.EQ.0.5)THEN
SPLITIQQV(I,J)=0.d0
SPLITIGGV(I,J)=0.d0
SPLITIQGV(I,J)=0.d0
ELSE
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2)
SPLITIQQV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3)
SPLITIGGV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4)
SPLITIQGV(I,J)=YSTART
ENDIF
110 CONTINUE
100 CONTINUE
END
***********************************************************************
*** subroutine pdfint
***********************************************************************
SUBROUTINE PDFINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I,J
DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI,
&Q2MAX,DELTAQ2,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
q2max = scalefacm*4.*pcms2
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
QINQX(1,1)=Q0**2
GINQX(1,1)=Q0**2
QINGX(1,1)=Q0**2
GINGX(1,1)=Q0**2
QINQX(2,1)=0.d0
GINQX(2,1)=0.d0
QINGX(2,1)=0.d0
GINGX(2,1)=0.d0
DO 12 J=2,1000
Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2))
QINQX(1,J)=Q2
GINQX(1,J)=Q2
QINGX(1,J)=Q2
GINGX(1,J)=Q2
QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ')
GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ')
QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG')
GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG')
12 CONTINUE
END
***********************************************************************
*** subroutine xsecint
***********************************************************************
SUBROUTINE XSECINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER J,K
DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI,
&GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
tmaxmax = scalefacm*4.*pcms2
DELTATMAX=(LOG(TMAXMAX)-
& LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0
MDMIN=GETMDMIN()
MDMAX=MAX(MDMIN,GETMDMAX())
DELTAMD=(MDMAX-MDMIN)/99.d0
DO 12 J=1,1000
TMAX = EXP((J-1)*DELTATMAX
& + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))
INTQ1(J,101)=TMAX
INTQ2(J,101)=TMAX
INTG1(J,101)=TMAX
INTG2(J,101)=TMAX
DO 13 K=1,100
MDX=MDMIN+(K-1)*DELTAMD
INTQ1(1001,K)=MDX
INTQ2(1001,K)=MDX
INTG1(1001,K)=MDX
INTG2(1001,K)=MDX
IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN
INTQ1(J,K)=0.d0
INTQ2(J,K)=0.d0
INTG1(J,K)=0.d0
INTG2(J,K)=0.d0
ELSE
C--first quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,11)
INTQ1(J,K)=YSTART
C--second quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,14)
INTQ2(J,K)=YSTART
C--first gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,12)
INTG1(J,K)=YSTART
C--second gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,13)
INTG2(J,K)=YSTART
ENDIF
13 CONTINUE
12 CONTINUE
END
***********************************************************************
*** function insudaint
***********************************************************************
SUBROUTINE INSUDAINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I
DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5),
&shat,pcms2
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0
DO 22 I=1,1000
Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6)))
SUDAQQ(I,1)=Q
SUDAQG(I,1)=Q
SUDAGG(I,1)=Q
SUDAGC(I,1)=Q
SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ')
SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG')
SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG')
SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC')
22 CONTINUE
END
***********************************************************************
*** function eixint
***********************************************************************
SUBROUTINE EIXINT
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C-local variables
INTEGER I,K
DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R
DATA EPSI/1.d-6/
NVAL=1000
VALMAX=55.
DO 10 I=1,NVAL
X=I*VALMAX/(NVAL*1.d0)
EIXS(1,I)=X
C--do negative arguments first
YSTART=0d0
HFIRST=0.01
CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5)
EIXS(2,I)=-YSTART
C--now do the positive arguments
IF (X.EQ.0.0) THEN
EI=-1.0D+300
ELSE IF (X.LE.40.0) THEN
EI=1.0D0
R=1.0D0
DO 15 K=1,100
R=R*K*X/(K+1.0D0)**2
EI=EI+R
IF (DABS(R/EI).LE.1.0D-15) GO TO 20
15 CONTINUE
20 GA=0.5772156649015328D0
EI=GA+DLOG(X)+X*EI
ELSE
EI=1.0D0
R=1.0D0
DO 25 K=1,20
R=R*K/X
EI=EI+R
25 continue
EI=DEXP(X)/X*EI
ENDIF
EIXS(3,I)=EI
10 CONTINUE
END
***********************************************************************
*** function odeint
***********************************************************************
subroutine odeint(ystart,a,b,eps,h1,hmin,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer nmax,nstep,w1
double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx,
&deriv,yscale,hdid,hnew
data nmax/100000/
x = a
y = ystart
h = sign(h1,b-a)
do 20 nstep=1,nmax
dydx = deriv(x,w1)
yscale = abs(y) + abs(h*dydx) + 1.e-25
if (((x + h - b)*h).gt.0.) h = b-x
call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1)
if ((x - b)*h.ge.0) then
ystart = y
return
endif
h = hnew
if (abs(h).lt.abs(hmin)) then
write(logfid,*)'Error in odeint: stepsize too small',w1
& ,ystart,a,b,h1
return
endif
20 continue
write(logfid,*)'Error in odeint: too many steps',w1
& ,ystart,a,b,h1
end
***********************************************************************
*** function rkstepper
***********************************************************************
subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer w1
double precision x,y,dydx,htest,hdid,hnew,yscale,eps,
&yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown,
&powerup,maxup,maxdown,deriv,fac
logical reject
data powerdown/0.25/
data powerup/0.2/
data safety/0.9/
data maxdown/10./
data maxup/5./
reject = .false.
h = htest
10 xnew = x + h
if (x.eq.xnew) then
write(logfid,*)'Error in rkstepper: step size not significant'
return
endif
yhalf = rk4step(x,y,dydx,h/2.,w1)
dydxhalf = deriv(x+h/2.,w1)
y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1)
y1 = rk4step(x,y,dydx,h,w1)
delta = y2-y1
err = abs(delta)/(yscale*eps)
if (err.gt.1.) then
reject = .true.
fac = max(1./maxdown,safety/err**powerdown)
h = h*fac
goto 10
else
if (reject) then
hnew = h
else
fac = min(maxup,safety/err**powerup)
hnew = fac*h
endif
x = xnew
y = y2 + delta/15.
hdid = h
endif
end
***********************************************************************
*** function rk4step
***********************************************************************
double precision function rk4step(x,y,dydx,h,w1)
implicit none
integer w1
double precision x,y,dydx,h,k1,k2,k4,yout,deriv
k1 = h*dydx
k2 = h*deriv(x+h/2.,w1)
k4 = h*deriv(x+h,w1)
yout = y+k1/6.+2.*k2/3.+k4/6.
rk4step = yout
end
***********************************************************************
*** function getdeltat
***********************************************************************
LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pythia common block
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--local variables
INTEGER LINE,I,NNULL
DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR,
&R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN,
&XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF,
&GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN,
&SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT
CHARACTER PTYPE
LOGICAL STOPNOW
C--initialization
GETDELTAT=.FALSE.
DELTAT=0.D0
DTMAX=DTMAX1
IF(K(LINE,2).EQ.21)THEN
PTYPE='G'
ELSE
PTYPE='Q'
ENDIF
NNULL=0
STOPNOW=.FALSE.
C--check for upper bound from plasma lifetime
IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART
IF(DTMAX.LT.0.D0) RETURN
C--calculate time relative to production of the considered parton
TOFF=TSTART-MV(LINE,4)
XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4)
YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4)
ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4)
C--calculate upper limit for density*cross section
SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1)
SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2)
NEFFMAX=GETNEFFMAX()
NEFFMIN=GETNATMDMIN()
LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN)
if(linvmax.eq.0.d0) return
DO 333 I=1,1000000
DELTAT=DELTAT-LOG(PYR(0))/LINVMAX
XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4)
YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4)
ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4)
TS=TSTART+DELTAT
IF(TS.LT.ZS)THEN
TAU=-1.d0
ELSE
TAU=SQRT(TS**2-ZS**2)
ENDIF
NEFF=GETNEFF(XS,YS,ZS,TS)
IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN
IF(NNULL.GT.4)THEN
STOPNOW=.TRUE.
ELSE
NNULL=NNULL+1
ENDIF
ELSE
NNULL=0
ENDIF
IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN
DELTAT=DTMAX
RETURN
ENDIF
IF(NEFF.GT.0.d0)THEN
SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0)
ELSE
SIGMA=0.d0
ENDIF
WEIGHT=5.d0*NEFF*SIGMA/LINVMAX
IF(WEIGHT.GT.1.d0+1d-6) then
if (line.ne.errl) then
write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT,
& NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX),
& p(line,4)
errl=line
endif
endif
R=PYR(0)
IF(R.LT.WEIGHT)THEN
GETDELTAT=.TRUE.
RETURN
ENDIF
333 CONTINUE
END
***********************************************************************
*** function poissonian
***********************************************************************
integer function poissonian(lambda)
implicit none
integer n
double precision lambda,disc,p,pyr,u,v,pi
data pi/3.141592653589793d0/
if (lambda.gt.745.d0) then
u = pyr(0);
v = pyr(0);
poissonian =
& int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda)
else
disc=exp(-lambda)
p=1.d0
n=0
800 p = p*pyr(0)
if (p.gt.disc) then
n = n+1
goto 800
endif
poissonian=n
endif
end
***********************************************************************
*** subroutine makemassless
***********************************************************************
subroutine makemassless(l3,l1,l2)
implicit none
C--pythia common block
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer l1,l2,l3
double precision beta(3),Etot,E1new,E2new,E3new,p1new,p1new2
double precision m1,m2,pyp
beta(1)=(p(l1,1)+p(l2,1))/(p(l1,4)+p(l2,4))
beta(2)=(p(l1,2)+p(l2,2))/(p(l1,4)+p(l2,4))
beta(3)=(p(l1,3)+p(l2,3))/(p(l1,4)+p(l2,4))
call pyrobo(l1,l1,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
call pyrobo(l2,l2,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
call pyrobo(l3,l3,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
Etot=p(l1,4)+p(l2,4)+p(l3,4)
E3new=pyp(l3,8)
m1=p(l1,5)
m2=p(l2,5)
p1new2=(((Etot-E3new)**2-m1**2-m2**2)**2 - 4.*m1**2*m2**2)/
& (4.*(Etot-E3new)**2)
if (p1new2.lt.0.d0) write(logfid,*)'negative mass squared: ',p1new2
p1new=sqrt(abs(p1new2))
E1new=sqrt(p1new2+m1**2)
E2new=sqrt(p1new2+m2**2)
p(l1,1)=p(l1,1)*p1new/pyp(l1,8)
p(l1,2)=p(l1,2)*p1new/pyp(l1,8)
p(l1,3)=p(l1,3)*p1new/pyp(l1,8)
p(l1,4)=E1new
p(l2,1)=p(l2,1)*p1new/pyp(l2,8)
p(l2,2)=p(l2,2)*p1new/pyp(l2,8)
p(l2,3)=p(l2,3)*p1new/pyp(l2,8)
p(l2,4)=E2new
p(l3,4)=E3new
p(l3,5)=0.d0
call pyrobo(l1,l1,0.d0,0.d0,beta(1),beta(2),beta(3))
call pyrobo(l2,l2,0.d0,0.d0,beta(1),beta(2),beta(3))
call pyrobo(l3,l3,0.d0,0.d0,beta(1),beta(2),beta(3))
return
end
***********************************************************************
*** function ishadron
***********************************************************************
LOGICAL FUNCTION ISHADRON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.100) THEN
ISHADRON=.FALSE.
ELSE
IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN
ISHADRON = .FALSE.
ELSE
ISHADRON = .TRUE.
ENDIF
ENDIF
END
***********************************************************************
*** function isdiquark
***********************************************************************
LOGICAL FUNCTION ISDIQUARK(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.1000) THEN
ISDIQUARK=.FALSE.
ELSE
IF(MOD(INT(ID/10),10).EQ.0) THEN
ISDIQUARK = .TRUE.
ELSE
ISDIQUARK = .FALSE.
ENDIF
ENDIF
END
***********************************************************************
*** function islepton
***********************************************************************
LOGICAL FUNCTION ISLEPTON(ID)
IMPLICIT NONE
C-- local variables
INTEGER ID
IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN
ISLEPTON=.TRUE.
ELSE
ISLEPTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isparton
***********************************************************************
LOGICAL FUNCTION ISPARTON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
LOGICAL ISDIQUARK
IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN
ISPARTON=.TRUE.
ELSE
ISPARTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isprimstring
***********************************************************************
logical function isprimstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
isprimstring=.false.
return
endif
if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then
isprimstring=.true.
else
isprimstring=.false.
endif
end
***********************************************************************
*** function issecstring
***********************************************************************
logical function issecstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton,isprimstring
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
issecstring = .false.
return
endif
if (isprimstring(l)) then
issecstring = .false.
return
endif
if (isparton(K(K(K(l,3),3),2))) then
issecstring = .false.
else
issecstring = .true.
endif
end
***********************************************************************
*** function isprimhadron
***********************************************************************
logical function isprimhadron(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isprimstring,isparton
if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92))
& .and.isprimstring(K(l,3))
& .and.(.not.isparton(K(l,2)))) then
isprimhadron=.true.
else
isprimhadron=.false.
endif
if (k(l,1).eq.17) isprimhadron=.true.
end
***********************************************************************
*** function compressevent
***********************************************************************
logical function compressevent(l1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
integer l1,i,j,nold,nnew,nstart
nold = n
do 777 i=2,nold
if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)
& .or.(k(i,1).eq.14)).and.(i.ne.l1)) then
nnew = i
goto 778
endif
777 continue
compressevent = .false.
return
778 continue
nstart = nnew
do 779 i=nstart,nold
if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)
& .and.(k(i,1).ne.14)).or.(i.eq.l1)) then
do 780 j=1,5
p(nnew,j)=p(i,j)
v(nnew,j)=v(i,j)
mv(nnew,j)=mv(i,j)
780 continue
trip(nnew)=trip(i)
anti(nnew)=anti(i)
za(nnew)=za(i)
zd(nnew)=zd(i)
thetaa(nnew)=thetaa(i)
qqbard(nnew)=qqbard(i)
k(nnew,1)=k(i,1)
k(nnew,2)=k(i,2)
k(nnew,3)=0
k(nnew,4)=0
k(nnew,5)=0
if (l1.eq.i) l1=nnew
nnew=nnew+1
endif
779 continue
n=nnew-1
if ((nold-n).le.10) then
compressevent = .false.
else
compressevent = .true.
endif
do 781 i=nnew,nold
do 782 j=1,5
k(i,j)=0
p(i,j)=0.d0
v(i,j)=0.d0
mv(i,j)=0.d0
782 continue
trip(i)=0
anti(i)=0
za(i)=0.d0
zd(i)=0.d0
thetaa(i)=0.d0
qqbard(i)=.false.
781 continue
if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n
if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1
call flush(logfid)
return
end
***********************************************************************
*** subroutine pevrec
***********************************************************************
SUBROUTINE PEVREC(NUM,COL)
C--identifier of file for hepmc output and logfile
implicit none
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
INTEGER NUM,i
LOGICAL COL
DO 202 I=1,N
V(I,1)=MV(I,1)
V(I,2)=MV(I,2)
V(I,3)=MV(I,3)
V(I,4)=MV(I,4)
V(I,5)=MV(I,5)
! IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
! &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
! &ZD(I),THETAA(I)
IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
&K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
&'{ ',ZD(I),THETAA(I),QQBARD(I),'}'
202 CONTINUE
CALL PYLIST(NUM)
END
***********************************************************************
*** subroutine converttohepmc
***********************************************************************
SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2)
IMPLICIT NONE
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART,
&NFIRST,NVERTEX,NTOT,J,CODEFIRST
integer intinpt(2),intinmass(2),intinphi(2),intineta
integer intz,inttheta
DOUBLE PRECISION mproton,centr,getcentrality,jprodr,phi,pi,
&pdummy,pscatcen,mneutron
LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring,
&issecstring
character*2 beam1,beam2
data mproton/0.9383/
data mneutron/0.9396/
DATA PI/3.141592653589793d0/
5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6)
5100 FORMAT(A2,2E14.6)
! 5200 FORMAT(A2,9I2,4E14.6)
! 5200 FORMAT(A2,2I7,7I2,4E14.6)
5200 FORMAT(A2,6I7,2I2,1I7,4E14.6)
5300 FORMAT(A2,2I2,5E14.6,2I2)
! 5400 FORMAT(A2,I6,6I2,I6,I2)
5400 FORMAT(A2,2I6,5I2,I6,I2)
5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2)
PBARCODE=0
VBARCODE=0
centr = getcentrality()
jprodr = sqrt(x0**2+y0**2)
if (abs(y0).lt.1.d-8) then
if (x0.gt.0.d0) then
phi = 0.d0
else
phi = pi
endif
else
if (x0.gt.0.d0) then
if (y0.gt.0.d0) then
phi = atan(y0/x0)
else
phi = (3.d0*pi/2.d0) - atan(x0/y0)
endif
else
if (y0.gt.0.d0) then
phi = (pi/2.d0) - atan(x0/y0)
else
phi = pi + atan(y0/x0)
endif
endif
endif
do 140 i=1,2
intinpt(i) = int(inpt(i)*100.)
intinmass(i) = int(inmass(i)*100.)
intinphi(i) = int(inphi(i)*100.)
140 continue
intineta = int(ineta(1)*100.)
intz = int(inz(1)*10000.)
inttheta = int(intheta(1)*100.)
if (shorthepmc) then
C--short output
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
PBARCODE=5
ELSE
NVERTEX=1
PBARCODE=2
ENDIF
nfirst = 0
do 131 i=1,N
if (((k(i,1).lt.6).or.(k(i,1).eq.17)))
& nfirst = nfirst+1
131 continue
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1,
&PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 133 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
133 continue
endif
C--write out dummy particles
if(writedummies) then
do 137 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
137 continue
endif
C--write out particle lines
do 132 i=1,N
if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then
pbarcode=pbarcode+1
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),4,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
endif
132 continue
else
C--long output
if (hadro) then
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 123 I=1,N
IF(K(i,3).ne.0)THEN
NSTART=I
GOTO 124
ENDIF
123 CONTINUE
124 CONTINUE
nstart=0
DO 126 I=NSTART+1,N
IF(isprimhadron(i)) NFIRST=NFIRST+1
IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15))
& .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1
126 CONTINUE
127 CONTINUE
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
CODEFIRST=NFIRST+PBARCODE
C--write out scattering centres
if(writescatcen) then
do 134 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
134 continue
endif
C--write out dummy particles
if(writedummies) then
do 138 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
138 continue
endif
C--first write out all particles coming directly from string or cluster decays
DO 125 I=NSTART+1,N
IF(.not.isprimhadron(i))THEN
GOTO 125
ELSE
IF (PBARCODE.EQ.CODEFIRST) GOTO 130
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
ENDIF
125 CONTINUE
130 CONTINUE
C--now write out all other particles and vertices
DO 129 I=NSTART+1,N
if (isprimhadron(i).or.isprimstring(i)) goto 129
if (isparton(K(i,2))) then
if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3))
goto 129
endif
if (issecstring(i)) then
codelist(i)=codelist(K(i,3))
goto 129
endif
PBARCODE=PBARCODE+1
IF((K(I,3).NE.K(I-1,3)))THEN
C--write out vertex line
WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
ENDIF
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
129 CONTINUE
else
C---------------------------------------------------------------------------------------
C--partonic events
! call pevrec(2,.false.)
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 150 I=9,N
IF((k(i,3).eq.1).or.(k(i,3).eq.2).or.
& (k(i,3).eq.7).or.(k(i,3).eq.8)) NFIRST=NFIRST+1
IF(K(I,4).NE.0) NVERTEX=NVERTEX+1
150 CONTINUE
nstart = 9+nfirst
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,centr,0.d0,0.d0,0.d0
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 151 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
151 continue
endif
C--write out dummy particles
if(writedummies) then
do 152 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
152 continue
endif
C--write out outgoing particles of first vertex
do 154 i=9,nstart-1
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
154 continue
C--now write out all other particles and vertices
DO 153 I=NSTART,N
PBARCODE=PBARCODE+1
if (k(i,3).eq.0) then
C--write out vertex line - scattering
WRITE(J,5400)'V ',CODELIST(K(I+1,3)),k(k(i+1,3),1),0,0,
& 0,0,0,K(K(I+1,3),5)-K(K(I+1,3),4)+1,0
elseif ((k(i,3).ne.k(i-1,3)).and.(k(i-1,3).ne.0)) then
C--write out vertex line - splitting
WRITE(J,5400)'V ',CODELIST(K(I,3)),k(k(i,3),1),0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
endif
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),4,0,0,0,0
elseif ((k(i,1).eq.11).and.(k(i,3).eq.0)) then
WRITE(J,5500)'P ',PBARCODE,0,0.d0,0.d0,0.d0,
& 0.d0,0.d0,0,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
ENDIF
153 CONTINUE
endif
endif
call flush(j)
END
subroutine combinegluons()
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
integer ncomb,i,j
double precision mom(4),mass2
logical compress,compressevent
data ncomb/3/
do 100 i=1,n
C-- find recoils (= gluons with finite mass)
if ((k(i,2).eq.21).and.(p(i,5).ne.0.d0).and.(k(i,1).eq.2)) then
mom(1) = p(i,1)
mom(2) = p(i,2)
mom(3) = p(i,3)
mom(4) = p(i,4)
do 101 j=1,ncomb-1
if ((k(i+j,2).eq.21).and.(p(i+j,5).ne.0.d0)
& .and.(k(i+j,1).eq.2)) then
mom(1) = mom(1) + p(i+j,1)
mom(2) = mom(2) + p(i+j,2)
mom(3) = mom(3) + p(i+j,3)
mom(4) = mom(4) + p(i+j,4)
k(i+j,1) = 11
else
goto 102
endif
101 continue
102 p(i,1) = mom(1)
p(i,2) = mom(2)
p(i,3) = mom(3)
p(i,4) = mom(4)
mass2 = mom(4)**2-mom(1)**2-mom(2)**2-mom(3)**2
if (mass2.lt.0.d0) write(logfid,*)mass2
endif
100 continue
C i=0
C compress = compressevent(i)
return
end
***********************************************************************
*** subroutine copyline
***********************************************************************
SUBROUTINE COPYLINE(NFR,NTO,MODE)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--local variables
integer nfr,nto,mode,j
if (mode.ge.0) then
k(nto,1) = k(nfr,1)
k(nto,2) = k(nfr,2)
do 100 j=1,5
p(nto,j) = p(nfr,j)
100 continue
za(nto)=za(nfr)
zd(nto)=zd(nfr)
thetaa(nto)=thetaa(nfr)
qqbard(nto)=qqbard(nfr)
endif
if (mode.ge.1) then
do 101 j=1,5
mv(nto,j) = mv(nfr,j)
101 continue
endif
if (mode.eq.2) then
trip(nto)=trip(nfr)
anti(nto)=anti(nfr)
endif
return
end
***********************************************************************
*** subroutine printlogo
***********************************************************************
subroutine printlogo(fid)
implicit none
integer fid
write(fid,*)
write(fid,*)' _______________'//
&'__________________________ '
write(fid,*)' | '//
&' | '
write(fid,*)' | JJJJJ EEEEE '//
&' W W EEEEE L | '
write(fid,*)' | J E '//
&' W W E L | '
write(fid,*)' _________________| J EEE '//
&' W W W EEE L |_________________ '
write(fid,*)'| | J J E '//
&' W W W W E L | |'
write(fid,*)'| | JJJ EEEEE '//
&' W W EEEEE LLLLL | |'
write(fid,*)'| |_______________'//
&'__________________________| |'
write(fid,*)'| '//
&' |'
write(fid,*)'| '//
&'this is JEWEL 2.4.0 |'
write(fid,*)'| '//
&' |'
write(fid,*)'| Copyright Korinna C. Zapp (2022)'//
&' [Korinna.Zapp@thep.lu.se] |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The medium model was partly '//
&'implemented by Jochen Klein |'
write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '//
&'Kunnawalkam Elayavalli helped with the |'
write(fid,*)'| implementation of the V+jet processes '//
&'[raghav.k.e@cern.ch]. |'
write(fid,*)'| '//
&' |'
write(fid,*)'| Please cite JHEP 1303 (2013) '//
&'080 [arXiv:1212.1599] for physics and |'
write(fid,*)'| EPJC 74 (2014) no.2, 2762 [arXiv:1311.0048] '//
&' for the code. |'
write(fid,*)'| The reference for '//
&'V+jet processes is EPJC 76 (2016) no.12 695 |'
write(fid,*)'| [arXiv:1608.03099] and for recoil effects'//
&' it is JHEP 07 (2017) 141 |'
- write(fid,*)'| [arXiv:1707.01539]. '//
- &' |'
+ write(fid,*)'| [arXiv:1707.01539] and '//
+ &'arXiv:2207.?????. |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL relies heavily on PYTHIA 6'//
&' for the event generation. The modified |'
write(fid,*)'| version of PYTHIA 6.4.25 that is'//
&' shipped with JEWEL is, however, not an |'
write(fid,*)'| official PYTHIA release and must'//
&' not be used for anything else. Please |'
write(fid,*)'| refer to results as "JEWEL+PYTHIA".'//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL also uses code provided by'//
&'S. Zhang and J. M. Jing |'
write(fid,*)'| (Computation of Special Functions, '//
&'John Wiley & Sons, New York, 1996 and |'
write(fid,*)'| http://jin.ece.illinois.edu) for '//
&'computing the exponential integral Ei(x). |'
write(fid,*)'| '//
&' |'
write(fid,*)'|_________________________________'//
&'____________________________________________|'
write(fid,*)
write(fid,*)
end
***********************************************************************
*** subroutine printtime
***********************************************************************
subroutine printtime
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer*4 date(3),time(3)
1000 format (i2.2, '.', i2.2, '.', i4.4, ', ',
& i2.2, ':', i2.2, ':', i2.2 )
call idate(date)
call itime(time)
write(logfid,1000)date,time
end
Index: trunk/code/jewel-240-hilmi.f
===================================================================
--- trunk/code/jewel-240-hilmi.f (revision 504)
+++ trunk/code/jewel-240-hilmi.f (revision 505)
@@ -1,8227 +1,8280 @@
PROGRAM JEWEL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
integer j,i,kk,poissonian
integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
double precision sumofweightstot,wdisctot,scalefac
double precision gettemp,r,tau
character*2 b1,b2
call init()
SUMOFWEIGHTSTOT=0.d0
WDISCTOT=0.d0
C--e+ + e- event generation
if (collider.eq.'EEJJ') then
b1 = 'e+'
b2 = 'e-'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
&' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--e+ + e- event loop
DO 100 J=1,NSIM
call genevent(j,b1,b2)
100 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb'
write(logfid,*)'sum of event weights in e+ + e- channel:',
& sumofweights-wdisc
write(logfid,*)
else
C--hadronic event generation
if (isochannel.eq.'PP') then
nsimpp = nsim
nsimpn = 0
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'PN') then
nsimpp = 0
nsimpn = nsim
nsimnp = 0
nsimnn = 0
elseif (isochannel.eq.'NP') then
nsimpp = 0
nsimpn = 0
nsimnp = nsim
nsimnn = 0
elseif (isochannel.eq.'NN') then
nsimpp = 0
nsimpn = 0
nsimnp = 0
nsimnn = nsim
else
nsimpp = poissonian(1.d0*nsim*nproton**2/mass**2)
nsimpn = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnp = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
nsimnn = poissonian(1.d0*nsim*(mass-nproton)**2/mass**2)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
scalefac = nsim*1.d0/(nsimsum*1.d0)
nsimpp = int(nsimpp*scalefac)
nsimpn = int(nsimpn*scalefac)
nsimnp = int(nsimnp*scalefac)
nsimnn = int(nsimnn*scalefac)
nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
endif
C--loop over channels
do 101 kk=1,4
if (kk.eq.1) then
b1 = 'p+'
b2 = 'p+'
nsimchn = nsimpp
elseif (kk.eq.2) then
b1 = 'p+'
b2 = 'n0'
nsimchn = nsimpn
elseif (kk.eq.3) then
b1 = 'n0'
b2 = 'p+'
nsimchn = nsimnp
else
b1 = 'n0'
b2 = 'n0'
nsimchn = nsimnn
endif
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
write(logfid,*)'generating ',nsimchn,' events in ',
&b1,' + ',b2,' channel'
write(logfid,*)
write(logfid,*)
&'####################################################'
write(logfid,*)
SUMOFWEIGHTS=0.d0
WDISC=0.d0
call initpythia(b1,b2)
write(logfid,*)
C--event loop
DO 102 J=1,nsimchn
call genevent(j,b1,b2)
102 CONTINUE
sumofweightstot = sumofweightstot+sumofweights
wdisctot = wdisctot + wdisc
write(logfid,*)
write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
& PARI(1),'mb'
write(logfid,*)'sum of event weights in ',b1,' + ',b2,
& ' channel:',sumofweights-wdisc
write(logfid,*)
101 continue
endif
C--finish
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
WRITE(HPMCFID,*)
CLOSE(HPMCFID,status='keep')
write(logfid,*)
write(logfid,*)'mean number of scatterings:',
& NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of effective scatterings:',
& NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings:',
& NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from IS shower:',
& nspliti/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'mean number of splittings from FS shower:',
& nsplitf/(SUMOFWEIGHTSTOT-WDISCTOT)
write(logfid,*)'fraction of rejected IS splittings:',
& nisfail/nistry
write(logfid,*)'fraction of rejected FS splittings:',
& nfsfail/nfstry
write(logfid,*)'fraction of rejected momentum transfers:',
& ntrej/nttot
write(logfid,*)
write(logfid,*)'number of extrapolations in splitting integral: ',
& noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting partonic PDFs: ',
& noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in splitting cross sections: ',
& noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
write(logfid,*)
& 'number of extrapolations in Sudakov form factor: ',
& noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
write(logfid,*)
write(logfid,*)'number of good events: ',ngood
write(logfid,*)'total number of discarded events: ',NDISC
write(logfid,*)'number of events for which conversion '//
&'to hepmc failed: ',NSTRANGE
call printtime
close(logfid,status='keep')
C--write random number generator state to file and close it
CALL PYRGET(2,-1)
CLOSE(2,status='keep')
END
***********************************************************************
***********************************************************************
*** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES ****************
***********************************************************************
***********************************************************************
***********************************************************************
*** subroutine init
***********************************************************************
subroutine init()
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
+C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
+ common/pdfas/pdfalphas
+ double precision pdfalphas
C--number of protons
common/np/nproton,mass
integer nproton,mass
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2)
&,SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
INTEGER NJOB,ios,pos,i,j,jj,intmass
DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr
character firstchar
CHARACTER*2 SNSET
CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer,
&label,value
CHARACTER*120 HEPMCFILE,LOGFILE,FILENAME2
CHARACTER(LEN=100) filename
LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST
logical readran
data maxnscatcen/22990/
HPMCFID = 4
logfid = 3
C--default settings
nsim = 10000
njob = 0
logfile = 'out.log'
hepmcfile = 'out.hepmc'
filesplit = 'splitint.dat'
pdffile = 'pdfs.dat'
xsecfile = 'xsecs.dat'
filemed = 'medium-params.dat'
nf = 3
lqcd = 0.4
q0 = 1.5
ptmin = 5.
ptmax = 350.
etamax = 3.1
collider = 'PPJJ'
isochannel = 'XX'
channel = 'MUON'
sqrts = 2760
- pdfset = 10042
+ pdfset = 13100
+ pdfalphas = 0.118
mass = 208
nproton = 82
weighted = .true.
weightex = 5.
angord = .true.
allhad = .false.
hadro = .true.
hadrotype = 0
shorthepmc = .true.
compress = .true.
writescatcen = .false.
writedummies = .false.
scatrecoil = .false.
recsoftcut = 0.
rechardcut = 5.
kinmode = 1
recmode = 0
readran = .false.
if (iargc().eq.0) then
write(*,*)'No parameter file given, '//
&'will run with default settings.'
else
call getarg(1,filename)
write(*,*)'Reading parameters from ',filename
open(unit=1,file=filename,status='old',err=110)
do 120 i=1,1000
read(1, '(A)', iostat=ios) buffer
if(ios.ne.0) goto 130
firstchar = buffer(1:1)
if (firstchar.eq.'#') goto 120
pos=scan(buffer,' ')
label=buffer(1:pos)
value=buffer(pos+1:)
if(label.eq."NEVENT")then
read(value,*,iostat=ios) nsim
elseif(label.eq."NJOB")then
read(value,*,iostat=ios) njob
elseif(label.eq."LOGFILE")then
read(value,'(a)',iostat=ios) logfile
elseif(label.eq."HEPMCFILE")then
read(value,'(a)',iostat=ios) hepmcfile
elseif(label.eq."SPLITINTFILE")then
read(value,'(a)',iostat=ios) filesplit
elseif(label.eq."PDFFILE")then
read(value,'(a)',iostat=ios) pdffile
elseif(label.eq."XSECFILE")then
read(value,'(a)',iostat=ios) xsecfile
elseif(label.eq."MEDIUMPARAMS")then
read(value,'(a)',iostat=ios) filemed
elseif(label.eq."NF")then
read(value,*,iostat=ios) nf
elseif(label.eq."LAMBDAQCD")then
read(value,*,iostat=ios) lqcd
elseif(label.eq."Q0")then
read(value,*,iostat=ios) q0
elseif(label.eq."PTMIN")then
read(value,*,iostat=ios) ptmin
elseif(label.eq."PTMAX")then
read(value,*,iostat=ios) ptmax
elseif(label.eq."ETAMAX")then
read(value,*,iostat=ios) etamax
elseif(label.eq."PROCESS")then
read(value,*,iostat=ios) collider
elseif(label.eq."ISOCHANNEL")then
read(value,*,iostat=ios) isochannel
elseif(label.eq."CHANNEL")then
read(value,*,iostat=ios) channel
elseif(label.eq."SQRTS")then
read(value,*,iostat=ios) sqrts
elseif(label.eq."PDFSET")then
read(value,*,iostat=ios) pdfset
+ elseif(label.eq."PDFALPHAS")then
+ read(value,*,iostat=ios) pdfalphas
elseif(label.eq."MASS")then
read(value,*,iostat=ios) mass
elseif(label.eq."NPROTON")then
read(value,*,iostat=ios) nproton
elseif(label.eq."WEIGHTED")then
read(value,*,iostat=ios) weighted
elseif(label.eq."WEXPO")then
read(value,*,iostat=ios) weightex
elseif(label.eq."ANGORD")then
read(value,*,iostat=ios) angord
elseif(label.eq."KEEPRECOILS")then
read(value,*,iostat=ios) allhad
elseif(label.eq."SCATRECOIL")then
read(value,*,iostat=ios) scatrecoil
elseif(label.eq."HADRO")then
read(value,*,iostat=ios) hadro
elseif(label.eq."HADROTYPE")then
read(value,*,iostat=ios) hadrotype
elseif(label.eq."SHORTHEPMC")then
read(value,*,iostat=ios) shorthepmc
elseif(label.eq."COMPRESS")then
read(value,*,iostat=ios) compress
elseif(label.eq."WRITESCATCEN")then
read(value,*,iostat=ios) writescatcen
elseif(label.eq."WRITEDUMMIES")then
read(value,*,iostat=ios) writedummies
elseif(label.eq."RECSOFTCUT")then
read(value,*,iostat=ios) recsoftcut
elseif(label.eq."RECHARDCUT")then
read(value,*,iostat=ios) rechardcut
elseif(label.eq."KINMODE")then
read(value,*,iostat=ios) kinmode
elseif(label.eq."RECMODE")then
read(value,*,iostat=ios) recmode
elseif(label.eq."READRAN")then
read(value,*,iostat=ios) readran
else
write(*,*)'unknown label ',label
endif
120 continue
110 write(*,*)
& 'Unable to open parameter file, will exit the run.'
call exit(1)
130 close(1,status='keep')
write(*,*)'...done'
endif
lps = lqcd
! scatrecoil = .false.
! if (.not.hadro) shorthepmc = .true.
if (recmode.eq.2) then
allhad = .false.
scatrecoil = .false.
endif
SCALEFACM=1.
ptfac=1.
ftfac=1.d0
if (ptmin.lt.3.d0) ptmin = 3.d0
if (.not.writescatcen) writedummies = .false.
OPEN(unit=logfid,file=LOGFILE,status='unknown')
MSTU(11)=logfid
call printtime
call printlogo(logfid)
write(logfid,*)
write(logfid,*)'parameters of the run:'
write(logfid,*)'NEVENT = ',nsim
write(logfid,*)'NJOB = ',njob
write(logfid,*)'LOGFILE = ',logfile
write(logfid,*)'HEPMCFILE = ',hepmcfile
write(logfid,*)'SPLITINTFILE = ',filesplit
write(logfid,*)'PDFFILE = ',pdffile
write(logfid,*)'XSECFILE = ',xsecfile
write(logfid,*)'MEDIUMPARAMS = ',filemed
write(logfid,*)'NF = ',nf
write(logfid,*)'LAMBDAQCD = ',lqcd
write(logfid,*)'Q0 = ',q0
write(logfid,*)'PTMIN = ',ptmin
write(logfid,*)'PTMAX = ',ptmax
write(logfid,*)'ETAMAX = ',etamax
write(logfid,*)'PROCESS = ',collider
write(logfid,*)'ISOCHANNEL = ',isochannel
write(logfid,*)'CHANNEL = ',channel
write(logfid,*)'SQRTS = ',sqrts
write(logfid,*)'PDFSET = ',pdfset
+ write(logfid,*)'PDFALPHAS = ',pdfalphas
write(logfid,*)'MASS = ',mass
write(logfid,*)'NPROTON = ',nproton
write(logfid,*)'WEIGHTED = ',weighted
write(logfid,*)'WEXPO = ',weightex
write(logfid,*)'ANGORD = ',angord
write(logfid,*)'HADRO = ',hadro
write(logfid,*)'HADROTYPE = ',hadrotype
write(logfid,*)'SHORTHEPMC = ',shorthepmc
write(logfid,*)'COMPRESS = ',compress
write(logfid,*)'KEEPRECOILS = ',allhad
write(logfid,*)'SCATRECOIL = ',scatrecoil
write(logfid,*)'RECSOFTCUT = ',recsoftcut
write(logfid,*)'RECHARDCUT = ',rechardcut
write(logfid,*)'WRITESCATCEN = ',writescatcen
write(logfid,*)'WRITEDUMMIES = ',writedummies
write(logfid,*)'KINMODE = ',kinmode
write(logfid,*)'RECMODE = ',recmode
write(logfid,*)
call flush(logfid)
if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
& .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
& .and.(collider.ne.'PPYG')
& .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
& .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
& .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
& .and.(collider.ne.'PPDY')) then
write(logfid,*)'Fatal error: colliding system unknown, '//
& 'will exit now'
call exit(1)
endif
C--initialize medium
intmass = int(mass)
CALL MEDINIT(FILEMED,logfid,etamax,intmass)
CALL MEDNEXTEVT
OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown')
WRITE(HPMCFID,*)
WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05'
WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
NPART=2
if(ptmax.gt.0.)then
EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.)
else
EOVEST=sqrts/2.
endif
CALL EIXINT
CALL INSUDAINT(EOVEST)
write(logfid,*)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(SPLITIEXIST)THEN
write(logfid,*)'read splitting integrals from ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='old')
READ(10,*)QMAX,ZMMIN,NPOINT
DO 893 I=1,NPOINT+1
READ(10,*) QVAL(I),ZMVAL(I)
893 CONTINUE
DO 891 I=1,NPOINT+1
DO 892 J=1,NPOINT+1
READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
892 CONTINUE
891 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate splitting functions, '//
&'this may take some time'
CALL SPLITFNCINT(EOVEST)
INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
IF(.NOT.SPLITIEXIST)THEN
write(logfid,*)'write splitting integrals to ',FILESPLIT
OPEN(unit=10,file=FILESPLIT,status='new')
WRITE(10,*)QMAX,ZMMIN,NPOINT
DO 896 I=1,NPOINT+1
WRITE(10,*) QVAL(I),ZMVAL(I)
896 CONTINUE
DO 897 I=1,NPOINT+1
DO 898 J=1,NPOINT+1
WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
898 CONTINUE
897 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(PDFEXIST)THEN
write(logfid,*)'read pdfs from ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='old')
DO 872 I=1,2
DO 873 J=1,1000
READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
873 CONTINUE
872 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate pdfs, this may take some time'
CALL PDFINT(EOVEST)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(.NOT.PDFEXIST)THEN
write(logfid,*)'write pdfs to ',PDFFILE
OPEN(unit=10,file=PDFFILE,status='new')
DO 876 I=1,2
DO 877 J=1,1000
WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
877 CONTINUE
876 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(XSECEXIST)THEN
write(logfid,*)'read cross sections from ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='old')
DO 881 J=1,1001
DO 885 JJ=1,101
READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
885 CONTINUE
881 CONTINUE
CLOSE(10,status='keep')
ELSE
write(logfid,*)'have to integrate cross sections, '//
&'this may take some time'
CALL XSECINT(EOVEST)
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(.NOT.XSECEXIST)THEN
write(logfid,*)'write cross sections to ',XSECFILE
OPEN(unit=10,file=XSECFILE,status='new')
DO 883 J=1,1001
DO 884 JJ=1,101
WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
&INTG1(J,JJ),INTG2(J,JJ)
884 CONTINUE
883 CONTINUE
CLOSE(10,status='keep')
ENDIF
ENDIF
write(logfid,*)
CALL FLUSH(3)
C--initialise random number generator status
IF(NJOB.GT.0)THEN
MRPY(1)=NJOB*1000
MRPY(2)=0
ENDIF
C--Call PYR once for initialization
R=PYR(0)
C--read random number generator from file if desired
IF(READRAN)THEN
OPEN(unit=2,file='in.ran',access='sequential',
&form='unformatted',status='old')
CALL PYRSET(2,0)
CLOSE(2,status='keep')
WRITE(logfid,*) 'read random number generator status'
ENDIF
C--write random number generator state to file
OPEN(unit=2,file='out.ran',access='sequential',form='unformatted',
&status='unknown')
CALL PYRGET(2,0)
NDISC=0
NGOOD=0
NSTRANGE=0
ERRCOUNT=0
errl = 0
NSCAT=0.d0
NSCATEFF=0.d0
NSPLIT=0.d0
nspliti=0.d0
nsplitf=0.d0
nistry=0.d0
nisfail=0.d0
nfstry=0.d0
nfsfail=0.d0
nttot=0.d0
ntrej=0.d0
ntotspliti=0
noverspliti=0
ntotpdf=0
noverpdf=0
ntotxsec=0
noverxsec=0
ntotsuda=0
noversuda=0
end
***********************************************************************
*** subroutine initpythia
***********************************************************************
subroutine initpythia(beam1,beam2)
implicit none
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--pdfset
common/pdf/pdfset
integer pdfset
+C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
+ common/pdfas/pdfalphas
+ double precision pdfalphas
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--Pythia parameters
common/pythiaparams/PTMIN,PTMAX,weighted
double precision PTMIN,PTMAX
LOGICAL WEIGHTED
C--Variables local to this program
character*2 beam1,beam2
C--initialise PYTHIA
C--keep parton shower history in PYJETS
MSTP(125)=2
C--no multiple interactions
MSTP(81) = 0
C--initial state radiation
MSTP(61)=1
C--switch off final state radiation off partons emitted from space-like shower
! MSTP(63)=0
C--switch off final state radiation
MSTP(71)=0
C--No hadronisation (yet)
MSTP(111)=0
C--Lambda_QCD and Q0
PARJ(81)=LQCD
PARJ(82)=Q0
C--parameter affecting treatment of string corners
PARU(14)=1.
C--Min shat in simulation
CKIN(1)=2.
C--pT-cut
CKIN(3)=PTMIN
CKIN(4)=PTMAX
+
+C...# Tuned flavour parameters:
+! PARJ(1) = 0.073
+! PARJ(2) = 0.2
+! PARJ(3) = 0.94
+! PARJ(4) = 0.032
+! PARJ(11) = 0.31
+! PARJ(12) = 0.4
+! PARJ(13) = 0.54
+! PARJ(25) = 0.63
+! PARJ(26) = 0.12
+C...# Fragmentation tune
+! MSTJ(11) = 5
+! PARJ(21) = 0.325
+! PARJ(41) = 0.5
+! PARJ(42) = 0.6
+! PARJ(47) = 0.67
+! PARJ(81) = 0.29
+! PARJ(82) = 1.65
+
+C--particles stable if lifetime > PARJ(71), default = 10mm
+ MSTJ(22)=2
+! PARJ(71)=288.
+C--switch off pi0 decay
+! MDCY(PYCOMP(111),1)=0
+
C--use LHAPDF
MSTP(52)=2
C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
C MSTW2008 (LO central) - 21000
MSTP(51)=PDFSET
IF(COLLIDER.EQ.'PPYQ')THEN
MSEL=0
MSUB(29)=1
ELSEIF(COLLIDER.EQ.'PPYG')THEN
MSEL=0
MSUB(14)=1
MSUB(115)=1
ELSEIF(COLLIDER.EQ.'PPYJ')THEN
MSEL=0
MSUB(14)=1
MSUB(29)=1
MSUB(115)=1
ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')
& .or.(COLLIDER.EQ.'PPZG')
& .or.(collider.eq.'PPDY'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1
IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1
IF(COLLIDER.EQ.'PPDY') MSUB(1)=1
MDME(174,1)=0 !Z decay into d dbar',
MDME(175,1)=0 !Z decay into u ubar',
MDME(176,1)=0 !Z decay into s sbar',
MDME(177,1)=0 !Z decay into c cbar',
MDME(178,1)=0 !Z decay into b bbar',
MDME(179,1)=0 !Z decay into t tbar',
MDME(182,1)=0 !Z decay into e- e+',
MDME(183,1)=0 !Z decay into nu_e nu_ebar',
MDME(184,1)=0 !Z decay into mu- mu+',
MDME(185,1)=0 !Z decay into nu_mu nu_mubar',
MDME(186,1)=0 !Z decay into tau- tau+',
MDME(187,1)=0 !Z decay into nu_tau nu_taubar',
if (channel.EQ.'ELEC')THEN
MDME(182,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(184,1)=1
ENDIF
ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')
& .or.(COLLIDER.EQ.'PPWG'))THEN
MSEL=0
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1
IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1
MDME(190,1)=0 ! W+ decay into dbar u,
MDME(191,1)=0 ! W+ decay into dbar c,
MDME(192,1)=0 ! W+ decay into dbar t,
MDME(194,1)=0 ! W+ decay into sbar u,
MDME(195,1)=0 ! W+ decay into sbar c,
MDME(196,1)=0 ! W+ decay into sbar t,
MDME(198,1)=0 ! W+ decay into bbar u,
MDME(199,1)=0 ! W+ decay into bbar c,
MDME(200,1)=0 ! W+ decay into bbar t,
MDME(202,1)=0 ! W+ decay into b'bar u,
MDME(203,1)=0 ! W+ decay into b'bar c,
MDME(204,1)=0 ! W+ decay into b'bar t,
MDME(206,1)=0 ! W+ decay into e+ nu_e,
MDME(207,1)=0 ! W+ decay into mu+ nu_mu,
MDME(208,1)=0 ! W+ decay into tau+ nu_tau,
MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau,
if (channel.EQ.'ELEC')THEN
MDME(206,1)=1
ELSEIF(channel.EQ.'MUON')THEN
MDME(207,1)=1
ENDIF
ELSE
C--All QCD processes are active
MSEL=1
ENDIF
! MSEL=0
! MSUB(11)=1
! MSUB(12)=1
! MSUB(53)=1
! MSUB(13)=1
! MSUB(68)=1
! MSUB(28)=1
C--weighted events
IF(WEIGHTED) MSTP(142)=1
C--number of errors to be printed
MSTU(22)=MAX(10,INT(5.*NSIM/100.))
C--number of lines in event record
MSTU(4)=23000
! MSTU(5)=23000
MSTU(5)=10000
C--switch off pi0 decay
MDCY(PYCOMP(111),1)=0
C--initialisation call
IF(COLLIDER.EQ.'EEJJ')THEN
OFFSET=9
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR.
& (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN
OFFSET=8
CALL PYINIT('CMS',beam1,beam2,sqrts)
ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or.
& (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN
OFFSET=10
CALL PYINIT('CMS',beam1,beam2,sqrts)
elseif (collider.eq.'PPDY') then
CALL PYINIT('CMS',beam1,beam2,sqrts)
ENDIF
end
***********************************************************************
*** subroutine genevent
***********************************************************************
subroutine genevent(j,b1,b2)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER PYCOMP
INTEGER NMXHEP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
INTEGER MSEL,MSELPD,MSUB,KFIN
DOUBLE PRECISION CKIN
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
COMMON/PYDATR/MRPY(6),RRPY(100)
INTEGER MRPY
DOUBLE PRECISION RRPY
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--event weight exponent
COMMON/WEXPO/WEIGHTEX
DOUBLE PRECISION WEIGHTEX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--Variables local to this program
INTEGER NOLD,PID,IPART,LME1,LME2,j,i,LME1ORIG,LME2ORIG,llep1,
&llep2,lv
integer nnew,lprev,l1,l2,l3,lstart,jj,ii,ntmp,slen
DOUBLE PRECISION PYR,ENI,QMAX1,R,GETMASS,PYP,Q1,Q2,P21,P22,ETOT,
&QMAX2,POLD,EN1,EN2,BETA(3),ENEW1,ENEW2,emax,lambda,x1,x2,x3,
&MEWEIGHT,PSWEIGHT,WEIGHT,EPS1,EPS2,THETA1,THETA2,Z1,Z2,
&getltimemax,pi,m1,m2,pymass
character*2 b1,b2
CHARACTER*2 TYPE1,TYPE2
LOGICAL FIRSTTRIP,WHICH1,WHICH2,ISDIQUARK,isparton,recomb
logical onlyzeros
DATA PI/3.141592653589793d0/
N=0
COLMAX=600
DISCARD=.FALSE.
DO 91 I=1,23000
MV(I,1)=0.d0
MV(I,2)=0.d0
MV(I,3)=0.d0
MV(I,4)=0.d0
MV(I,5)=0.d0
ZA(I)=0.d0
ZD(I)=0.d0
THETAA(I)=0.d0
QQBARD(I)=.FALSE.
91 CONTINUE
nscatcen = 0
CALL MEDNEXTEVT
C--initialisation with matrix element
C--production vertex
CALL PICKVTX(X0,Y0)
LTIME=GETLTIMEMAX()
99 CALL PYEVNT
! call pylist(2)
NPART=N-OFFSET
EVWEIGHT=PARI(10)
SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
GOTO 102
ELSE
NGOOD=NGOOD+1
ENDIF
C--DY: don't have to do anything
if (collider.eq.'PPDY') then
CALL PYEXEC
call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
goto 102
endif
C--prepare event record
C--special treatment for Jeweling intial state radiation (currently only available for di-jets)
if (collider.eq.'PPJJ') then
! write(logfid,*)'begin special treatment'
! call pevrec(2,.false.)
C--find non-strongly interacting particles and move them up first
nnew=8
do 300 i=107,n
if ((k(i,1).le.2).and.(.not.isparton(k(i,2)))) then
k(i,1)=11
nnew=nnew+1
call copyline(i,nnew,0)
endif
300 continue
C--walk backwards from ME to beam and set production vertices and times
do 400 i=0,1
lstart=105+i
lambda=1.d0/(ftfac*p(lstart,4)*0.2/p(lstart,5)**2)
mv(lstart,4)=log(1.d0-pyr(0))/lambda
mv(lstart,5)=0.d0
mv(lstart,1)=x0 +
& mv(lstart,4)*p(lstart,1)/max(pyp(lstart,8),p(lstart,4))
mv(lstart,2)=y0 +
& mv(lstart,4)*p(lstart,2)/max(pyp(lstart,8),p(lstart,4))
mv(lstart,3)=
& mv(lstart,4)*p(lstart,3)/max(pyp(lstart,8),p(lstart,4))
lprev=lstart
l1=k(lprev,3)
do while (k(lprev,3).gt.4)
do 302 jj=105,n
if (k(jj,3).eq.l1) l2=jj
302 continue
if ((k(l1,3).eq.3).or.(k(l1,3).eq.4)) then
mv(l1,1)=1.d6
mv(l1,2)=1.d6
if (k(l1,3).eq.3) then
mv(l1,3)=1.d6
else
mv(l1,3)=-1.d6
endif
mv(l1,4)=-1.d6
mv(l1,5)=mv(lprev,4)
else
lambda=1.d0/(ftfac*p(l1,4)*0.2/p(l1,5)**2)
mv(l1,4)=mv(lprev,4) + log(1.d0-pyr(0))/lambda
mv(l1,5)=mv(lprev,4)
mv(l1,1)=mv(lprev,1) +
& (mv(l1,4)-mv(l1,5))*p(l1,1)/max(pyp(l1,8),p(l1,4))
mv(l1,2)=mv(lprev,2) +
& (mv(l1,4)-mv(l1,5))*p(l1,2)/max(pyp(l1,8),p(l1,4))
mv(l1,3)=mv(lprev,3) +
& (mv(l1,4)-mv(l1,5))*p(l1,3)/max(pyp(l1,8),p(l1,4))
endif
mv(l2,4)=mv(lprev,4)
if (p(l2,5).eq.pymass(k(l2,2))) then
mv(l2,5)=ltime
else
lambda=1.d0/(ftfac*p(l2,4)*0.2/p(l2,5)**2)
mv(l2,5)=mv(lprev,4) - log(1.d0-pyr(0))/lambda
endif
mv(l2,1)=mv(lprev,1)
mv(l2,2)=mv(lprev,2)
mv(l2,3)=mv(lprev,3)
lprev=l1
l1=k(lprev,3)
end do
400 continue
! call pevrec(3,.false.)
C--order all singlets from triplet to antitriplet
do 401 i=lstart,n
if ((k(i,1).eq.2).and.
& ((k(i,2).lt.0).or.isdiquark(k(i,2)))) then
ntmp=n
do 402 jj=i,n
ntmp=ntmp+1
call copyline(jj,ntmp,1)
k(ntmp,3)=k(jj,3)
if (k(jj,1).eq.1) goto 403
402 continue
403 do 404 jj=0,ntmp-n-1
call copyline(ntmp-jj,i+jj,1)
k(i+jj,3)=k(ntmp-jj,3)
if (jj.eq.ntmp-n-1) then
k(i+jj,1)=1
else
k(i+jj,1)=2
endif
404 continue
! write(logfid,*)'had to change order of singlets'
! call pevrec(3,.false.)
endif
401 continue
C--undo final state splittings
lstart=0
do 303 i=107,n
if ((lstart.eq.0).and.(k(i,1).le.2)) lstart=i
if (k(i,1).le.2) then
do 310 jj=1,5
mv(i,jj)=mv(k(i,3),jj)
310 continue
k(i,3)=k(k(i,3),3)
endif
303 continue
! write(logfid,*)'start undoing FS splittings'
! call pevrec(3,.false.)
recomb=.true.
do while (recomb)
recomb=.false.
do 304 i=lstart,n
if (k(i,3).gt.106) then
onlyzeros=.true.
do 307 jj=i+1,n
if (k(i,3).eq.k(jj,3)) then
l1=i
l2=jj
recomb=.true.
goto 308
else
if ((jj.gt.i+1).and.(k(jj,1).gt.0)) onlyzeros=.false.
endif
307 continue
endif
304 continue
308 if (recomb) then
if (onlyzeros) then
! write(logfid,*)'normal recombination step',l1,l2
if (k(k(l1,3),2).eq.21) then
zd(l1)=p(l1,4)/p(k(l1,3),4)
if (k(l1,2).ne.21) then
qqbard(l1)=.true.
else
qqbard(l1)=.false.
endif
else
if (k(l1,2).eq.21) then
zd(l1)=p(l2,4)/p(k(l2,3),4)
else
zd(l1)=p(l1,4)/p(k(l1,3),4)
endif
qqbard(l1)=.false.
endif
do 305 i=1,5
p(l1,i)=p(k(l1,3),i)
305 continue
k(l1,2)=k(k(l1,3),2)
k(l1,3)=k(k(l1,3),3)
if (k(l1,2).eq.21) k(l1,1)=2
if (k(l2,1).eq.1) k(l1,1)=1
k(l2,1)=0
else
C--have to change order in which singlets appear
! write(logfid,*)'have to change order of singlets',l1,l2
if (k(l1,1).eq.2) then
ntmp=n
do 405 i=l1,n
ntmp=ntmp+1
call copyline(i,ntmp,1)
k(ntmp,3)=k(i,3)
if (k(i,1).eq.1) goto 406
405 continue
406 continue
slen=ntmp-n
do 407 i=l1+slen,l2
call copyline(i,i-slen,1)
k(i-slen,3)=k(i,3)
407 continue
do 408 i=1,slen
call copyline(n+i,l2-slen+i,1)
k(l2-slen+i,3)=k(n+i,3)
408 continue
else
do 410 i=1,l1-lstart
if ((k(l1-i,2).ne.21).and.(k(l1-i,1).ne.0)) then
l3=l1-i
goto 411
endif
410 continue
411 ntmp=n
do 415 i=l3,l1
ntmp=ntmp+1
call copyline(i,ntmp,1)
k(ntmp,3)=k(i,3)
415 continue
slen=ntmp-n
do 417 i=l3+slen,l2-1
call copyline(i,i-slen,1)
k(i-slen,3)=k(i,3)
417 continue
do 418 i=1,slen
call copyline(n+i,l2-slen-1+i,1)
k(l2-slen-1+i,3)=k(n+i,3)
418 continue
endif
endif
endif
! write(logfid,*)'after one iteration'
! call pevrec(3,.false.)
end do
! write(logfid,*)'before copying everything up'
! call pevrec(3,.false.)
C--copy remaining lines to top of event record
do 309 jj=lstart,n
if(k(jj,1).gt.0) then
if ((k(jj,3).gt.106).and.
& (p(jj,5).ne.pymass(k(jj,2)))) then
do 311 i=1,5
mv(jj,i)=mv(k(jj,3),i)
311 continue
endif
if ((k(jj,3).eq.1).or.(k(jj,3).eq.2)) then
mv(jj,1)=x0
mv(jj,2)=y0
mv(jj,3)=0.d0
mv(jj,4)=0.d0
mv(jj,5)=ltime
endif
nnew=nnew+1
call copyline(jj,nnew,1)
if (k(jj,3).lt.100) k(nnew,3)=k(jj,3)
za(nnew)=1.d0
zd(nnew)=zd(jj)
qqbard(nnew)=qqbard(jj)
thetaa(nnew)=p(nnew,5)/
& (sqrt(zd(nnew)*(1.-zd(nnew)))*p(nnew,4))
endif
309 continue
n=nnew
NPART=N-OFFSET
endif
! write(logfid,*)'end special treatment'
! call pevrec(3,.false.)
C--end special treatment
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
LME1ORIG=7
LME2ORIG=8
if(abs(k(7,2)).gt.21) then
lv=7
else
lv=8
endif
ELSE
LME1ORIG=OFFSET-1
LME2ORIG=OFFSET
ENDIF
DO 180 IPART=OFFSET+1, OFFSET+NPART
C--find decay leptons in V+jet events
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if(k(ipart,3).eq.offset-1) llep1=ipart
if(k(ipart,3).eq.offset) llep2=ipart
endif
IF(K(IPART,3).EQ.(LME1ORIG))THEN
LME1=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE1='GC'
ELSE
TYPE1='QQ'
ENDIF
ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN
LME2=IPART
IF(K(IPART,2).EQ.21)THEN
TYPE2='GC'
ELSE
TYPE2='QQ'
ENDIF
ELSE
TRIP(IPART)=0
ANTI(IPART)=0
! ZD(IPART)=0.d0
! THETAA(IPART)=0.d0
ENDIF
C--assign colour indices
IF(K(IPART,1).EQ.2)THEN
IF(K(IPART-1,1).EQ.2)THEN
C--in middle of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
C--beginning of colour singlet
IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0))
& .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN
TRIP(IPART)=COLMAX+1
ANTI(IPART)=0
FIRSTTRIP=.TRUE.
ELSE
TRIP(IPART)=0
ANTI(IPART)=COLMAX+1
FIRSTTRIP=.FALSE.
ENDIF
COLMAX=COLMAX+1
ENDIF
ENDIF
IF(K(IPART,1).EQ.1)THEN
C--end of colour singlet
IF(FIRSTTRIP)THEN
TRIP(IPART)=0
ANTI(IPART)=TRIP(IPART-1)
ELSE
TRIP(IPART)=ANTI(IPART-1)
ANTI(IPART)=0
ENDIF
ENDIF
180 CONTINUE
if (k(lme1,1).lt.11) K(LME1,1)=8
if (k(lme2,1).lt.11) K(LME2,1)=8
PID=K(LME1,2)
ENI=MAX(P(LME1,4),P(LME2,4))
DO 183 IPART=OFFSET+1, OFFSET+NPART
IF((IPART.NE.LME1).AND.(IPART.NE.LME2)
& .AND.(K(IPART,1).LT.11)) then
if (p(ipart,5).gt.pymass(k(ipart,2))) then
k(ipart,1)=1
else
if ((isparton(k(ipart,2))).and.
& (abs(pyp(ipart,19)).lt.etamax)) then
if (p(ipart,5).gt.0.d0) call makemassless(ipart,lme1,lme2)
k(ipart,1)=1
else
k(ipart,1)=4
endif
endif
endif
if (k(ipart,2).eq.22) k(ipart,1)=9
183 CONTINUE
! DO 183 IPART=OFFSET+1, OFFSET+NPART
! IF((IPART.NE.LME1).AND.(IPART.NE.LME2))
! & K(IPART,1)=11
! if (k(ipart,2).eq.22) k(ipart,1)=4
! 183 CONTINUE
C--find virtualities and adapt four-vectors
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
if (abs(k(lme1,2)).gt.21) then
QMAX1=0.d0
QMAX2=sqrt(pari(18)+p(lme1,5)**2)
else
QMAX1=sqrt(pari(18)+p(lme2,5)**2)
QMAX2=0.d0
endif
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ELSEIF(COLLIDER.EQ.'PPJJ'.OR.COLLIDER.EQ.'PPYJ'
& .OR.COLLIDER.EQ.'PPYQ'.OR.COLLIDER.EQ.'PPYG')THEN
if (k(lme1,1).eq.4) then
qmax1 = 0.d0
else
QMAX1=pari(17)
endif
if (k(lme2,1).eq.4) then
qmax2 = 0.d0
else
QMAX2=pari(17)
endif
! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
EN1=P(LME1,4)
EN2=P(LME2,4)
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
ETOT=P(LME1,4)+P(LME2,4)
IF(COLLIDER.EQ.'EEJJ')THEN
QMAX1=ETOT
QMAX2=ETOT
EMAX=P(LME1,4)+P(LME2,4)
THETA1=-1.d0
THETA2=-1.d0
ENDIF
C-- find virtuality
Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
182 if (abs(k(lme1,2)).gt.21) then
m1=p(lme1,5)
else
m1=q1
endif
if (abs(k(lme2,2)).gt.21) then
m2=p(lme2,5)
else
m2=q2
endif
ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2
P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0)
& .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0)
& )THEN
IF(Q1.GT.Q2)THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ELSE
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
GOTO 182
ENDIF
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=m1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=m2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 182
ENDIF
ENDIF
C--correct to ME for first parton
IF(COLLIDER.EQ.'EEJJ')THEN
BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4))
BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4))
BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4))
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
IF(Q1.GT.0.d0)THEN
C--generate z value
X1=Z1*(ETOT**2+Q1**2)/ETOT**2
X2=(ETOT**2-Q1**2)/ETOT**2
X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
ENDIF
ENDIF
C--correct to ME for second parton
IF(Q2.GT.0.d0)THEN
C--generate z value
X1=(ETOT**2-Q2**2)/ETOT**2
X2=Z2*(ETOT**2+Q2**2)/ETOT**2
X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2
PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
& + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
MEWEIGHT=X1**2+X2**2
WEIGHT=MEWEIGHT/PSWEIGHT
IF(PYR(0).GT.WEIGHT)THEN
185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
ENDIF
ENDIF
186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT)
ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT)
P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2
P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2
POLD=PYP(LME1,8)
P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD
P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD
P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD
P(LME1,4)=ENEW1
P(LME1,5)=Q1
POLD=PYP(LME2,8)
P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD
P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD
P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD
P(LME2,4)=ENEW2
P(LME2,5)=Q2
CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3))
C--correct for overestimated energy
IF(Q1.GT.0.d0)THEN
EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
& *SQRT(1.-Q1**2/P(LME1,4)**2)
IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
& Z1,WHICH1)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
IF(Q2.GT.0.d0)THEN
EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
& *SQRT(1.-Q2**2/P(LME2,4)**2)
IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
& Z2,WHICH2)
CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
GOTO 186
ENDIF
ENDIF
ENDIF
C--transfer recoil to decay leptons in V+jet
if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
& (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
& (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
beta(1)=p(lv,1)/p(lv,4)
beta(2)=p(lv,2)/p(lv,4)
beta(3)=p(lv,3)/p(lv,4)
CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if (abs(k(lme1,2)).gt.21) then
beta(1)=p(lme1,1)/p(lme1,4)
beta(2)=p(lme1,2)/p(lme1,4)
beta(3)=p(lme1,3)/p(lme1,4)
else
beta(1)=p(lme2,1)/p(lme2,4)
beta(2)=p(lme2,2)/p(lme2,4)
beta(3)=p(lme2,3)/p(lme2,4)
endif
CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3))
endif
C--store initial parton pt and mass for output
if (k(lme1,1).eq.1) then
inpt(1) = pyp(lme1,10)
! inpt(1) = p(lme1,4)*sin(pyp(lme1,13))
inmass(1) = p(lme1,5)
inphi(1) = pyp(lme1,15)
ineta(1) = pyp(lme1,19)
inpt(2) = pyp(lme2,10)
! inpt(2) = p(lme2,4)*sin(pyp(lme2,13))
inmass(2) = p(lme2,5)
inphi(2) = pyp(lme2,15)
ineta(2) = pyp(lme2,19)
if (k(lme1,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme2,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z1
inz(2) = z2
if(z1.gt.0.d0) then
intheta(1) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(1) = 0.d0
endif
if(z2.gt.0.d0) then
intheta(2) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(2) = 0.d0
endif
else
inpt(1) = pyp(lme2,10)
! inpt(1) = p(lme2,4)*sin(pyp(lme2,13))
inmass(1) = p(lme2,5)
inphi(1) = pyp(lme2,15)
ineta(1) = pyp(lme2,19)
inpt(2) = pyp(lme1,10)
! inpt(2) = p(lme1,4)*sin(pyp(lme1,13))
inmass(2) = p(lme1,5)
inphi(2) = pyp(lme1,15)
ineta(2) = pyp(lme1,19)
if (k(lme2,2).eq.21) then
isgluon(1) = 1
elseif (abs(k(lme2,2)).le.5) then
isgluon(1) = 0
else
isgluon(1) = 2
endif
if (k(lme1,2).eq.21) then
isgluon(2) = 1
elseif (abs(k(lme1,2)).le.5) then
isgluon(2) = 0
else
isgluon(2) = 2
endif
inz(1) = z2
inz(2) = z1
if(z2.gt.0.d0) then
intheta(1) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
else
intheta(1) = 0.d0
endif
if(z1.gt.0.d0) then
intheta(2) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
else
intheta(2) = 0.d0
endif
endif
ZA(LME1)=1.d0
ZA(LME2)=1.d0
THETAA(LME1)=P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
THETAA(LME2)=P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
ZD(LME1)=Z1
ZD(LME2)=Z2
QQBARD(LME1)=WHICH1
QQBARD(LME2)=WHICH2
MV(LME1,1)=X0
MV(LME1,2)=Y0
MV(LME1,3)=0.d0
MV(LME1,4)=0.d0
IF(P(LME1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME1,4)*0.2/Q1**2)
MV(LME1,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME1,5)=LTIME
ENDIF
MV(LME2,1)=X0
MV(LME2,2)=Y0
MV(LME2,3)=0.d0
MV(LME2,4)=0.d0
IF(P(LME2,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(LME2,4)*0.2/Q2**2)
MV(LME2,5)=-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(LME2,5)=LTIME
ENDIF
! write(logfid,*)'before parton shower'
-! call pevrec(3,.false.)
+! call pevrec(2,.false.)
C--develop parton shower
CALL MAKECASCADE
IF(DISCARD) THEN
NGOOD=NGOOD-1
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
write(logfid,*)'discard event',J
GOTO 102
ENDIF
- do 78 i=1,n
+! write(logfid,*)'after first parton shower'
+! call pevrec(2,.false.)
+
+ do 78 i=1,n
if (k(i,1).eq.8) k(i,1)=1
if (k(i,1).eq.4) k(i,1)=7
- if (k(i,1).eq.3) k(i,1)=7
+ if ((k(i,1).eq.3).or.(k(i,1).eq.5)) k(i,1)=8
if (k(i,1).eq.9) k(i,1)=4
78 continue
CALL MAKECASCADE
IF(DISCARD) THEN
NGOOD=NGOOD-1
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
write(logfid,*)'discard event',J
GOTO 102
ENDIF
+
+! write(logfid,*)'after second parton shower'
+! call pevrec(2,.false.)
! write(logfid,*)'after parton shower'
! call pevrec(2,.true.)
IF(.NOT.ALLHAD)THEN
DO 86 I=1,N
IF(K(I,1).EQ.3) K(I,1)=22
86 CONTINUE
ENDIF
IF(HADRO)THEN
CALL MAKESTRINGS(HADROTYPE)
! call combinegluons()
IF(DISCARD) THEN
write(logfid,*)'discard event',J
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
CALL PYEXEC
IF(MSTU(30).NE.ERRCOUNT)THEN
write(logfid,*)'PYTHIA discards event',J,
& ' (error number',MSTU(30),')'
ERRCOUNT=MSTU(30)
WDISC=WDISC+EVWEIGHT
NDISC=NDISC+1
NGOOD=NGOOD-1
GOTO 102
ENDIF
ENDIF
! DO 888 I=1,N
! IF(K(I,2).EQ.94)THEN
! NGOOD=NGOOD-1
! NSTRANGE=NSTRANGE+1
! NDISC=NDISC+1
! call pevrec(2,.false.)
! GOTO 102
! ENDIF
! 888 CONTINUE
IF(MSTU(30).NE.ERRCOUNT)THEN
ERRCOUNT=MSTU(30)
ELSE
CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
ENDIF
C--write message to log-file
102 IF(NSIM.GT.100)THEN
IF(MOD(J,NSIM/100).EQ.0)THEN
write(logfid,*) 'done with event number ',J,
& PARI(1), (sumofweights-wdisc)/j
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
else
write(logfid,*) 'done with event number ',J
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
call flush(logfid)
end
***********************************************************************
*** subroutine makestrings
***********************************************************************
SUBROUTINE MAKESTRINGS(WHICH)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
INTEGER WHICH
IF(WHICH.EQ.0)THEN
CALL MAKESTRINGS_VAC
ELSEIF(WHICH.EQ.1)THEN
CALL MAKESTRINGS_MINL
ELSE
WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS'
ENDIF
END
***********************************************************************
*** subroutine makestrings_vac
***********************************************************************
SUBROUTINE MAKESTRINGS_VAC
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1
DOUBLE PRECISION EADDEND,PYR,DIR
LOGICAL ISDIQUARK,compressevent,roomleft
DATA EADDEND/10.d0/
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--first do strings with existing (anti)triplets
C--find string end (=quark or antiquark)
43 LQUARK=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR.
& (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN
LQUARK=I
GOTO 41
ENDIF
40 CONTINUE
GOTO 50
41 CONTINUE
C--copy string end to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LQUARK,2)
K(N,3)=LQUARK
K(N,4)=0
K(N,5)=0
P(N,1)=P(LQUARK,1)
P(N,2)=P(LQUARK,2)
P(N,3)=P(LQUARK,3)
P(N,4)=P(LQUARK,4)
P(N,5)=P(LQUARK,5)
K(LQUARK,1)=16
K(LQUARK,4)=N
K(LQUARK,5)=N
TRIP(N)=TRIP(LQUARK)
ANTI(N)=ANTI(LQUARK)
C--append matching colour partner
LMATCH=0
DO 44 J=1,10000000
DO 42 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0))
& .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
IF(K(I,2).EQ.21)THEN
K(N,1)=2
GOTO 44
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
42 CONTINUE
C--no matching colour partner found
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event',n,trip(n),anti(n),i
call pevrec(2,.true.)
discard = .true.
return
44 CONTINUE
C--now take care of purely gluonic remainder system
C-----------------------------------------
C--find gluon where anti-triplet is not matched
50 LLOOSE=0
DO 45 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
DO 46 J=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)))THEN
IF(ANTI(I).EQ.TRIP(J)) GOTO 45
ENDIF
46 CONTINUE
LLOOSE=I
GOTO 47
ENDIF
45 CONTINUE
GOTO 51
47 CONTINUE
C--generate artificial triplet end
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
C--copy loose gluon to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LLOOSE,2)
K(N,3)=LLOOSE
K(N,4)=0
K(N,5)=0
P(N,1)=P(LLOOSE,1)
P(N,2)=P(LLOOSE,2)
P(N,3)=P(LLOOSE,3)
P(N,4)=P(LLOOSE,4)
P(N,5)=P(LLOOSE,5)
K(LLOOSE,1)=16
K(LLOOSE,4)=N
K(LLOOSE,5)=N
TRIP(N)=TRIP(LLOOSE)
ANTI(N)=ANTI(LLOOSE)
C--append matching colour partner
LMATCH=0
DO 48 J=1,10000000
DO 49 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5))
& .AND.(ANTI(I).EQ.TRIP(N)))THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
K(I,1)=16
K(I,4)=N
K(I,5)=N
K(N,1)=2
GOTO 48
ENDIF
49 CONTINUE
C--no matching colour partner found, add artificial end point
write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
&'colour singlet system, will discard event'
discard = .true.
return
48 CONTINUE
51 CONTINUE
CALL CLEANUP(NOLD1)
END
***********************************************************************
*** subroutine makestrings_minl
***********************************************************************
SUBROUTINE MAKESTRINGS_MINL
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1
DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR,
&pyp
DATA MCUT/1.d8/
DATA EADDEND/10.d0/
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
logical compressevent,roomleft
i = 0
if (compress) roomleft = compressevent(i)
NOLD1=N
C--remove all active lines that are leptons, gammas, hadrons etc.
DO 52 I=1,NOLD1
IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
C--copy line to end of event record
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=11
K(N,2)=K(I,2)
K(N,3)=I
K(N,4)=0
K(N,5)=0
P(N,1)=P(I,1)
P(N,2)=P(I,2)
P(N,3)=P(I,3)
P(N,4)=P(I,4)
P(N,5)=P(I,5)
K(I,1)=17
K(I,4)=N
K(I,5)=N
TRIP(N)=TRIP(I)
ANTI(N)=ANTI(I)
ENDIF
52 CONTINUE
NOLD=N
C--find most energetic unfragmented parton in event
43 EMAX=0
LMAX=0
DO 40 I=1,NOLD
IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
& .OR.(K(I,1).EQ.14)) K(I,1)=17
if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
& .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN
EMAX=P(I,4)
LMAX=I
ENDIF
40 CONTINUE
C--if there is non, we are done
IF(LMAX.EQ.0) GOTO 50
C--check if highest energy parton is (anti)quark or gluon
IF(K(LMAX,2).EQ.21)THEN
C--split gluon in qqbar pair and store one temporarily in line 1
C--make new line in event record for string end
N=N+2
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF((N-2).GT.NOLD)THEN
DO 47 J=NOLD,N-3
K(N+NOLD-J,1)=K(N+NOLD-J-2,1)
K(N+NOLD-J,2)=K(N+NOLD-J-2,2)
IF(K(N+NOLD-J-2,3).GT.NOLD) THEN
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2
ELSE
K(N+NOLD-J,3)=K(N+NOLD-J-2,3)
ENDIF
K(N+NOLD-J,4)=0
K(N+NOLD-J,5)=0
P(N+NOLD-J,1)=P(N+NOLD-J-2,1)
P(N+NOLD-J,2)=P(N+NOLD-J-2,2)
P(N+NOLD-J,3)=P(N+NOLD-J-2,3)
P(N+NOLD-J,4)=P(N+NOLD-J-2,4)
P(N+NOLD-J,5)=P(N+NOLD-J-2,5)
K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2
K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2
47 CONTINUE
ENDIF
NOLD=NOLD+2
K(LMAX,1)=18
Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG')
IF(Z.GT.0.5)THEN
K(NOLD-1,2)=1
K(NOLD,2)=-1
ELSE
Z=1.-Z
K(NOLD-1,2)=-1
K(NOLD,2)=1
ENDIF
K(NOLD-1,1)=1
K(NOLD-1,3)=LMAX
K(NOLD-1,4)=0
K(NOLD-1,5)=0
P(NOLD-1,1)=(1.-Z)*P(LMAX,1)
P(NOLD-1,2)=(1.-Z)*P(LMAX,2)
P(NOLD-1,3)=(1.-Z)*P(LMAX,3)
P(NOLD-1,4)=(1.-Z)*P(LMAX,4)
P(NOLD-1,5)=P(LMAX,5)
K(NOLD,1)=1
K(NOLD,3)=LMAX
K(NOLD,4)=0
K(NOLD,5)=0
P(NOLD,1)=Z*P(LMAX,1)
P(NOLD,2)=Z*P(LMAX,2)
P(NOLD,3)=Z*P(LMAX,3)
P(NOLD,4)=Z*P(LMAX,4)
P(NOLD,5)=P(LMAX,5)
K(LMAX,1)=18
K(LMAX,4)=NOLD-1
K(LMAX,5)=NOLD
LMAX=NOLD
ENDIF
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=2
K(N,2)=K(LMAX,2)
K(N,3)=LMAX
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMAX,1)
P(N,2)=P(LMAX,2)
P(N,3)=P(LMAX,3)
P(N,4)=P(LMAX,4)
P(N,5)=P(LMAX,5)
K(LMAX,1)=16
K(LMAX,4)=N
K(LMAX,5)=N
LEND=LMAX
C--find closest partner
42 MMIN=1.d10
LMIN=0
DO 41 I=1,NOLD
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1)
& .EQ.4).OR.(K(I,1).EQ.5))
& .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND.
& (K(I,3).NE.K(LEND,3))))
& .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN
MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2)
& -P(I,3)*P(LMAX,3)
IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN
MMIN=MINV
LMIN=I
ENDIF
ENDIF
41 CONTINUE
C--if no closest partner can be found, generate artificial end point for string
IF(LMIN.EQ.0)THEN
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,1)=1
K(N,2)=-K(LEND,2)
K(N,3)=0
K(N,4)=0
K(N,5)=0
P(N,1)=0.d0
P(N,2)=0.d0
IF(PYR(0).LT.0.5)THEN
DIR=1.d0
ELSE
DIR=-1.d0
ENDIF
P(N,3)=DIR*EADDEND
P(N,4)=EADDEND
P(N,5)=0.d0
GOTO 43
ELSE
C--else build closest partner in string
N=N+1
IF(N.GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
K(N,2)=K(LMIN,2)
K(N,3)=LMIN
K(N,4)=0
K(N,5)=0
P(N,1)=P(LMIN,1)
P(N,2)=P(LMIN,2)
P(N,3)=P(LMIN,3)
P(N,4)=P(LMIN,4)
P(N,5)=P(LMIN,5)
K(LMIN,1)=16
K(LMIN,4)=N
K(LMIN,5)=N
IF(K(LMIN,2).EQ.21)THEN
K(N,1)=2
LMAX=LMIN
GOTO 42
ELSE
K(N,1)=1
GOTO 43
ENDIF
ENDIF
50 CONTINUE
CALL CLEANUP(NOLD)
END
***********************************************************************
*** subroutine cleanup
***********************************************************************
SUBROUTINE CLEANUP(NFIRST)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
INTEGER NFIRST,NLAST,I,J
NLAST=N
DO 21 I=1,NLAST-NFIRST
DO 22 J=1,5
K(I,J)=K(NFIRST+I,J)
P(I,J)=P(NFIRST+I,J)
V(I,J)=V(NFIRST+I,J)
22 CONTINUE
K(I,3)=0
21 CONTINUE
N=NLAST-NFIRST
END
***********************************************************************
*** subroutine makecascade
***********************************************************************
SUBROUTINE MAKECASCADE
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--local variables
INTEGER NOLD,I
LOGICAL CONT
10 NOLD=N
CONT=.FALSE.
DO 11 I=2,NOLD
if (i.gt.n) goto 10
C--check if parton may evolve, i.e. do splitting or scattering
IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN
CONT=.TRUE.
CALL MAKEBRANCH(I)
IF(DISCARD) GOTO 12
ENDIF
11 CONTINUE
IF(CONT) GOTO 10
12 END
***********************************************************************
*** subroutine makebranch
***********************************************************************
SUBROUTINE MAKEBRANCH(L)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
& scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--local variables
INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold
integer oldstcode
DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT,
&TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR
LOGICAL OVERQ0,QQBARDEC
CHARACTER TYP
LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent
LINE=L
NSTART=0
NEND=0
if ((mv(line,4).lt.0.d0).and.(mv(line,5).gt.0.d0)) then
starttime=0.d0
else
STARTTIME=MV(LINE,4)
endif
TSUM=0.d0
QSUM2=0.d0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
RETRYSPLIT=.FALSE.
MEDIND=.FALSE.
X=0.d0
Q=0.d0
TYPI=0
20 IF(DISCARD) RETURN
IF ((N.GT.20000).and.compress) roomleft = compressevent(line)
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN
IF(MEDIND)THEN
FORMTIME=starttime
ELSE
FORMTIME=MIN(MV(LINE,5),LTIME)
ENDIF
RADIATION=.TRUE.
ELSE
FORMTIME=LTIME
RADIATION=.FALSE.
ENDIF
TLEFT=FORMTIME-STARTTIME
IF(K(LINE,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
MEDIND=.FALSE.
! write(logfid,*)'makebranch: starttime tleft formtime radiation',
! & line, starttime,tleft,formtime,radiation
IF((TLEFT.LE.1.d-10).or.(starttime.lt.0.d0))THEN
C--no scattering
IF(RADIATION)THEN
C--if there is radiation associated with the parton then form it now
C--rotate such that momentum points in z-direction
NOLD=N
nscatcenold=nscatcen
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL MAKESPLITTING(LINE)
C--rotate back
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
IF(DISCARD) RETURN
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(LINE,1)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N-1,2)=MV(LINE,2)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N-1,3)=MV(LINE,3)
& +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
MV(N, 1)=MV(LINE,1)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
MV(N, 2)=MV(LINE,2)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
MV(N, 3)=MV(LINE,3)
& +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
LINE=N
NSTART=0
NEND=0
if ((mv(n,4).lt.0.d0).and.(mv(n,5).gt.0.d0)) then
starttime=0.d0
else
STARTTIME=MV(N,4)
endif
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ELSE
NSTART=0
NEND=0
STARTTIME=FORMTIME
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
TSUM=0.d0
GOTO 21
ENDIF
ELSE
C--do scattering
C--find delta t for the scattering
DELTAT=TLEFT
OVERQ0=.FALSE.
CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,
& OVERQ0,.FALSE.)
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
C--do initial state splitting if there is one
NOLD=N
LINEOLD=LINE
oldstcode=k(line,1)
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
nscatcenold=nscatcen
25 IF(X.LT.1.d0) THEN
CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT)
IF(DISCARD) RETURN
IF(X.LT.1.d0)THEN
LINE=N
LKINE=N
IF(K(LINE,2).EQ.21)THEN
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ELSE
NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
& 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
IF(ZDEC.GT.0.d0)THEN
THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
ELSE
THETAA(LINE)=0.d0
ENDIF
ZD(LINE)=ZDEC
QQBARD(LINE)=QQBARDEC
ENDIF
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ELSE
LKINE=LINE
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
ENDIF
ENDIF
IF(X.EQ.1.d0)THEN
NEWMASS=0.d0
IF(NEND.GT.0)THEN
CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT,
& NEWMASS,OVERQ0,ZDEC,QQBARDEC)
IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN
MEDIND=.TRUE.
ELSE
MEDIND=.FALSE.
ZDEC=ZD(LINE)
QQBARDEC=QQBARD(LINE)
ENDIF
TSUM=TSUM+DELTAT
TLEFT=TLEFT-DELTAT
LKINE=LINE
ENDIF
ENDIF
C--do kinematics
RETRYSPLIT=.FALSE.
IF(NEND.GT.0) THEN
nendold=nend
CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT,
& STARTTIME+TSUM,X,ZDEC,QQBARDEC)
IF(RETRYSPLIT) THEN
tleft = starttime+tsum+tleft-allqs(1,6)
tsum = allqs(1,6)-starttime
if (x.lt.1.d0) then
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
N=NOLD
LINE=LINEOLD
X=1.d0
K(LINE,1)=oldstcode
! K(LINE,1)=1
nscatcen=nscatcenold
NSPLIT=NSPLIT-EVWEIGHT
nspliti=nspliti-evweight
GOTO 25
else
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
endif
ELSE
LINE=N
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
ELSE
STARTTIME=STARTTIME+TSUM
TSUM=0.d0
ENDIF
! IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE.
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))) RADIATION=.TRUE.
ENDIF
21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))
& .OR.(STARTTIME.LT.LTIME))THEN
GOTO 20
ENDIF
IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4
IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5
END
***********************************************************************
*** subroutine makesplitting
***********************************************************************
SUBROUTINE MAKESPLITTING(L)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,DIR
DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC,
&GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA,
&GETTEMP
LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4)
XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4)
XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4)
IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN
THETA=-1.d0
ELSE
THETA=THETAA(L)
ENDIF
C--on-shell partons cannot split
IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)
& .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3)
& .or.(zd(l).lt.0.d0)) GOTO 31
C--quark or gluon?
IF(K(L,2).EQ.21)THEN
QUARK=.FALSE.
ELSE
QUARK=.TRUE.
QQBAR=.FALSE.
ENDIF
C--if gluon decide on kind of splitting
QQBAR=QQBARD(L)
C--if g->gg splitting decide on colour order
IF(QUARK.OR.QQBAR)THEN
DIR=0
ELSE
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ENDIF
Z=ZD(L)
IF(Z.EQ.0.d0)THEN
write(logfid,*)'makesplitting: z=0',L,p(l,5)
call pevrec(2,.false.)
goto 36
ENDIF
GOTO 35
C--generate z value
36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN
C--additional z constraint due to angular ordering
QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2)
IF(QH.GT.1)THEN
write(logfid,*)L,': reject event: angular ordering
& conflict in medium'
CALL PYLIST(2)
DISCARD=.TRUE.
GOTO 31
ENDIF
EPS=0.5-0.5*SQRT(1.-QH)
ELSE
EPS=0d0
ENDIF
IF(QUARK)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ')
ELSE
IF(QQBAR)THEN
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG')
ELSE
Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG')
ENDIF
ENDIF
35 CONTINUE
C--maximum virtualities for daughters
BMAX1=MIN(P(L,5),Z*P(L,4))
CMAX1=MIN(P(L,5),(1.-Z)*P(L,4))
C--generate mass of quark or gluon (particle b) from Sudakov FF
30 IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
C--generate mass gluon (particle c) from Sudakov FF
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
C--quark (parton b) momentum
182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3))
PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2
C--if kinematics doesn't work out, generate new virtualities
C for daughters
C--massive phase space weight
IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36
WEIGHT=1.d0
IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0)
& .OR.((MB+MC).GT.P(L,5)))THEN
IF(MB.GT.MC)THEN
IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ELSE
MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC',
& BMAX1,.FALSE.,ZDECB,QQBARDECB)
ENDIF
ELSE
IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ELSE
MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ',
& CMAX1,.FALSE.,ZDECC,QQBARDECC)
ENDIF
ENDIF
GOTO 182
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(QQBAR)THEN
K(N-1,2)=-1
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1-Z)*P(L,4)
P(N-1,5)=MC
ZA(N-1)=1.-Z
IF(ZDECC.GT.0.d0)THEN
THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4))
ELSE
THETAA(N-1)=0.d0
ENDIF
ZD(N-1)=ZDECC
QQBARD(N-1)=QQBARDECC
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(QUARK)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(QQBAR)THEN
K(N,2)=1
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
K(N,2)=21
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=Z*P(L,4)
P(N,5)=MB
ZA(N)=Z
IF(ZDECB.GT.0.d0)THEN
THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4))
ELSE
THETAA(N)=0.d0
ENDIF
ZD(N)=ZDECB
QQBARD(N)=QQBARDECB
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(PTS)*COS(PHIQ)
P(N,2)=SQRT(PTS)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N,5)=0.d0
ENDIF
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nsplitf=nsplitf+evweight
31 CONTINUE
END
***********************************************************************
*** subroutine makeinsplit
***********************************************************************
SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--local variables
INTEGER L,TYPI,NOLD,DIR
DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
&PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC
LOGICAL QQBARDEC
CHARACTER*2 TYP2,TYPC
integer bin
DATA PI/3.141592653589793d0/
IF((N+2).GT.22990) THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
IF(TYPI.EQ.21)THEN
TYP2='GG'
TYPC='GC'
ELSE
TYP2='QG'
TYPC='QQ'
ENDIF
ELSE
IF(TYPI.EQ.21)THEN
TYP2='GQ'
TYPC='QQ'
ELSE
TYP2='QQ'
TYPC='GC'
ENDIF
ENDIF
C--if g->gg decide on colour configuration
IF(TYP2.EQ.'GG')THEN
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
DIR=0
ENDIF
MB2=VIRT**2
MB2=P(L,5)**2-MB2
! MB2=-VIRT**2
MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0,
& (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4),
& .FALSE.,ZDEC,QQBARDEC)**2
C--rotate such that momentum points in z-direction
NOLD=N
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
MC2=0.d0
IF(K(L,1).EQ.2) zdec = -1.d0
PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
KT2=X**2*(P(L,4)**2)-PZ**2-MB2
IF(KT2.LT.0.d0)THEN
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
X=1.d0
RETURN
ENDIF
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
! K(N-1,1)=K(L,1)
K(N-1,1)=1
IF(TYP2.EQ.'QG')THEN
K(N-1,2)=-TYPI
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=ANTI(L)
ENDIF
ELSEIF(TYP2.EQ.'GQ')THEN
K(N-1,2)=K(L,2)
IF(K(N-1,2).GT.0)THEN
TRIP(N-1)=COLMAX+1
ANTI(N-1)=0
ELSE
TRIP(N-1)=0
ANTI(N-1)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
K(N-1,2)=21
IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(L)
ANTI(N-1)=COLMAX+1
ELSE
TRIP(N-1)=COLMAX+1
ANTI(N-1)=ANTI(L)
ENDIF
COLMAX=COLMAX+1
ENDIF
K(N-1,3)=L
K(N-1,4)=0
K(N-1,5)=0
P(N-1,4)=(1.-X)*P(L,4)
P(N-1,5)=SQRT(MC2)
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
! K(N,1)=K(L,1)
K(N,1)=1
IF(TYP2.EQ.'QG')THEN
K(N,2)=TYPI
IF(K(N,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=ANTI(L)
ENDIF
ELSEIF(TYPI.NE.21)THEN
K(N,2)=K(L,2)
IF(K(N,2).GT.0)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=TRIP(N-1)
ENDIF
ELSE
K(N,2)=21
IF(K(N-1,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ELSE
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ENDIF
ELSEIF(K(N-1,2).GT.0)THEN
TRIP(N)=TRIP(L)
ANTI(N)=TRIP(N-1)
ELSE
TRIP(N)=ANTI(N-1)
ANTI(N)=ANTI(L)
ENDIF
ENDIF
K(N,3)=L
K(N,4)=0
K(N,5)=0
P(N,3)=PZ
P(N,4)=X*P(L,4)
IF(MB2.LT.0.d0)THEN
P(N,5)=-SQRT(-MB2)
ELSE
P(N,5)=SQRT(MB2)
ENDIF
C--azimuthal angle
PHIQ=2*PI*PYR(0)
P(N,1)=SQRT(KT2)*COS(PHIQ)
P(N,2)=SQRT(KT2)*SIN(PHIQ)
C--gluon momentum
P(N-1,1)=P(L,1)-P(N,1)
P(N-1,2)=P(L,2)-P(N,2)
P(N-1,3)=P(L,3)-P(N,3)
MV(L,5)=TIME-TAURAD
MV(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
MV(N,5)=TIME
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=ZDEC
QQBARD(N-1)=QQBARDEC
ZA(N)=1.d0
THETAA(N)=-1.d0
ZD(N)=0.d0
QQBARD(N)=.FALSE.
C--take care of initial quark (or gluon)
IF(K(L,1).EQ.2)THEN
K(L,1)=13
ELSE
K(L,1)=11
ENDIF
K(L,4)=N-1
K(L,5)=N
NSPLIT=NSPLIT+EVWEIGHT
nspliti=nspliti+evweight
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
END
***********************************************************************
*** subroutine doinstatescat
***********************************************************************
SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0,
& RETRYSPLIT)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT,
&WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT,
&XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS,
&GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD,
&GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT,
&pyp
LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT,
&QQBARDUM
CHARACTER TYP
CHARACTER*2 TYP2
DATA PI/3.141592653589793d0/
DATA COUNTMAX/10000/
COUNTER=0
XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4)
YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4)
ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4)
TSC=TSTART
MD1=GETMD(XSC,YSC,ZSC,TSC)
MS1=GETMS(XSC,YSC,ZSC,TSC)
IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN
write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC),
&GETNEFF(XSC,YSC,ZSC,TSC)
ENDIF
C--check for scattering
NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT)
IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116
C--decide whether there will be radiation
PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc)
IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN
NORAD=.TRUE.
ELSE
NORAD=.FALSE.
ENDIF
C--decide whether q or g is to be scattered
IF(K(L,2).EQ.21)THEN
TYP='G'
TYP2='GC'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'G','Q',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'G','C',xsc,ysc,zsc,tsc,0)
ELSE
TYP='Q'
TYP2='QQ'
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','C',xsc,ysc,zsc,tsc,0)
IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
PFCHANGE=0.d0
ELSE
PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& Q0,'Q','G',xsc,ysc,zsc,tsc,0)
& /SIGMATOT
ENDIF
SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
& 0.d0,'Q','C',xsc,ysc,zsc,tsc,0)
ENDIF
IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN
write(logfid,*)'error: flavour change probability=',
& PFCHANGE,'for ',TYP
ENDIF
IF(PYR(0).LT.PFCHANGE)THEN
FCHANGE=.TRUE.
ELSE
FCHANGE=.FALSE.
ENDIF
IF (NORAD) FCHANGE=.FALSE.
C--set TYPI
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
TYPI=INT(SIGN(2.d0,PYR(0)-0.5))
ELSE
TYPI=K(L,2)
ENDIF
ELSE
IF(FCHANGE)THEN
TYPI=21
ELSE
TYPI=K(L,2)
ENDIF
ENDIF
LOW=Q0**2/SCALEFACM**2
TMAX=4.*(P(L,4)**2-P(L,5)**2)
XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX)
IF(SIGMATOT.EQ.0.d0) GOTO 116
RTAU=PYR(0)
C--generate a trial emission
C--pick a x value from splitting function
112 COUNTER=COUNTER+1
IF(TYP.EQ.'G')THEN
IF(FCHANGE)THEN
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG')
ENDIF
ELSE
IF(FCHANGE)THEN
X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ELSE
X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
ENDIF
ENDIF
IF(NORAD) X=1.d0
C--initialisation
TMAXNEW=(X*P(L,4))**2
PHI=0.d0
TLEFT=DELTAT
TNOW=TSTART
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=-1.d-10
OVERQ0=.FALSE.
Q=P(L,5)
QOLD=P(L,5)
TAUEST=DELTAT
C--generate first momentum transfer
DELTAL=DT
NSTART=1
NEND=1
TNOW=TNOW+DELTAL
TSUM=DELTAL
TLEFT=TLEFT-DELTAL
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 118
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE.
C--get new virtuality
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
C--estimate formation time
111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN
TAUEST=DELTAT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
C--find number, position and momentum transfers of further scatterings
NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL)
IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN
C--add a momentum transfer
NEND=NEND+1
IF(NEND.GE.100)THEN
nend=nend-1
goto 114
ENDIF
TNOW=TNOW+DELTAL
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
C--update phase
IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4))
ENDIF
C--get new momentum transfer
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
COUNT2=0
119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 119
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--update OVERQ0
IF((-QSUM2.GT.LOW)
& .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE.
C--get new virtuality
QOLD=Q
IF(OVERQ0.AND.(.NOT.NORAD))THEN
Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
& .TRUE.,X,ZDUM,QQBARDUM)
ELSE
Q=0.d0
ENDIF
GOTO 111
ENDIF
C--do reweighting
114 TMAXNEW=X**2*P(L,4)**2
IF(NORAD)THEN
WEIGHT=1.d0
Q=0.d0
X=1.d0
ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN
WEIGHT=0.d0
ELSEIF(-QSUM2.GT.P(L,4)**2)THEN
WEIGHT=0.d0
ELSE
IF(TYP.EQ.'G')THEN
FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg',
& FMAX
ENDIF
ENDIF
ENDIF
ELSE
FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2)
& *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
IF(QSUM2.EQ.0.d0)THEN
WEIGHT=0.d0
NORAD=.TRUE.
ELSE
IF(FCHANGE)THEN
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq',
& FMAX
ENDIF
ELSE
WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX)
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
& SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq',
& FMAX
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))
& write(logfid,*)'error: weight=',WEIGHT
115 IF(PYR(0).GT.WEIGHT)THEN
IF(COUNTER.LT.COUNTMAX)THEN
GOTO 112
ELSE
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
RETURN
ENDIF
ENDIF
C--found meaningful configuration, now do final checks
C--check if phase is unity and weight with 1/Nscat
IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0)))
& .AND.(.NOT.NORAD))THEN
Q=0.d0
X=1.d0
NEND=NSTART
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
TYPI=K(L,2)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
DELTAT=ALLQS(NEND,6)-TSTART
TNOW=ALLQS(1,6)
ELSE
IF(.NOT.NORAD)THEN
TLEFT=TLEFT-TAUEST
TNOW=TNOW+TAUEST
TSUM=TSUM+TAUEST
ENDIF
DELTAT=TSUM
ENDIF
RETURN
C--exit in case of failure
116 Q=0.d0
X=1.d0
NSTART=0
NEND=0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
OVERQ0=.FALSE.
TYPI=K(L,2)
RETURN
END
***********************************************************************
*** subroutine dofistatescat
***********************************************************************
SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS,
& OVERQ0,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--local variables
INTEGER L,COUNTER,COUNTMAX,COUNT2
DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD,
&GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI,
&TAUEST,LOW,Z,pyp
LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR
CHARACTER TYP
DATA COUNTMAX/100/
DELTAL=0.d0
IF(-QSUM2.GT.P(L,4)**2)
& write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2
IF(K(L,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
LOW=Q0**2/SCALEFACM**2
TSUM=0.d0
PHI=0.d0
DELTAT=0.d0
C--check for radiation with first (given) momentum transfer
Q2OLD=0.d0
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ELSE
NEWMASS=P(L,5)
ENDIF
RTAU=PYR(0)
TLEFT=DTLEFT
222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN
TAUEST=TLEFT
ELSE
TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2
ENDIF
LAMBDA=1.d0/TAUEST
TAUEST=-LOG(1.d0-RTAU)/LAMBDA
NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL)
IF(.NOT.NOSCAT)THEN
C--do scattering
NEND=NEND+1
IF(NEND.gt.countmax)THEN
nend=nend-1
goto 218
ENDIF
IF(NSTART.EQ.0) NSTART=1
TSUM=TSUM+DELTAL
TLEFT=TLEFT-DELTAL
IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN
PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4))
ENDIF
ALLQS(NEND,6)=TNOW+TSUM
QSUMVECOLD(1)=QSUMVEC(1)
QSUMVECOLD(2)=QSUMVEC(2)
QSUMVECOLD(3)=QSUMVEC(3)
QSUMVECOLD(4)=QSUMVEC(4)
Q2OLD=QSUM2
C--get new momentum transfer
COUNT2=0
219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0)
IF(-QSUM2.GT.P(L,4)**2)THEN
QSUMVEC(1)=QSUMVECOLD(1)
QSUMVEC(2)=QSUMVECOLD(2)
QSUMVEC(3)=QSUMVECOLD(3)
QSUMVEC(4)=QSUMVECOLD(4)
QSUM2=Q2OLD
IF(COUNT2.LT.100)THEN
COUNT2=COUNT2+1
GOTO 219
ELSE
ALLQS(NEND,1)=0.d0
ALLQS(NEND,2)=0.d0
ALLQS(NEND,3)=0.d0
ALLQS(NEND,4)=0.d0
ALLQS(NEND,5)=0.d0
ENDIF
ENDIF
C--figure out new virtuality
IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
& NEWMASS,.FALSE.,1.d0,Z,QQBAR)
OVERQ0=.TRUE.
ENDIF
GOTO 222
ENDIF
C--no more scattering
218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then
if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then
if (nend.eq.countmax) then
deltat=tsum
else if (TLEFT.LT.TAUEST) then
DELTAT=TSUM+tleft
else
DELTAT=TSUM+tauest
endif
NEWMASS=P(L,5)
ELSE
DELTAT=TSUM+TAUEST
ENDIF
else
DELTAT=0.d0
NSTART=1
NEND=1
QSUM2=ALLQS(NEND,1)
QSUMVEC(1)=ALLQS(NEND,2)
QSUMVEC(2)=ALLQS(NEND,3)
QSUMVEC(3)=ALLQS(NEND,4)
QSUMVEC(4)=ALLQS(NEND,5)
IF(-ALLQS(NEND,1).GT.LOW)THEN
OVERQ0=.TRUE.
ELSE
OVERQ0=.FALSE.
ENDIF
NEWMASS=P(L,5)
endif
return
END
***********************************************************************
*** function getnewmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X,
& ZDEC,QQBARDEC)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L
DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
&GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD
LOGICAL IN,QQBARDEC,QQBAROLD
CHARACTER*2 TYP
IF(x*P(L,4).LT.Q0)THEN
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
IF (-Q2.LT.Q0**2)THEN
GETNEWMASS=0.d0
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
TYP='GC'
ELSE
TYP='QQ'
ENDIF
IF(SQRT(-QOLD2).LE.Q0)THEN
IF(IN)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
ELSE
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
ENDIF
GETNEWMASS=MIN(GETNEWMASS,X*P(L,4))
RETURN
ENDIF
Z=1.d0
QA=1.d0
IF(MAX(P(L,5),MASS).GT.0.d0)THEN
IF(-Q2.GT.-QOLD2)THEN
ZOLD=ZDEC
QQBAROLD=QQBARDEC
QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF(QTMP.LT.SQRT(-QOLD2))THEN
GETNEWMASS=MASS
ZDEC=ZOLD
QQBARDEC=QQBAROLD
ELSE
GETNEWMASS=QTMP
ENDIF
ELSE
PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4),
& TYP,MV(L,4),IN)
PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
IF(PYR(0).LT.PKEEP)THEN
IF(P(L,5).LT.SQRT(-Q2))THEN
GETNEWMASS=MASS
ELSE
55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
& SQRT(-Q2),IN,ZDEC,QQBARDEC)
IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55
ENDIF
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
ELSE
IF(-Q2.GT.-QOLD2)THEN
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
& X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
if(getnewmass.lt.SQRT(-QOLD2))then
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
endif
ELSE
GETNEWMASS=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
ENDIF
ENDIF
GETNEWMASS=MIN(GETNEWMASS,x*P(L,4))
END
***********************************************************************
*** function getpnorad1
***********************************************************************
DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER LINE
DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT,
&SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd
md1 = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
ms1 = avmom(5)
shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4)
& -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3))
pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2
up = 4.*pcms2
LOW=Q0**2/SCALEFACM**2
IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN
GETPNORAD1=1.d0
RETURN
ENDIF
IF(K(LINE,2).EQ.21)THEN
CCOL=3./2.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'G','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=-1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'GB'))/SIGMATOT
ELSE
CCOL=2./3.
C--probability for no initial state radiation
SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,'Q','C',x,y,z,t,0)
IF(SIGMATOT.EQ.0.d0)THEN
GETPNORAD1=1.d0
RETURN
ENDIF
GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
&SCATPRIMFUNC(0.d0,MD1))
& + GETXSECINT(UP,MD1,'QB'))/SIGMATOT
ENDIF
IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN
write(logfid,*)'error: P_norad=',GETPNORAD1,
& P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1
ENDIF
END
***********************************************************************
*** subroutine getqvec
***********************************************************************
SUBROUTINE GETQVEC(L,J,DT,X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i
DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4),
&T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS,
&savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2,
&avmom(5)
CHARACTER TYPS
DATA PI/3.141592653589793d0/
DATA COUNTMAX/1000/
IF (J.GT.10000)THEN
discard = .true.
return
ENDIF
COUNTER=0
COUNT2=0
XSC=MV(L,1)+DT*P(L,1)/P(L,4)
YSC=MV(L,2)+DT*P(L,2)/P(L,4)
ZSC=MV(L,3)+DT*P(L,3)/P(L,4)
TSC=MV(L,4)+DT
md = GETMD(XSC,YSC,ZSC,TSC)
call AVSCATCEN(xsc,ysc,zsc,tsc,
&avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
do 210 i=1,5
savemom(i) = p(l,i)
210 continue
xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8)
p(l,1) = xi*p(l,1)
p(l,2) = xi*p(l,2)
p(l,3) = xi*p(l,3)
p(l,4) = max(x*p(l,4),p(l,5))
444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
&K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5))
MV(1,1)=XSC
MV(1,2)=YSC
MV(1,3)=ZSC
MV(1,4)=TSC
TYPS='Q'
IF(K(1,2).EQ.21)TYPS='G'
shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4)
& -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3))
pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat)
& -savemom(5)**2
maxt = 4.*pcms2
K(1,1)=13
SCATCENTRES(J,1)=K(1,2)
SCATCENTRES(J,2)=P(1,1)
SCATCENTRES(J,3)=P(1,2)
SCATCENTRES(J,4)=P(1,3)
SCATCENTRES(J,5)=P(1,4)
SCATCENTRES(J,6)=P(1,5)
SCATCENTRES(J,7)=MV(1,1)
SCATCENTRES(J,8)=MV(1,2)
SCATCENTRES(J,9)=MV(1,3)
SCATCENTRES(J,10)=MV(1,4)
C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(L,13)
PHI=PYP(L,15)
CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
C--pick a t from differential scattering cross section
204 T=-GETT(0.d0,MAXT,md)
202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5))
NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3))
PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
IF(DABS(PT2).LT.1.d-10) PT2=0.d0
IF(T.EQ.0.d0) PT2=0.d0
IF(PT2.LT.0.d0)THEN
T=0.d0
GOTO 202
ENDIF
PT=SQRT(PT2)
PHI2=PYR(0)*2*PI
NEWMOM(1)=PT*COS(PHI2)
NEWMOM(2)=PT*SIN(PHI2)
P(1,1)=NEWMOM(1)-P(L,1)
P(1,2)=NEWMOM(2)-P(L,2)
P(1,3)=NEWMOM(3)-P(L,3)
P(1,4)=NEWMOM(4)-P(L,4)
P(1,5)=0.d0
C--transformation to lab
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
ALLQS(J,1)=T
ALLQS(J,2)=P(1,1)
ALLQS(J,3)=P(1,2)
ALLQS(J,4)=P(1,3)
ALLQS(J,5)=P(1,4)
QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(QSUM2.GT.0.d0)THEN
QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2)
QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3)
QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4)
QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5)
QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
IF(COUNTER.GT.COUNTMAX)THEN
write(logfid,*)'GETQVEC unable to find q vector'
ALLQS(J,1)=0.d0
ALLQS(J,2)=0.d0
ALLQS(J,3)=0.d0
ALLQS(J,4)=0.d0
ALLQS(J,5)=0.d0
ELSE
COUNTER=COUNTER+1
GOTO 444
ENDIF
ENDIF
do 211 i=1,5
p(l,i) = savemom(i)
211 continue
END
***********************************************************************
*** subroutine dokinematics
***********************************************************************
SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT,
& TIME,X,Z,QQBAR)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of formation times
COMMON/FTIMEFAC/FTFAC
DOUBLE PRECISION FTFAC
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--discard event flag
COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
LOGICAL DISCARD
INTEGER NDISC,NSTRANGE,NGOOD,errcount
double precision wdisc
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--number of scattering events
COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
&nisfail,nfsfail,nfstry,nttot,ntrej
C--event weight
COMMON/WEIGHT/EVWEIGHT,sumofweights
double precision EVWEIGHT,sumofweights
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold
DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T,
&NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp,
&m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old,
&newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2,
&ys,p3boost,pboost,m42,localt,oldt,precoil,qmass2,pdummy,pproj
double precision m4,z4,getmass,getms,getmd
double precision thetasub,phisub,rapsub
CHARACTER*2 TYP
LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle,
&softrec,splitrec,isrecoil
DATA PI/3.141592653589793d0/
data pdummy/1.d-6/
if (newm.ne.p(l,5)) then
if (p(l,5).lt.0.d0) then
nistry = nistry+evweight
else
nfstry = nfstry+evweight
endif
endif
IF((N+2*(n2-n1+1)).GT.22990)THEN
write(logfid,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
if (k(l,1).eq.2) then
isrecoil = .true.
else
isrecoil = .false.
endif
firsttime = mv(l,5)
redokin = .false.
nttot=nttot+(n2-n1+1)*evweight
newm2=newm
nold=n
nscatcenold=nscatcen
colmaxold=colmax
statold=k(l,1)
204 DELTAM=NEWM2-P(L,5)
DMLEFT=DELTAM
TTOT=0.d0
DO 220 J=N1,N2
TTOT=TTOT+ALLQS(J,1)
220 CONTINUE
LINE=L
DO 222 J=N1,N2
splitrec = .false.
C--projectile type
IF(K(LINE,2).EQ.21)THEN
TYP='GC'
IF(PYR(0).LT.0.5)THEN
DIR=1
ELSE
DIR=-1
ENDIF
ELSE
TYP='QQ'
DIR=0
ENDIF
K(1,1)=6
K(1,2)=SCATCENTRES(J,1)
P(1,1)=SCATCENTRES(J,2)
P(1,2)=SCATCENTRES(J,3)
P(1,3)=SCATCENTRES(J,4)
P(1,4)=SCATCENTRES(J,5)
P(1,5)=SCATCENTRES(J,6)
MV(1,1)=SCATCENTRES(J,7)
MV(1,2)=SCATCENTRES(J,8)
MV(1,3)=SCATCENTRES(J,9)
MV(1,4)=SCATCENTRES(J,10)
T=ALLQS(J,1)
if (t.eq.0.d0) then
rejectt = .true.
else
rejectt = .false.
endif
IF(TTOT.EQ.0.d0)THEN
DM=0.d0
ELSE
if (dmleft.lt.0.d0) then
DM=max(DMLEFT*T/TTOT*1.5d0,dmleft)
else
DM=min(DMLEFT*T/TTOT*1.5d0,dmleft)
endif
ENDIF
TTOT=TTOT-ALLQS(J,1)
C--transform to c.m.s. and rotate such that parton momentum is in z-direction
BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4))
BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4))
BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4))
IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0)
& .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN
reshuffle = .false.
else
reshuffle = .true.
endif
! reshuffle = .false.
205 if (.not.reshuffle) then
BETA(1)=P(1,1)/P(1,4)
BETA(2)=P(1,2)/P(1,4)
BETA(3)=P(1,3)/P(1,4)
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
if (kinmode.eq.0)then
m42 = 0.d0
elseif (kinmode.eq.1)then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
maxt = -2.*p(1,5)*p(line,4) - p(1,5)**2 + m42
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
dm = 0.d0
m42 = p(1,5)**2
endif
m12 = -p(line,5)**2
203 newmass = p(line,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) then
enew = p(line,4)
else
enew = p(line,4)+(t+p(1,5)**2-m42)/(2.*p(1,5))
endif
pl = (t+2.*p(line,4)*enew-m12-m32)/(2.*p(line,3))
pt2 = enew**2-pl**2-m32
if (t.eq.0.d0) pt2 = 0.d0
if (dabs(pt2).lt.1.d-8) pt2 = 0.d0
if (pt2.lt.0.d0) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 203
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 203
else
write(logfid,*)' This should not have happened: pt^2<0!'
write(logfid,*)t,enew,pl,pt2
t = 0.d0
m42 = p(1,5)**2
rejectt = .true.
goto 203
endif
endif
pt = sqrt(pt2)
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=pt*cos(phi2)
p(n,2)=pt*sin(phi2)
p(n,3)=pl
p(n,4)=enew
p(n,5)=sign(sqrt(abs(m32)),newmass)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-sqrt(m42)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass (no rs): ',
& p(n-1,5),p(1,5),p(l,5),sqrt(m42),rejectt
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
else
CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
reshuffle = .false.
goto 205
endif
THETA=PYP(LINE,13)
PHI=PYP(LINE,15)
CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
shat = (p(1,4)+p(line,4))**2
p3old = p(line,3)
maxt = -4.*p(line,3)**2
if (t.lt.maxt) then
t=0.d0
rejectt = .true.
ntrej=ntrej+evweight
endif
theta2 = acos(1.d0+t/(2.*p(line,3)**2))
phi2 = pyr(0)*2.*pi
n=n+2
p(n,1)=p(line,3)*sin(theta2)*cos(phi2)
p(n,2)=p(line,3)*sin(theta2)*sin(phi2)
p(n,3)=p(line,3)*cos(theta2)
p(n,4)=p(line,4)
p(n,5)=p(line,5)
!---------------------------------
P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
if (mass2.lt.0.d0)
& write(logfid,*)'messed up scattering centres mass^2: ',
& mass2,p(1,5)**2
P(N-1,5)=SQRT(mass2)
if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
& write(logfid,*)'messed up scattering centres mass: ',
& p(n-1,5),p(1,5),p(l,5)
call flush(logfid)
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
C--outgoing projectile
K(N,1)=K(LINE,1)
if (isrecoil.and.(newm.gt.p(l,5)).and.(p(n,5).gt.q0)
& .and.(j.eq.n2)) then
k(n,1)=1
endif
K(N,2)=K(LINE,2)
! K(N,3)=L
K(N,3)=LINE
K(N,4)=0
K(N,5)=0
ZA(N)=1.d0
THETAA(N)=-1.d0
if ((k(n,1).eq.2).and.(z.eq.0.d0)) then
zd(n) = -1.d0
else
ZD(N)=Z
endif
QQBARD(N)=QQBAR
C--take care of incoming projectile
IF(K(LINE,1).EQ.1)THEN
K(LINE,1)=12
ELSE
write(*,*)line,k(line,1)
K(LINE,1)=14
call pevrec(2,.false.)
call exit(1)
ENDIF
K(LINE,4)=N-1
K(LINE,5)=N
C--temporary status code, will be overwritten later
K(N-1,1)=3
K(N-1,2)=21
K(N-1,3)=0
K(N-1,4)=0
K(N-1,5)=0
if (reshuffle) then
C--adjust mass and re-shuffle momenta
if (kinmode.eq.0) then
m42 = 0.d0
elseif (kinmode.eq.1) then
m42 = p(1,5)**2
else
if (scalefacm*sqrt(-t).gt.q0) then
m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.gt.0.d0) splitrec = .true.
m42 = m4**2
else
m42 = p(1,5)**2
endif
endif
206 newmass = p(n,5)+dm
if (newmass.lt.0.d0) then
m32 = -NEWMASS**2
else
m32 = NEWMASS**2
endif
if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
if (localt.gt.0.d0) then
m32 = (p(l,5)*localt/oldt)**2
newm2 = sqrt(m32)
endif
endif
if (t.eq.0.d0) m42 = p(1,5)**2
E3new = (shat + m32 - m42)/(2.d0*sqrt(shat))
E4new = (shat - m32 + m42)/(2.d0*sqrt(shat))
p32 = E3new**2 - m32
p42 = E4new**2 - m42
if ((p32.lt.0.d0).or.(p42.lt.0.d0).or.
& (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (m42.eq.0.d0) then
p42 = 1.d-4
else
p42 = 0.d0
endif
E4new = sqrt(p42 + m42)
E3new = sqrt(shat) - E4new
p32 = E4new**2 - m42
m32 = E3new**2 - E4new**2 + m42
if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
if (splitrec) then
m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
& p(1,4),.false.,z4,qqbardec)
if (m4.eq.0.d0) splitrec = .false.
m42 = m4**2
goto 206
endif
if (dm.ne.0.d0) then
dm = 0.d0
goto 206
endif
m42 = p(1,5)**2
E3new = p(n,4)
E4new = p(n-1,4)
p32 = p3old**2
p42 = p3old**2
if (p(n,5).lt.0.d0) then
m32 = -p(n,5)**2
else
m32 = p(n,5)**2
endif
endif
endif
p(n,1) = sqrt(p32)*p(n,1)/p3old
p(n,2) = sqrt(p32)*p(n,2)/p3old
p(n,3) = sqrt(p32)*p(n,3)/p3old
p(n,4) = E3new
p(n,5) = sign(sqrt(abs(m32)),newmass)
tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2-m32
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up projectiles mass (rs):',
& tmp,m32,p(n,5),dm,m42,p32
!---------------------------------
p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old
p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old
p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old
p(n-1,4) = E4new
p(n-1,5) = sqrt(m42)
tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
& -p(n-1,5)**2
if (abs(tmp).gt.1.d-6)
& write(logfid,*) 'Oups, messed up scattering centres mass (rs):',
& tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or.
& (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or.
& (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) then
write(logfid,*) 'Oups, momentum not conserved (rs)',
& p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3)
write(logfid,*) m42,dm,E3new,E4new
endif
!---------------------------------
! P(N-1,1)=P(1,1)
! P(N-1,2)=P(1,2)
! P(N-1,3)=P(1,3)
! P(N-1,4)=P(1,4)
! P(N-1,5)=P(1,5)
!---------------------------------
endif
! write(*,*)((p(n-1,4)-p(1,4))**2-(p(n-1,1)-p(1,1))**2
! & -(p(n-1,2)-p(1,2))**2-(p(n-1,3)-p(1,3))**2)/t
C--transformation to lab
CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
if (.not.allhad) then
k(n-1,1)=13
softrec=.false.
else
C--boost to fluid rest frame
ys = 0.5*log((mv(1,4)+mv(1,3))/(mv(1,4)-mv(1,3)))
p3boost = sinh(-ys)*p(n-1,4) + cosh(-ys)*p(n-1,3)
pboost = sqrt(p3boost**2+p(n-1,1)**2+p(n-1,2)**2)
localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
if (pboost.lt.(recsoftcut*3.*localt)) then
softrec = .true.
k(n-1,1)=13
else
softrec = .false.
if (scatrecoil.and.(pboost.GT.(rechardcut*3.*localt))) THEN
K(N-1,1)=2
else
K(N-1,1)=3
ENDIF
endif
endif
if (rejectt) k(n-1,1)=11
C--outgoing projectile
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF(K(N,2).EQ.21)THEN
IF(DIR.EQ.1)THEN
TRIP(N)=COLMAX+1
ANTI(N)=ANTI(LINE)
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=COLMAX+1
ENDIF
ELSEIF(K(N,2).GT.0)THEN
TRIP(N)=COLMAX+1
ANTI(N)=0
ELSE
TRIP(N)=0
ANTI(N)=COLMAX+1
ENDIF
COLMAX=COLMAX+1
ELSE
TRIP(N)=TRIP(LINE)
ANTI(N)=ANTI(LINE)
ENDIF
C--outgoing scattering centre
IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN
TRIP(N-1)=TRIP(LINE)
ANTI(N-1)=TRIP(N)
ELSE
TRIP(N-1)=ANTI(N)
ANTI(N-1)=ANTI(LINE)
ENDIF
ELSE
TRIP(N-1)=0
ANTI(N-1)=0
ENDIF
C--outgoing scattering centre
if (splitrec) then
if (k(n-1,1).eq.2) k(n-1,1)=1
ZA(N-1)=1.d0
THETAA(N-1)=P(n-1,5)/(SQRT(Z4*(1.-Z4))*P(n-1,4))
ZD(N-1)=z4
QQBARD(N-1)=qqbardec
else
ZA(N-1)=1.d0
THETAA(N-1)=-1.d0
ZD(N-1)=-1.d0
QQBARD(N-1)=.false.
endif
MV(N,4)=MV(1,4)
MV(N-1,4)=MV(1,4)
C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
MV(N-1,1)=MV(line,1)
& +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N-1,2)=MV(line,2)
& +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N-1,3)=MV(line,3)
& +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
MV(N, 1)=MV(line,1)
& +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
MV(N, 2)=MV(line,2)
& +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
MV(N, 3)=MV(line,3)
& +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
IF(P(N-1,5).GT.P(1,5))THEN
LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2)
MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
MV(N-1,5)=0.d0
ENDIF
IF(J.LT.N2)THEN
MV(N,5)=SCATCENTRES(J+1,10)
ELSE
IF(P(N,5).GT.0.d0)THEN
IF(DELTAM.EQ.0.d0)THEN
ENDTIME=firsttime
ELSE
IF(X.LT.1.d0)THEN
LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA
ELSE
ENDTIME=TIME
ENDIF
ENDIF
MV(N,5)=ENDTIME
ELSE
MV(N,5)=0.d0
ENDIF
ENDIF
MV(LINE,5)=ALLQS(J,6)
if ((.not.redokin).and.(.not.rejectt)) NSCAT=NSCAT+EVWEIGHT
C--store scattering centre before interaction in separate common block
if (writescatcen.and.(.not.rejectt).and.
& (nscatcen.lt.maxnscatcen)) then
nscatcen = nscatcen+1
if (nscatcen.gt.maxnscatcen) then
write(logfid,*)
&'WARNING: no room left to store further scattering centres'
goto 230
endif
if (recmode.eq.0) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.1) then
if (.not.softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
! precoil = sqrt(p(n-1,1)**2+p(n-1,2)**2+p(n-1,3)**2)
! dummies(nscatcen,1) = pdummy*p(n-1,1)/precoil
! dummies(nscatcen,2) = pdummy*p(n-1,2)/precoil
! dummies(nscatcen,3) = pdummy*p(n-1,3)/precoil
! dummies(nscatcen,4) = pdummy
C--------------------
c phisub = pyp(n-1,15)
c rapsub = pyp(n-1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = p(n-1,1)*pdummy/p(n-1,4)
dummies(nscatcen,2) = p(n-1,2)*pdummy/p(n-1,4)
dummies(nscatcen,3) = p(n-1,3)*pdummy/p(n-1,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
elseif (recmode.eq.2) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil = sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
elseif (recmode.eq.3) then
if (softrec) then
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
& - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
! precoil=sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
! & +scatcen(nscatcen,3)**2)
! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
! dummies(nscatcen,4) = pdummy
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
& dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
& dummies(nscatcen,4)**2)
if (scatcen(nscatcen,4).lt.0.d0) then
dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
endif
else
scatflav(nscatcen) = k(1,2)
scatcen(nscatcen,1) = p(1,1)
scatcen(nscatcen,2) = p(1,2)
scatcen(nscatcen,3) = p(1,3)
scatcen(nscatcen,4) = p(1,4)
scatcen(nscatcen,5) = p(1,5)
C--------------------
c phisub = pyp(1,15)
c rapsub = pyp(1,17)
c thetasub = 2.*atan(exp(-rapsub))
c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
c dummies(nscatcen,3) = pdummy*cos(thetasub)
c dummies(nscatcen,4) = pdummy
c dummies(nscatcen,5) = 0.d0
C--------------------
dummies(nscatcen,1) = scatcen(nscatcen,1)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,2) = scatcen(nscatcen,2)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,3) = scatcen(nscatcen,3)*
& pdummy/scatcen(nscatcen,4)
dummies(nscatcen,4) = pdummy
dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
& dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
& dummies(nscatcen,3)**2)
C--------------------
endif
endif
endif
230 continue
! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then
! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5)
! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5)
! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5)
! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
! write(*,*)t
! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
! write(*,*)
! endif
DMLEFT=DMLEFT-(p(n,5)-P(LINE,5))
LINE=N
tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2
if (abs(tmp).ge.1.d-6)
& write(logfid,*)'dokinematics 4-momentum test failed:',
& tmp,j,p(l,5),p(line,5),p(n,5),reshuffle
222 CONTINUE
if (p(n,5).lt.0.d0) then
nisfail = nisfail+evweight
RETRYSPLIT=.TRUE.
return
endif
if (p(n,5).ne.newm2) then
RETRYSPLIT=.TRUE.
redokin = .true.
nfsfail = nfsfail+evweight
n=nold
colmax=colmaxold
nscatcen=nscatcenold
k(l,1)=statold
if (p(l,5).lt.0.d0) then
newm2 = 0.d0
else
if ((p(l,5).lt.q0).and.(k(l,1).ne.14)) then
if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then
newm2=q0+1.d-6
else
newm2=0.d0
! nisfail = nisfail+evweight
! RETRYSPLIT=.TRUE.
! write(*,*)'dokinematics takes the dubious exit'
! return
endif
else
newm2=p(l,5)
if (k(l,1).eq.14) z = 0.d0
endif
n2=n1
endif
goto 204
endif
if ((k(n,1).eq.1).and.
& ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))))
&write(logfid,*)'dokinematics did not reach sensible mass: ',l,
&p(n,5),newm,p(l,5),newm2
NSCATEFF=NSCATEFF+EVWEIGHT
END
***********************************************************************
*** function getproba
***********************************************************************
DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE,
& T1,INS2)
IMPLICIT NONE
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1
CHARACTER*2 TYPE
LOGICAL INS2
QA=QAA
ZA2=ZAA
EB=EBB
TYP=TYPE
T=T1
INSTATE=INS2
GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2)
& *DERIV(QF,1)
END
***********************************************************************
*** function getsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
& TYPE3,T2,INS)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI,
&HFIRST,T2,GETINSUDAFAST,QB2
CHARACTER*2 TYPE3
LOGICAL INS
DATA EPSI/1.d-4/
QB2=QB1
IF(INS)THEN
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ELSE
IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1
IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
ENDIF
IF(QB2.GE.(QMAX1-1.d-10)) THEN
GETSUDAKOV=1.d0
ELSE
IF(INS)THEN
GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3)
ELSE
QA=QA1
ZA2=ZA1
EB=EB1
TYP=TYPE3
T=T2
INSTATE=.FALSE.
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1)
GETSUDAKOV=EXP(-YSTART)
ENDIF
ENDIF
END
***********************************************************************
*** function getinsudakov
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--local variables
DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI,
&HFIRST
CHARACTER*2 TYPE3
DATA EPSI/1.d-4/
QB1=QB
IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1
IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12
IF(QB1.GE.(QMAX1-1.d-12)) THEN
GETINSUDAKOV=1.d0
ELSE
TYP=TYPE3
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6)
GETINSUDAKOV=EXP(-YSTART)
ENDIF
END
***********************************************************************
*** function deriv
***********************************************************************
DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--variables for Sudakov integration
COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
DOUBLE PRECISION QA,ZA2,EB,T
CHARACTER*2 TYP
LOGICAL INSTATE
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
INTEGER W4
DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI,
&GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ,
&MEDDERIV
DATA PI/3.141592653589793d0/
IF(W4.EQ.1)THEN
C--Sudakov integration
IF(INSTATE)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSE
DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL
ENDIF
ELSEIF(W4.EQ.2)THEN
C--P(q->qg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)*
& PQQ(XVAL)/(2.*PI)
ELSEIF(W4.EQ.3)THEN
C--P(g->gg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)
& *PGG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.4)THEN
C--P(g->qq) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)*
& PQG(XVAL)/(2.*PI)
ELSEIF(W4.EQ.5)THEN
DERIV=EXP(-XVAL)/XVAL
ELSEIF(W4.EQ.6)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
ELSEIF(W4.EQ.7)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.8)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PGQ(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.9)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
& *PQG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.10)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2/1.,LPS)*
& *2.*PGG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.11)THEN
DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ')
& *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL)
ELSEIF(W4.EQ.12)THEN
DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG')
& *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL)
ELSEIF(W4.EQ.13)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC')
& *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.14)THEN
DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ')
& *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2)
ELSEIF(W4.EQ.21)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ')
& /XVAL
ELSEIF(W4.EQ.22)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ')
& /XVAL
ELSEIF(W4.EQ.23)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG')
& /XVAL
ELSEIF(W4.EQ.24)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2.
& *GETINSPLITI(XVAL,'GG')/XVAL
ELSE
DERIV=MEDDERIV(XVAL,W4-100)
ENDIF
END
***********************************************************************
*** function getspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE
DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y,
&SPLITINTGG,SPLITINTQG,A,B,YB(2)
CHARACTER*2 TYPE1
ntotspliti=ntotspliti+1
if (qb.gt.qmax) then
noverspliti=noverspliti+1
if (noverspliti.le.25)
& write(logfid,*)'WARNING in getspliti: need to extrapolate: ',
& qb,qmax
endif
C--find boundaries for z integration
IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)))
ELSE
LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2)
& *SQRT(1.-QB**2/EB**2)
ENDIF
C--find values in array
QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1)
QLINE=MAX(QLMAX,1)
QLINE=MIN(QLINE,NPOINT)
ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/
& (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1)
ZLINE=MAX(ZLMAX,1)
ZLINE=MIN(ZLINE,NPOINT)
IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR.
& (QLINE.LT.1).OR.(ZLINE.LT.1))THEN
write(logfid,*)'ERROR in GETSPLITI: line number out of bound',
& QLINE,ZLINE
ENDIF
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 17 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 16 J=1,2
YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
16 CONTINUE
17 CONTINUE
DO 30 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
30 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=MIN(Y,10.d0)
ELSE
SPLITINTGG=MIN(Y,10.d0)
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
DO 19 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 18 J=1,2
YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
18 CONTINUE
19 CONTINUE
DO 31 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
31 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=NF*MIN(Y,10.d0)
ELSE
SPLITINTQG=NF*MIN(Y,10.d0)
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
DO 21 I=1,2
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 20 J=1,2
YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
20 CONTINUE
21 CONTINUE
DO 32 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*LOW+B
32 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=(YB(1)+YB(2))/2.
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*QB+B
ENDIF
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getinspliti
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
UP = 1. - Q0**2/(4.*QB**2)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - LOG(LOG((1.-UP)*QB**2/LPS**2))
& + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + LOW - LOG(LOW) - UP + LOG(UP) )
& *3.*12.*PI/(2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'GG')THEN
GETINSPLITI=Y
ELSE
SPLITINTGG=Y
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
& - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
& + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
& - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 )
& *12.*PI/(2.*2.*PI*(33.-2.*NF))
IF(TYPE1.EQ.'QG')THEN
GETINSPLITI=NF*Y
ELSE
SPLITINTQG=NF*Y
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
LOW=0.d0
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
& - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
& + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
& - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
& + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
& - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GQ')THEN
LOW=1.d0-UP
IF (UP.LE.LOW) THEN
GETINSPLITI=0.d0
RETURN
ENDIF
Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW))
& *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
END
***********************************************************************
*** function getpdf
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN
write(logfid,*)'error in GETPDF: parameter out of bound',X,Q
GETPDF=0.d0
RETURN
ENDIF
IF(TYP.EQ.'QQ')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GQ')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'QG')THEN
Z=X
XMAX=Q
C--f_q^g
QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9)
ENDIF
GETPDF=YSTART
ELSEIF(TYP.EQ.'GG')THEN
Z=X
XMAX=Q
C--f_q^q
QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
QHIGH=Q
IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
& .OR.(X.GT.1.d0-1d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(QHIGH-QLOW)
YSTART=0.d0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10)
ENDIF
GETPDF=YSTART
ELSE
write(logfid,*)'error: pdf-type ',TYP,' does not exist'
GETPDF=0.d0
ENDIF
END
***********************************************************************
*** function getpdfxint
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER J,Q2CLOSE,Q2LINE
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP
ntotpdf=ntotpdf+1
if (q**2.gt.QINQX(1,1000)) then
noverpdf=noverpdf+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ',
& q**2,QINQX(1,1000)
endif
Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/
& (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1)
Q2LINE=MAX(Q2CLOSE,1)
Q2LINE=MIN(Q2LINE,999)
IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN
write(logfid,*)'ERROR in GETPDFXINT: line number out of bound',
& Q2LINE
ENDIF
IF(TYP.EQ.'QQ')THEN
DO 11 J=1,2
XA(J)=QINQX(1,Q2LINE-1+J)
YA(J)=QINQX(2,Q2LINE-1+J)
11 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
DO 13 J=1,2
XA(J)=GINQX(1,Q2LINE-1+J)
YA(J)=GINQX(2,Q2LINE-1+J)
13 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
DO 15 J=1,2
XA(J)=QINGX(1,Q2LINE-1+J)
YA(J)=QINGX(2,Q2LINE-1+J)
15 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
DO 17 J=1,2
XA(J)=GINGX(1,Q2LINE-1+J)
YA(J)=GINGX(2,Q2LINE-1+J)
17 CONTINUE
ELSE
write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q**2+B
GETPDFXINT=Y
END
***********************************************************************
*** subroutine getpdfxintexact
***********************************************************************
DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
DOUBLE PRECISION Q,EPSI,YSTART,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
HFIRST=0.01d0
YSTART=0.d0
XMAX=Q
Z=0.d0
IF(TYP.EQ.'QQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21)
ELSEIF(TYP.EQ.'QG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23)
ELSEIF(TYP.EQ.'GQ')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22)
ELSEIF(TYP.EQ.'GG')THEN
CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24)
ENDIF
GETPDFXINTEXACT=YSTART
END
***********************************************************************
*** function getxsecint
***********************************************************************
DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J
DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B
CHARACTER*2 TYP2
ntotxsec=ntotxsec+1
if (tm.gt.intq1(1000,101)) then
noverxsec=noverxsec+1
if (noverpdf.le.25)
& write(logfid,*)'WARNING in getxsecint: need to extrapolate: ',
& tm,intq1(1000,101)
endif
TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/
& (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1)
TLINE=MAX(TCLOSE,1)
TLINE=MIN(TLINE,999)
MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/
&(INTQ1(1001,100)-INTQ1(1001,1))+1)
MDLINE=MAX(MDCLOSE,1)
MDLINE=MIN(MDLINE,99)
IF((TLINE.GT.999).OR.(MDLINE.GT.99)
& .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN
write(logfid,*)'ERROR in GETXSECINT: line number out of bound',
& TLINE,MDLINE
ENDIF
IF(TYP2.EQ.'QA')THEN
C--first quark integral
DO 12 I=1,2
X1A(I)=INTQ1(1001,MDLINE-1+I)
X2A(I)=INTQ1(TLINE-1+I,101)
DO 11 J=1,2
YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP2.EQ.'QB')THEN
C--second quark integral
DO 18 I=1,2
X1A(I)=INTQ2(1001,MDLINE-1+I)
X2A(I)=INTQ2(TLINE-1+I,101)
DO 17 J=1,2
YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I)
17 CONTINUE
18 CONTINUE
ELSEIF(TYP2.EQ.'GA')THEN
C--first gluon integral
DO 14 I=1,2
X1A(I)=INTG1(1001,MDLINE-1+I)
X2A(I)=INTG1(TLINE-1+I,101)
DO 13 J=1,2
YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP2.EQ.'GB')THEN
C--second gluon integral
DO 16 I=1,2
X1A(I)=INTG2(1001,MDLINE-1+I)
X2A(I)=INTG2(TLINE-1+I,101)
DO 15 J=1,2
YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I)
15 CONTINUE
16 CONTINUE
ELSE
write(logfid,*)'error in GETXSECINT: unknown integral type ',
& TYP2
ENDIF
DO 19 I=1,2
A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
B=YA(I,1)-A*X2A(1)
YB(I)=A*TM+B
19 CONTINUE
IF(X1A(1).EQ.X1A(2))THEN
Y=YB(1)
ELSE
A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
B=YB(1)-A*X1A(1)
Y=A*MD+B
ENDIF
GETXSECINT=Y
END
***********************************************************************
*** function getinsudafast
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Q1,Q2,GETINSUDARED
CHARACTER*2 TYP
IF(Q2.LE.Q1)THEN
GETINSUDAFAST=1.d0
ELSEIF(Q1.LE.Q0)THEN
GETINSUDAFAST=GETINSUDARED(Q2,TYP)
ELSE
GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP)
ENDIF
IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0
IF(GETINSUDAFAST.LT.(-1.d-10))THEN
write(logfid,*)'ERROR: GETINSUDAFAST < 0:',
& GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP
ENDIF
if (getinsudafast.lt.0.d0) getinsudafast = 0.d0
END
***********************************************************************
*** function getinsudared
***********************************************************************
DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--number of extrapolations in tables
common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
integer ntotspliti,noverspliti,ntotpdf,noverpdf,
&ntotxsec,noverxsec,ntotsuda,noversuda
C--local variables
INTEGER QCLOSE,QBIN,I
DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
CHARACTER*2 TYP2
ntotsuda=ntotsuda+1
if (q.gt.sudaqq(1000,1)) then
noversuda=noversuda+1
if (noversuda.le.25)
& write(logfid,*)'WARNING in getinsudared: need to extrapolate: ',
& q,sudaqq(1000,1)
endif
QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0
& /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1)
QBIN=MAX(QCLOSE,1)
QBIN=MIN(QBIN,999)
IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN
write(logfid,*)
& 'ERROR in GETINSUDARED: line number out of bound',QBIN
ENDIF
IF(TYP2.EQ.'QQ')THEN
DO 16 I=1,2
XA(I)=SUDAQQ(QBIN-1+I,1)
YA(I)=SUDAQQ(QBIN-1+I,2)
16 CONTINUE
ELSEIF(TYP2.EQ.'QG')THEN
DO 17 I=1,2
XA(I)=SUDAQG(QBIN-1+I,1)
YA(I)=SUDAQG(QBIN-1+I,2)
17 CONTINUE
ELSEIF(TYP2.EQ.'GG')THEN
DO 18 I=1,2
XA(I)=SUDAGG(QBIN-1+I,1)
YA(I)=SUDAGG(QBIN-1+I,2)
18 CONTINUE
ELSEIF(TYP2.EQ.'GC')THEN
DO 19 I=1,2
XA(I)=SUDAGC(QBIN-1+I,1)
YA(I)=SUDAGC(QBIN-1+I,2)
19 CONTINUE
ELSE
write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2
ENDIF
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*Q+B
GETINSUDARED=Y
IF(GETINSUDARED.LT.(-1.d-10))THEN
write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2
ENDIF
if (getinsudared.lt.0.d0) getinsudared = 0.d0
END
***********************************************************************
*** function getsscat
***********************************************************************
DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2,
& x,y,z,t,mode)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--local variables
integer mode
DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP,
&LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp,
&x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct
CHARACTER TYPE1,TYPE2
IF(TYPE1.EQ.'Q')THEN
CCOL=2./3.
ELSE
CCOL=3./2.
ENDIF
if (mode.eq.0) then
mdeb = getmd(x,y,z,t)
call avscatcen(x,y,z,t,
& avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 + mp**2 +
& 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
else
if (mode.eq.1) then
mdeb = getmdmin()
else
mdeb = getmdmax()
endif
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)
pproj = sqrt(px**2+py**2+pz**2)
shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct)
pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
up = 4.*pcms2
endif
LOW=LW**2
IF(LOW.GT.UP)THEN
GETSSCAT=0.d0
RETURN
ENDIF
IF((TYPE2.EQ.'C').OR.
& ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR.
& ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN
GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB))
! write(logfid,*)'getsscat 1',GETSSCAT
ELSE
GETSSCAT=0.d0
ENDIF
LOW=Q0**2/SCALEFACM**2
IF(UP.GT.LOW)THEN
IF(TYPE1.EQ.'Q')THEN
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ')
& *3.*SCATPRIMFUNC(UP,MDEB)/2.
GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA')
ENDIF
ELSE
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
& SCATPRIMFUNC(LOW,MDEB))
& - GETXSECINT(UP,MDEB,'GB')
! write(*,*)'getsscat 2',GETSSCAT,CCOL*(SCATPRIMFUNC(UP,MDEB)-
! & SCATPRIMFUNC(LOW,MDEB)),-GETXSECINT(UP,MDEB,'GB')
ENDIF
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG')
& *2.*SCATPRIMFUNC(UP,MDEB)/3.
GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA')
! write(*,*)'getsscat 3',getsscat,-2.*GETXSECINT(UP,MDEB,'GA')
ENDIF
ENDIF
ENDIF
IF(GETSSCAT.LT.-1.d-4) then
write(logfid,*) 'error: cross section < 0',GETSSCAT,'for',
& EN,mp,LW,TYPE1,TYPE2,LW**2,UP,mode
endif
GETSSCAT=MAX(GETSSCAT,0.d0)
END
***********************************************************************
*** function getmass
***********************************************************************
DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE,
& MAX2,INS,ZDEC,QQBARDEC)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
INTEGER MSTU,MSTJ
DOUBLE PRECISION PARU,PARJ
COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
INTEGER MDCY,MDME,KFDP
DOUBLE PRECISION BRAT
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--factor in front of alphas argument
COMMON/ALPHASFAC/PTFAC
DOUBLE PRECISION PTFAC
C--local variables
DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec,
&q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin,
&gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti,
&r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin
CHARACTER*2 TYPE
LOGICAL INS,QQBARDEC
DATA PI/3.141592653589793d0/
q2min = q0**2
alphmax = alphas(3.*ptfac*q2min/16.,lps)
log14 = log(0.25)
IF(TYPE.EQ.'QQ')THEN
pref=4.*alphmax/(3.*2.*PI)
ELSE
pref=29.*alphmax/(8.*2.*PI)
ENDIF
C--check if phase space available, return 0.d0 otherwise
IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
ENDIF
q2max = qbmax**2
! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2))
! IF(pyr(0).LE.sudaover)THEN
21 if (q2max-qbmin**2.lt.1e-4)then
getmass=qbmin
zdec=0.5
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
endif
return
endif
gmax = pref*log(q2min/(4.*q2max))**2
if (qbmin.gt.0.d0) then
rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax)
else
rmin = 0.d0
endif
r=pyr(0)*(1.d0-rmin)+rmin
arg=gmax+log(r)
if(arg.lt.0.d0)then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
! r=pyr(0)
! gmin = pref*log14**2
! gmax = pref*log(q2min/(4.*q2max))**2
! arg = log(r*exp(gmax)+(1.-r)*exp(gmin))
cand = q2min*exp(sqrt(arg/pref))/4.
eps = q2min/(4.*cand)
if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then
getmass=0.d0
ZDEC=0.d0
QQBARDEC=.FALSE.
RETURN
endif
IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN
q2max=cand
goto 21
ENDIF
if (ins) then
trueval=getinspliti(sqrt(cand),type)
oest = -2.*pref*log(eps)
weight = trueval/oest
else
C--find true z interval
TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand)
& *SQRT(1.-cand/EP**2)
IF(TRUEEPS.LT.EPS)
& WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS
RZ=PYR(0)
z = 1.-eps**rz
if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then
weight = 0.
else
if (type.eq.'QQ')then
! if (ins) then
! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
! endif
oest = 2.*pref/(1.-z)
weight = trueval/oest
else
if (pyr(0).lt.(17./29.)) z = 1.-z
! if (ins)then
! trueval = alphas(ptfac*(1.-z)*cand,lps)
! & *(pgg(z)+pqg(z))/(2.*pi)
! else
trueval = alphas(ptfac*z*(1.-z)*cand,lps)
& *(pgg(z)+pqg(z))/(2.*pi)
! endif
oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi)
weight = trueval/oest
endif
thetanew = sqrt(cand/(z*(1.-z)))/ep
if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta))
& weight = 0.d0
endif
endif
IF (WEIGHT.GT.1.d0) WRITE(logfid,*)
& 'problem in getmass: weight> 1',
& WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND
R2=PYR(0)
IF(R2.GT.WEIGHT)THEN
q2max=cand
GOTO 21
ELSE
getmass=sqrt(cand)
if (.not.ins) then
ZDEC=Z
IF(TYPE.EQ.'QQ')THEN
QQBARDEC=.FALSE.
ELSE
IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN
QQBARDEC=.TRUE.
ELSE
QQBARDEC=.FALSE.
ENDIF
ENDIF
endif
ENDIF
END
***********************************************************************
*** function generatez
***********************************************************************
DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
CHARACTER*2 TYPE
IF(TI.EQ.0.d0)THEN
EPS=EPSI
ELSE
EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
& *SQRT(1.-TI/EA**2),EPSI)
ENDIF
IF(EPS.GT.0.5)THEN
GENERATEZ=0.5
GOTO 61
ENDIF
60 R=PYR(0)
IF(TYPE.EQ.'QQ')THEN
X=1.-(1.-EPS)*(EPS/(1.-EPS))**R
R=PYR(0)
IF(R.LT.((1.+X**2)/2.))THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSEIF(TYPE.EQ.'GG')THEN
X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R))
R=PYR(0)
HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X)
IF(R.LT.HELP)THEN
GENERATEZ=X
ELSE
GOTO 60
ENDIF
ELSE
R=PYR(0)*(1.-2.*EPS)+EPS
R1=PYR(0)/2.
HELP=0.5*(R**2+(1.-R)**2)
IF(R1.LT.HELP)THEN
GENERATEZ=R
ELSE
GOTO 60
ENDIF
ENDIF
61 END
***********************************************************************
*** function scatprimfunc
***********************************************************************
DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
DATA PI/3.141592653589793d0/
SCATPRIMFUNC = 2.*PI*(12.*PI)**2*(
& - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2
& - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2
END
***********************************************************************
*** function intpqq
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2)
& +LOG(1.-Z)))/((33.-2.*NF)*3.)
END
***********************************************************************
*** function intpgglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpgghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q
INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
END
***********************************************************************
*** function intpqglow
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function intpqghigh
***********************************************************************
DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION Z,Q,EI
INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2
& - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4
& + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/
&((33.-2.*NF)*2.)
END
***********************************************************************
*** function gett
***********************************************************************
DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
&MDEB,MINT,T
DATA PI/3.141592653589793d0/
TMAX=MAXT+MDEB**2
TMIN=MINT+MDEB**2
IF(TMIN.GT.TMAX) THEN
GETT=0.d0
RETURN
ENDIF
20 R1=PYR(0)
T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX))
R2=PYR(0)
IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN
GETT=T-MDEB**2
ELSE
GOTO 20
ENDIF
! 20 R1 = pyr(0);
! R2 = pyr(0);
! t = abs(mdeb**2*sqrt(-2.*log(R1))*cos(2.*pi*R2))
! if (t.gt.maxt) goto 20
! gett=t
! return
END
***********************************************************************
*** function ei
***********************************************************************
DOUBLE PRECISION FUNCTION EI(X)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C--local variables
INTEGER K,LINE,LMAX
DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B
DOUBLE PRECISION YSTART,EPSI,HFIRST
DATA EPSI/1.e-5/
IF(DABS(X).GT.VALMAX)
& write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX
IF(X.GE.0.d0)THEN
LMAX=INT(X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 26 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(3,LINE-1+K)
26 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=A*X+B
ELSE
LMAX=INT(-X*NVAL/VALMAX)
LINE=MAX(LMAX,1)
LINE=MIN(LINE,999)
IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
write(logfid,*)'ERROR in EI: line number out of bound',LINE
ENDIF
DO 27 K=1,2
XA(K)=EIXS(1,LINE-1+K)
YA(K)=EIXS(2,LINE-1+K)
27 CONTINUE
A=(YA(2)-YA(1))/(XA(2)-XA(1))
B=YA(1)-A*XA(1)
Y=-A*X+B
ENDIF
EI=Y
END
***********************************************************************
*** function pqq
***********************************************************************
DOUBLE PRECISION FUNCTION PQQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
END
***********************************************************************
*** function pgq
***********************************************************************
DOUBLE PRECISION FUNCTION PGQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
END
***********************************************************************
*** function pgg
***********************************************************************
DOUBLE PRECISION FUNCTION PGG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
END
***********************************************************************
*** function pqg
***********************************************************************
DOUBLE PRECISION FUNCTION PQG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQG=0.5*(Z**2 + (1.-Z)**2)
END
***********************************************************************
*** function alphas
***********************************************************************
DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--local variables
DOUBLE PRECISION T,L0,PI,LAMBDA
DATA PI/3.141592653589793d0/
ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
END
***********************************************************************
*** subroutine splitfncint
***********************************************************************
SUBROUTINE SPLITFNCINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER NSTEP,I,J
DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
&LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2
DATA ZMMAX/0.5/
DATA NSTEP/999/
DATA EPSI/1.d-5/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
ZMMIN=Q0/EMAX
LNZMMIN=LOG(ZMMIN)
LNZMMAX=LOG(ZMMAX)
NPOINT=NSTEP
DO 100 I=1,NSTEP+1
Q=(I-1)*(QMAX-Q0)/NSTEP+Q0
QVAL(I)=Q
QQUAD=Q**2
DO 110 J=1,NSTEP+1
ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
ZMVAL(J)=ZM
IF(Q**2.LT.Q0**2)THEN
ZM2=0.5
ELSE
ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2)
ENDIF
ZM=MAX(ZM,ZM2)
IF(ZM.EQ.0.5)THEN
SPLITIQQV(I,J)=0.d0
SPLITIGGV(I,J)=0.d0
SPLITIQGV(I,J)=0.d0
ELSE
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2)
SPLITIQQV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3)
SPLITIGGV(I,J)=YSTART
YSTART=0d0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4)
SPLITIQGV(I,J)=YSTART
ENDIF
110 CONTINUE
100 CONTINUE
END
***********************************************************************
*** subroutine pdfint
***********************************************************************
SUBROUTINE PDFINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--pdf common block
COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
&GINGX(2,1000)
DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I,J
DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI,
&Q2MAX,DELTAQ2,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
q2max = scalefacm*4.*pcms2
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
QINQX(1,1)=Q0**2
GINQX(1,1)=Q0**2
QINGX(1,1)=Q0**2
GINGX(1,1)=Q0**2
QINQX(2,1)=0.d0
GINQX(2,1)=0.d0
QINGX(2,1)=0.d0
GINGX(2,1)=0.d0
DO 12 J=2,1000
Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2))
QINQX(1,J)=Q2
GINQX(1,J)=Q2
QINGX(1,J)=Q2
GINGX(1,J)=Q2
QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ')
GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ')
QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG')
GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG')
12 CONTINUE
END
***********************************************************************
*** subroutine xsecint
***********************************************************************
SUBROUTINE XSECINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--cross secttion common block
COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
&INTG1(1001,101),INTG2(1001,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW,MDX
DOUBLE PRECISION QLOW,MDX
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER J,K
DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI,
&GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2
DATA EPSI/1.d-4/
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
tmaxmax = scalefacm*4.*pcms2
DELTATMAX=(LOG(TMAXMAX)-
& LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0
MDMIN=GETMDMIN()
MDMAX=MAX(MDMIN,GETMDMAX())
DELTAMD=(MDMAX-MDMIN)/99.d0
DO 12 J=1,1000
TMAX = EXP((J-1)*DELTATMAX
& + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))
INTQ1(J,101)=TMAX
INTQ2(J,101)=TMAX
INTG1(J,101)=TMAX
INTG2(J,101)=TMAX
DO 13 K=1,100
MDX=MDMIN+(K-1)*DELTAMD
INTQ1(1001,K)=MDX
INTQ2(1001,K)=MDX
INTG1(1001,K)=MDX
INTG2(1001,K)=MDX
IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN
INTQ1(J,K)=0.d0
INTQ2(J,K)=0.d0
INTG1(J,K)=0.d0
INTG2(J,K)=0.d0
ELSE
C--first quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,11)
INTQ1(J,K)=YSTART
C--second quark integral
QLOW=Q0
HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,14)
INTQ2(J,K)=YSTART
C--first gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,12)
INTG1(J,K)=YSTART
C--second gluon integral
QLOW=Q0
YSTART=0.d0
CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
& ,0.d0,13)
INTG2(J,K)=YSTART
ENDIF
13 CONTINUE
12 CONTINUE
END
***********************************************************************
*** function insudaint
***********************************************************************
SUBROUTINE INSUDAINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
&SUDAGC(1000,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--max rapidity
common/rapmax/etamax
double precision etamax
C--local variables
INTEGER I
DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5),
&shat,pcms2
call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
shat = avmom(5)**2 +
& 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
qmax = sqrt(scalefacm*4.*pcms2)
DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0
DO 22 I=1,1000
Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6)))
SUDAQQ(I,1)=Q
SUDAQG(I,1)=Q
SUDAGG(I,1)=Q
SUDAGC(I,1)=Q
SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ')
SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG')
SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG')
SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC')
22 CONTINUE
END
***********************************************************************
*** function eixint
***********************************************************************
SUBROUTINE EIXINT
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIXS,VALMAX
C-local variables
INTEGER I,K
DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R
DATA EPSI/1.d-6/
NVAL=1000
VALMAX=55.
DO 10 I=1,NVAL
X=I*VALMAX/(NVAL*1.d0)
EIXS(1,I)=X
C--do negative arguments first
YSTART=0d0
HFIRST=0.01
CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5)
EIXS(2,I)=-YSTART
C--now do the positive arguments
IF (X.EQ.0.0) THEN
EI=-1.0D+300
ELSE IF (X.LE.40.0) THEN
EI=1.0D0
R=1.0D0
DO 15 K=1,100
R=R*K*X/(K+1.0D0)**2
EI=EI+R
IF (DABS(R/EI).LE.1.0D-15) GO TO 20
15 CONTINUE
20 GA=0.5772156649015328D0
EI=GA+DLOG(X)+X*EI
ELSE
EI=1.0D0
R=1.0D0
DO 25 K=1,20
R=R*K/X
EI=EI+R
25 continue
EI=DEXP(X)/X*EI
ENDIF
EIXS(3,I)=EI
10 CONTINUE
END
***********************************************************************
*** function odeint
***********************************************************************
subroutine odeint(ystart,a,b,eps,h1,hmin,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer nmax,nstep,w1
double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx,
&deriv,yscale,hdid,hnew
data nmax/100000/
x = a
y = ystart
h = sign(h1,b-a)
do 20 nstep=1,nmax
dydx = deriv(x,w1)
yscale = abs(y) + abs(h*dydx) + 1.e-25
if (((x + h - b)*h).gt.0.) h = b-x
call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1)
if ((x - b)*h.ge.0) then
ystart = y
return
endif
h = hnew
if (abs(h).lt.abs(hmin)) then
write(logfid,*)'Error in odeint: stepsize too small',w1
& ,ystart,a,b,h1
return
endif
20 continue
write(logfid,*)'Error in odeint: too many steps',w1
& ,ystart,a,b,h1
end
***********************************************************************
*** function rkstepper
***********************************************************************
subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer w1
double precision x,y,dydx,htest,hdid,hnew,yscale,eps,
&yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown,
&powerup,maxup,maxdown,deriv,fac
logical reject
data powerdown/0.25/
data powerup/0.2/
data safety/0.9/
data maxdown/10./
data maxup/5./
reject = .false.
h = htest
10 xnew = x + h
if (x.eq.xnew) then
write(logfid,*)'Error in rkstepper: step size not significant'
return
endif
yhalf = rk4step(x,y,dydx,h/2.,w1)
dydxhalf = deriv(x+h/2.,w1)
y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1)
y1 = rk4step(x,y,dydx,h,w1)
delta = y2-y1
err = abs(delta)/(yscale*eps)
if (err.gt.1.) then
reject = .true.
fac = max(1./maxdown,safety/err**powerdown)
h = h*fac
goto 10
else
if (reject) then
hnew = h
else
fac = min(maxup,safety/err**powerup)
hnew = fac*h
endif
x = xnew
y = y2 + delta/15.
hdid = h
endif
end
***********************************************************************
*** function rk4step
***********************************************************************
double precision function rk4step(x,y,dydx,h,w1)
implicit none
integer w1
double precision x,y,dydx,h,k1,k2,k4,yout,deriv
k1 = h*dydx
k2 = h*deriv(x+h/2.,w1)
k4 = h*deriv(x+h,w1)
yout = y+k1/6.+2.*k2/3.+k4/6.
rk4step = yout
end
***********************************************************************
*** function getdeltat
***********************************************************************
LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT)
IMPLICIT NONE
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--pythia common block
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--max rapidity
common/rapmax/etamax
double precision etamax
C--memory for error message from getdeltat
common/errline/errl
integer errl
C--local variables
INTEGER LINE,I,NNULL
DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR,
&R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN,
&XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF,
&GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN,
&SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT
CHARACTER PTYPE
LOGICAL STOPNOW
C--initialization
GETDELTAT=.FALSE.
DELTAT=0.D0
DTMAX=DTMAX1
IF(K(LINE,2).EQ.21)THEN
PTYPE='G'
ELSE
PTYPE='Q'
ENDIF
NNULL=0
STOPNOW=.FALSE.
C--check for upper bound from plasma lifetime
IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART
IF(DTMAX.LT.0.D0) RETURN
C--calculate time relative to production of the considered parton
TOFF=TSTART-MV(LINE,4)
XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4)
YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4)
ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4)
C--calculate upper limit for density*cross section
SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1)
SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
& P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2)
NEFFMAX=GETNEFFMAX()
NEFFMIN=GETNATMDMIN()
LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN)
if(linvmax.eq.0.d0) return
DO 333 I=1,1000000
DELTAT=DELTAT-LOG(PYR(0))/LINVMAX
XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4)
YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4)
ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4)
TS=TSTART+DELTAT
IF(TS.LT.ZS)THEN
TAU=-1.d0
ELSE
TAU=SQRT(TS**2-ZS**2)
ENDIF
NEFF=GETNEFF(XS,YS,ZS,TS)
IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN
IF(NNULL.GT.4)THEN
STOPNOW=.TRUE.
ELSE
NNULL=NNULL+1
ENDIF
ELSE
NNULL=0
ENDIF
IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN
DELTAT=DTMAX
RETURN
ENDIF
IF(NEFF.GT.0.d0)THEN
SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
& P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0)
ELSE
SIGMA=0.d0
ENDIF
WEIGHT=5.d0*NEFF*SIGMA/LINVMAX
IF(WEIGHT.GT.1.d0+1d-6) then
if (line.ne.errl) then
write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT,
& NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX),
& p(line,4)
errl=line
endif
endif
R=PYR(0)
IF(R.LT.WEIGHT)THEN
GETDELTAT=.TRUE.
RETURN
ENDIF
333 CONTINUE
END
***********************************************************************
*** function poissonian
***********************************************************************
integer function poissonian(lambda)
implicit none
integer n
double precision lambda,disc,p,pyr,u,v,pi
data pi/3.141592653589793d0/
if (lambda.gt.745.d0) then
u = pyr(0);
v = pyr(0);
poissonian =
& int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda)
else
disc=exp(-lambda)
p=1.d0
n=0
800 p = p*pyr(0)
if (p.gt.disc) then
n = n+1
goto 800
endif
poissonian=n
endif
end
***********************************************************************
*** subroutine makemassless
***********************************************************************
subroutine makemassless(l3,l1,l2)
implicit none
C--pythia common block
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer l1,l2,l3
double precision beta(3),Etot,E1new,E2new,E3new,p1new,p1new2
double precision m1,m2,pyp
beta(1)=(p(l1,1)+p(l2,1))/(p(l1,4)+p(l2,4))
beta(2)=(p(l1,2)+p(l2,2))/(p(l1,4)+p(l2,4))
beta(3)=(p(l1,3)+p(l2,3))/(p(l1,4)+p(l2,4))
call pyrobo(l1,l1,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
call pyrobo(l2,l2,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
call pyrobo(l3,l3,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
Etot=p(l1,4)+p(l2,4)+p(l3,4)
E3new=pyp(l3,8)
m1=p(l1,5)
m2=p(l2,5)
p1new2=(((Etot-E3new)**2-m1**2-m2**2)**2 - 4.*m1**2*m2**2)/
& (4.*(Etot-E3new)**2)
if (p1new2.lt.0.d0) write(logfid,*)'negative mass squared: ',p1new2
p1new=sqrt(abs(p1new2))
E1new=sqrt(p1new2+m1**2)
E2new=sqrt(p1new2+m2**2)
p(l1,1)=p(l1,1)*p1new/pyp(l1,8)
p(l1,2)=p(l1,2)*p1new/pyp(l1,8)
p(l1,3)=p(l1,3)*p1new/pyp(l1,8)
p(l1,4)=E1new
p(l2,1)=p(l2,1)*p1new/pyp(l2,8)
p(l2,2)=p(l2,2)*p1new/pyp(l2,8)
p(l2,3)=p(l2,3)*p1new/pyp(l2,8)
p(l2,4)=E2new
p(l3,4)=E3new
p(l3,5)=0.d0
call pyrobo(l1,l1,0.d0,0.d0,beta(1),beta(2),beta(3))
call pyrobo(l2,l2,0.d0,0.d0,beta(1),beta(2),beta(3))
call pyrobo(l3,l3,0.d0,0.d0,beta(1),beta(2),beta(3))
return
end
***********************************************************************
*** function ishadron
***********************************************************************
LOGICAL FUNCTION ISHADRON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.100) THEN
ISHADRON=.FALSE.
ELSE
IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN
ISHADRON = .FALSE.
ELSE
ISHADRON = .TRUE.
ENDIF
ENDIF
END
***********************************************************************
*** function isdiquark
***********************************************************************
LOGICAL FUNCTION ISDIQUARK(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
IF(ABS(ID).LT.1000) THEN
ISDIQUARK=.FALSE.
ELSE
IF(MOD(INT(ID/10),10).EQ.0) THEN
ISDIQUARK = .TRUE.
ELSE
ISDIQUARK = .FALSE.
ENDIF
ENDIF
END
***********************************************************************
*** function islepton
***********************************************************************
LOGICAL FUNCTION ISLEPTON(ID)
IMPLICIT NONE
C-- local variables
INTEGER ID
IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN
ISLEPTON=.TRUE.
ELSE
ISLEPTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isparton
***********************************************************************
LOGICAL FUNCTION ISPARTON(ID)
IMPLICIT NONE
C--local variables
INTEGER ID
LOGICAL ISDIQUARK
IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN
ISPARTON=.TRUE.
ELSE
ISPARTON=.FALSE.
ENDIF
END
***********************************************************************
*** function isprimstring
***********************************************************************
logical function isprimstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
isprimstring=.false.
return
endif
if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then
isprimstring=.true.
else
isprimstring=.false.
endif
end
***********************************************************************
*** function issecstring
***********************************************************************
logical function issecstring(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isparton,isprimstring
if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
issecstring = .false.
return
endif
if (isprimstring(l)) then
issecstring = .false.
return
endif
if (isparton(K(K(K(l,3),3),2))) then
issecstring = .false.
else
issecstring = .true.
endif
end
***********************************************************************
*** function isprimhadron
***********************************************************************
logical function isprimhadron(l)
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
integer l
logical isprimstring,isparton
if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92))
& .and.isprimstring(K(l,3))
& .and.(.not.isparton(K(l,2)))) then
isprimhadron=.true.
else
isprimhadron=.false.
endif
if (k(l,1).eq.17) isprimhadron=.true.
end
***********************************************************************
*** function compressevent
***********************************************************************
logical function compressevent(l1)
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--local variables
integer l1,i,j,nold,nnew,nstart
nold = n
do 777 i=2,nold
if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)
& .or.(k(i,1).eq.14)).and.(i.ne.l1)) then
nnew = i
goto 778
endif
777 continue
compressevent = .false.
return
778 continue
nstart = nnew
do 779 i=nstart,nold
if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)
& .and.(k(i,1).ne.14)).or.(i.eq.l1)) then
do 780 j=1,5
p(nnew,j)=p(i,j)
v(nnew,j)=v(i,j)
mv(nnew,j)=mv(i,j)
780 continue
trip(nnew)=trip(i)
anti(nnew)=anti(i)
za(nnew)=za(i)
zd(nnew)=zd(i)
thetaa(nnew)=thetaa(i)
qqbard(nnew)=qqbard(i)
k(nnew,1)=k(i,1)
k(nnew,2)=k(i,2)
k(nnew,3)=0
k(nnew,4)=0
k(nnew,5)=0
if (l1.eq.i) l1=nnew
nnew=nnew+1
endif
779 continue
n=nnew-1
if ((nold-n).le.10) then
compressevent = .false.
else
compressevent = .true.
endif
do 781 i=nnew,nold
do 782 j=1,5
k(i,j)=0
p(i,j)=0.d0
v(i,j)=0.d0
mv(i,j)=0.d0
782 continue
trip(i)=0
anti(i)=0
za(i)=0.d0
zd(i)=0.d0
thetaa(i)=0.d0
qqbard(i)=.false.
781 continue
if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n
if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1
call flush(logfid)
return
end
***********************************************************************
*** subroutine pevrec
***********************************************************************
SUBROUTINE PEVREC(NUM,COL)
C--identifier of file for hepmc output and logfile
implicit none
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
INTEGER NUM,i
LOGICAL COL
DO 202 I=1,N
V(I,1)=MV(I,1)
V(I,2)=MV(I,2)
V(I,3)=MV(I,3)
V(I,4)=MV(I,4)
V(I,5)=MV(I,5)
! IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
! &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
! &ZD(I),THETAA(I)
IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
&K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
&'{ ',ZD(I),THETAA(I),QQBARD(I),'}'
202 CONTINUE
CALL PYLIST(NUM)
END
***********************************************************************
*** subroutine converttohepmc
***********************************************************************
SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2)
IMPLICIT NONE
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--Parameter common block
COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
&RECSOFTCUT,RECHARDCUT,
&ANGORD,SCATRECOIL,ALLHAD,compress,
&NF,KINMODE,recmode
INTEGER NF,KINMODE,recmode
DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
&RECSOFTCUT,RECHARDCUT
LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
C--organisation of event record
common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
&shorthepmc,channel,isochannel
integer nsim,npart,offset,hadrotype
double precision sqrts
character*4 collider,channel
character*2 isochannel
logical hadro,shorthepmc
C--production point
common/jetpoint/x0,y0
double precision x0,y0
C--initial pt and virtuality
common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
&inz(2),intheta(2)
integer isgluon
double precision inpt,inmass,inphi,ineta,inz,intheta
C--extra storage for scattering centres before interactions
common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
&scatcen(23000,5),writescatcen,writedummies
integer nscatcen,maxnscatcen,scatflav
double precision scatcen
logical writescatcen,writedummies
C--extra storage for dummy particles for subtraction
common/storedummies/dummies(10000,5)
double precision dummies
C--local variables
INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART,
&NFIRST,NVERTEX,NTOT,J,CODEFIRST
integer intinpt(2),intinmass(2),intinphi(2),intineta
integer intz,inttheta
DOUBLE PRECISION mproton,centr,getcentrality,jprodr,phi,pi,
&pdummy,pscatcen,mneutron
LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring,
&issecstring
character*2 beam1,beam2
data mproton/0.9383/
data mneutron/0.9396/
DATA PI/3.141592653589793d0/
5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6)
5100 FORMAT(A2,2E14.6)
! 5200 FORMAT(A2,9I2,4E14.6)
! 5200 FORMAT(A2,2I7,7I2,4E14.6)
5200 FORMAT(A2,6I7,2I2,1I7,4E14.6)
5300 FORMAT(A2,2I2,5E14.6,2I2)
! 5400 FORMAT(A2,I6,6I2,I6,I2)
5400 FORMAT(A2,2I6,5I2,I6,I2)
5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2)
PBARCODE=0
VBARCODE=0
centr = getcentrality()
jprodr = sqrt(x0**2+y0**2)
if (abs(y0).lt.1.d-8) then
if (x0.gt.0.d0) then
phi = 0.d0
else
phi = pi
endif
else
if (x0.gt.0.d0) then
if (y0.gt.0.d0) then
phi = atan(y0/x0)
else
phi = (3.d0*pi/2.d0) - atan(x0/y0)
endif
else
if (y0.gt.0.d0) then
phi = (pi/2.d0) - atan(x0/y0)
else
phi = pi + atan(y0/x0)
endif
endif
endif
do 140 i=1,2
intinpt(i) = int(inpt(i)*100.)
intinmass(i) = int(inmass(i)*100.)
intinphi(i) = int(inphi(i)*100.)
140 continue
intineta = int(ineta(1)*100.)
intz = int(inz(1)*10000.)
inttheta = int(intheta(1)*100.)
if (shorthepmc) then
C--short output
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
PBARCODE=5
ELSE
NVERTEX=1
PBARCODE=2
ENDIF
nfirst = 0
do 131 i=1,N
- if (((k(i,1).lt.6).or.(k(i,1).eq.17).or.(k(i,1).eq.7)))
+ if ((k(i,1).lt.6).or.(k(i,1).eq.17).or.(k(i,1).eq.7)
+ & .or.(k(i,1).eq.8))
& nfirst = nfirst+1
131 continue
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1,
&PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 133 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
133 continue
endif
C--write out dummy particles
if(writedummies) then
do 137 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
137 continue
endif
C--write out particle lines
do 132 i=1,N
- if((k(i,1).lt.6).or.(k(i,1).eq.17).or.(k(i,1).eq.7)) then
+ if((k(i,1).lt.6).or.(k(i,1).eq.17).or.(k(i,1).eq.7)
+ & .or.(k(i,1).eq.8)) then
pbarcode=pbarcode+1
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
- & P(I,4),P(I,5),1,0,0,0,0
+ & P(I,4),P(I,5),4,0,0,0,0
else if(k(i,1).eq.7) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),7,0,0,0,0
+ else if(k(i,1).eq.8) then
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),8,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
endif
132 continue
else
C--long output
if (hadro) then
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 123 I=1,N
IF(K(i,3).ne.0)THEN
NSTART=I
GOTO 124
ENDIF
123 CONTINUE
124 CONTINUE
nstart=0
DO 126 I=NSTART+1,N
IF(isprimhadron(i)) NFIRST=NFIRST+1
IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15))
& .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1
126 CONTINUE
127 CONTINUE
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
! WRITE(J,5200)'H ',
! & intinpt(1),intinmass(1),intinphi(1),
! & intinpt(2),intinmass(2),intinphi(2),
! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5200)'H ',
& intinpt(1),intinmass(1),intinphi(1),
& intinpt(2),intz,inttheta,
& isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
CODEFIRST=NFIRST+PBARCODE
C--write out scattering centres
if(writescatcen) then
do 134 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
134 continue
endif
C--write out dummy particles
if(writedummies) then
do 138 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
138 continue
endif
C--first write out all particles coming directly from string or cluster decays
DO 125 I=NSTART+1,N
IF(.not.isprimhadron(i))THEN
GOTO 125
ELSE
IF (PBARCODE.EQ.CODEFIRST) GOTO 130
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
ENDIF
125 CONTINUE
130 CONTINUE
C--now write out all other particles and vertices
DO 129 I=NSTART+1,N
if (isprimhadron(i).or.isprimstring(i)) goto 129
if (isparton(K(i,2))) then
if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3))
goto 129
endif
if (issecstring(i)) then
codelist(i)=codelist(K(i,3))
goto 129
endif
PBARCODE=PBARCODE+1
IF((K(I,3).NE.K(I-1,3)))THEN
C--write out vertex line
WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
ENDIF
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
ENDIF
129 CONTINUE
else
C---------------------------------------------------------------------------------------
C--partonic events
! call pevrec(2,.false.)
C--hadronised events
NFIRST=0
IF(COLLIDER.EQ.'EEJJ')THEN
NVERTEX=3
ELSE
NVERTEX=1
ENDIF
DO 150 I=9,N
IF((k(i,3).eq.1).or.(k(i,3).eq.2).or.
& (k(i,3).eq.7).or.(k(i,3).eq.8)) NFIRST=NFIRST+1
IF(K(I,4).NE.0) NVERTEX=NVERTEX+1
150 CONTINUE
nstart = 9+nfirst
if(writescatcen) NFIRST=NFIRST+nscatcen
if(writedummies) NFIRST=NFIRST+nscatcen
WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
&1,2,0,1,PARI(10)
WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
WRITE(J,'(A)')'U GEV MM'
WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,centr,0.d0,0.d0,0.d0
WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
C--write out vertex line
IF(COLLIDER.EQ.'EEJJ')THEN
VBARCODE=-3
PBARCODE=5
ELSE
VBARCODE=-1
PBARCODE=2
ENDIF
IF(COLLIDER.EQ.'EEJJ')THEN
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
& 0.00051,2,0,0,-1,0
WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
& 91.2,2,0,0,-2,0
WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
& 0.000,2,0,0,-3,0
WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
ELSE
WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
if (beam1.eq.'p+') then
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
& sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
if (beam2.eq.'p+') then
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
else
WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
& -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
endif
ENDIF
C--write out scattering centres
if(writescatcen) then
do 151 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
& scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
& 3,0,0,0,0
151 continue
endif
C--write out dummy particles
if(writedummies) then
do 152 i=1,nscatcen
pbarcode=pbarcode+1
WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
& dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
152 continue
endif
C--write out outgoing particles of first vertex
do 154 i=9,nstart-1
PBARCODE=PBARCODE+1
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
154 continue
C--now write out all other particles and vertices
DO 153 I=NSTART,N
PBARCODE=PBARCODE+1
if (k(i,3).eq.0) then
C--write out vertex line - scattering
WRITE(J,5400)'V ',CODELIST(K(I+1,3)),k(k(i+1,3),1),0,0,
& 0,0,0,K(K(I+1,3),5)-K(K(I+1,3),4)+1,0
elseif ((k(i,3).ne.k(i-1,3)).and.(k(i-1,3).ne.0)) then
C--write out vertex line - splitting
WRITE(J,5400)'V ',CODELIST(K(I,3)),k(k(i,3),1),0,0,0,0,0,
& K(K(I,3),5)-K(K(I,3),4)+1,0
endif
C--write out particle line
IF(K(I,4).GT.0)THEN
VBARCODE=VBARCODE-1
CODELIST(I)=VBARCODE
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),2,0,0,VBARCODE,0
ELSE
if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),4,0,0,0,0
+ elseif(k(i,1).eq.7) then
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),7,0,0,0,0
+ elseif(k(i,1).eq.8) then
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),8,0,0,0,0
elseif ((k(i,1).eq.11).and.(k(i,3).eq.0)) then
WRITE(J,5500)'P ',PBARCODE,0,0.d0,0.d0,0.d0,
& 0.d0,0.d0,0,0,0,0,0
else
WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
& P(I,4),P(I,5),1,0,0,0,0
endif
ENDIF
153 CONTINUE
endif
endif
call flush(j)
END
subroutine combinegluons()
implicit none
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
INTEGER MSTP,MSTI
DOUBLE PRECISION PARP,PARI
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
integer ncomb,i,j
double precision mom(4),mass2
logical compress,compressevent
data ncomb/3/
do 100 i=1,n
C-- find recoils (= gluons with finite mass)
if ((k(i,2).eq.21).and.(p(i,5).ne.0.d0).and.(k(i,1).eq.2)) then
mom(1) = p(i,1)
mom(2) = p(i,2)
mom(3) = p(i,3)
mom(4) = p(i,4)
do 101 j=1,ncomb-1
if ((k(i+j,2).eq.21).and.(p(i+j,5).ne.0.d0)
& .and.(k(i+j,1).eq.2)) then
mom(1) = mom(1) + p(i+j,1)
mom(2) = mom(2) + p(i+j,2)
mom(3) = mom(3) + p(i+j,3)
mom(4) = mom(4) + p(i+j,4)
k(i+j,1) = 11
else
goto 102
endif
101 continue
102 p(i,1) = mom(1)
p(i,2) = mom(2)
p(i,3) = mom(3)
p(i,4) = mom(4)
mass2 = mom(4)**2-mom(1)**2-mom(2)**2-mom(3)**2
if (mass2.lt.0.d0) write(logfid,*)mass2
endif
100 continue
C i=0
C compress = compressevent(i)
return
end
***********************************************************************
*** subroutine copyline
***********************************************************************
SUBROUTINE COPYLINE(NFR,NTO,MODE)
IMPLICIT NONE
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(23000,5)
DOUBLE PRECISION MV
C--colour index common block
COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
INTEGER TRIP,ANTI,COLMAX
C--variables for angular ordering
COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
DOUBLE PRECISION ZA,ZD,THETAA
LOGICAL QQBARD
C--local variables
integer nfr,nto,mode,j
if (mode.ge.0) then
k(nto,1) = k(nfr,1)
k(nto,2) = k(nfr,2)
do 100 j=1,5
p(nto,j) = p(nfr,j)
100 continue
za(nto)=za(nfr)
zd(nto)=zd(nfr)
thetaa(nto)=thetaa(nfr)
qqbard(nto)=qqbard(nfr)
endif
if (mode.ge.1) then
do 101 j=1,5
mv(nto,j) = mv(nfr,j)
101 continue
endif
if (mode.eq.2) then
trip(nto)=trip(nfr)
anti(nto)=anti(nfr)
endif
return
end
***********************************************************************
*** subroutine printlogo
***********************************************************************
subroutine printlogo(fid)
implicit none
integer fid
write(fid,*)
write(fid,*)' _______________'//
&'__________________________ '
write(fid,*)' | '//
&' | '
write(fid,*)' | JJJJJ EEEEE '//
&' W W EEEEE L | '
write(fid,*)' | J E '//
&' W W E L | '
write(fid,*)' _________________| J EEE '//
&' W W W EEE L |_________________ '
write(fid,*)'| | J J E '//
&' W W W W E L | |'
write(fid,*)'| | JJJ EEEEE '//
&' W W EEEEE LLLLL | |'
write(fid,*)'| |_______________'//
&'__________________________| |'
write(fid,*)'| '//
&' |'
write(fid,*)'| '//
&'this is JEWEL 2.4.0 |'
write(fid,*)'| '//
&' |'
write(fid,*)'| Copyright Korinna C. Zapp (2022)'//
&' [Korinna.Zapp@thep.lu.se] |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| The medium model was partly '//
&'implemented by Jochen Klein |'
write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '//
&'Kunnawalkam Elayavalli helped with the |'
write(fid,*)'| implementation of the V+jet processes '//
&'[raghav.k.e@cern.ch]. |'
write(fid,*)'| '//
&' |'
write(fid,*)'| Please cite JHEP 1303 (2013) '//
&'080 [arXiv:1212.1599] for physics and |'
write(fid,*)'| EPJC 74 (2014) no.2, 2762 [arXiv:1311.0048] '//
&' for the code. |'
write(fid,*)'| The reference for '//
&'V+jet processes is EPJC 76 (2016) no.12 695 |'
write(fid,*)'| [arXiv:1608.03099] and for recoil effects'//
&' it is JHEP 07 (2017) 141 |'
write(fid,*)'| [arXiv:1707.01539]. '//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL relies heavily on PYTHIA 6'//
&' for the event generation. The modified |'
write(fid,*)'| version of PYTHIA 6.4.25 that is'//
&' shipped with JEWEL is, however, not an |'
write(fid,*)'| official PYTHIA release and must'//
&' not be used for anything else. Please |'
write(fid,*)'| refer to results as "JEWEL+PYTHIA".'//
&' |'
write(fid,*)'| '//
&' |'
write(fid,*)'| JEWEL also uses code provided by'//
&'S. Zhang and J. M. Jing |'
write(fid,*)'| (Computation of Special Functions, '//
&'John Wiley & Sons, New York, 1996 and |'
write(fid,*)'| http://jin.ece.illinois.edu) for '//
&'computing the exponential integral Ei(x). |'
write(fid,*)'| '//
&' |'
write(fid,*)'|_________________________________'//
&'____________________________________________|'
write(fid,*)
write(fid,*)
end
***********************************************************************
*** subroutine printtime
***********************************************************************
subroutine printtime
implicit none
C--identifier of file for hepmc output and logfile
common/hepmcid/hpmcfid,logfid
integer hpmcfid,logfid
C--local variables
integer*4 date(3),time(3)
1000 format (i2.2, '.', i2.2, '.', i4.4, ', ',
& i2.2, ':', i2.2, ':', i2.2 )
call idate(date)
call itime(time)
write(logfid,1000)date,time
end
Index: trunk/code/runit-lhc5.sh
===================================================================
--- trunk/code/runit-lhc5.sh (revision 504)
+++ trunk/code/runit-lhc5.sh (revision 505)
@@ -1,46 +1,46 @@
#!/bin/bash
source /media/hdmobil/korinna/arbeit/rivet2/local/rivetenv.sh
export RIVET_ANALYSIS_PATH=$RIVET_ANALYSIS_PATH:/media/hdmobil/korinna/arbeit/MC/jewel/trunc/code/
#export RIVET_REF_PATH=$RIVET_REF_PATH:/home/jewel/trunk/code
export LD_LIBRARY_PATH=/media/hdmobil/korinna/arbeit/lhapdf6/lib/:$LD_LIBRARY_PATH
export LHAPATH=/media/hdmobil/korinna/arbeit/lhapdf6/share/LHAPDF
fifo=fifo-vac5.hepmc
runcard=params.vac5.dat
#outfile=data/jewel-2.3.0_vac_hl_5TeV_1M.yoda
#outfile=data/jewel-2.1.1_vac_cms-zg.yoda
-outfile=data/jewel-2.4.0_vac_5TeV.israd-largeR2.yoda
-#outfile=data/jewel-2.3.0_vac_5TeV.Mg.yoda
+#outfile=data/jewel-2.4.0_vac_5TeV.israd-largeR2.yoda
+outfile=data/jewel-2.3.0_vac_5TeV_q0.test-jetpr.yoda
#outfile=data/test.yoda
rm $fifo
mkfifo $fifo
sed -i 's/FIFO/'$fifo'/g' $runcard
-./jewel-240-hilmi-vac $runcard &
+#./jewel-240-hilmi-vac $runcard &
#./jewel-emmi-vac $runcard &
-#./jewel-2.4.0-vac $runcard &
+./jewel-2.3.0-vac $runcard &
#rivet --pwd -a MC_XS -a MC_JETS_ISRAD -H $outfile $fifo
-rivet --pwd -a MC_XS -a MC_ISRAD_LARGERADIUS -H $outfile $fifo
+#rivet --pwd -a MC_XS -a MC_ISRAD_LARGERADIUS -H $outfile $fifo
#rivet --pwd -a MC_XS -a ATLAS_2018_I1673184 -H $outfile $fifo
-#rivet --pwd -a MC_XS -a CMS_2018_I1658057 -H $outfile $fifo
+rivet --pwd -a MC_XS -a CMS_2018_I1658057 -H $outfile $fifo
#rivet --pwd -a MC_XS -a CMS_2018_I1672962 -H $outfile $fifo
#rivet --pwd -a MC_XS -a CMS_2021_I1840683 -H $outfile $fifo
#rivet -a MC_XS -a MC_SOFTDROP_REC -a MC_SOFTDROP_NOREC_GRID -a MC_SOFTDROP_NOREC_PART -H $outfile $fifo
#rivet -a MC_XS -a MC_SOFTDROP_REC -a MC_SOFTDROP_NOREC_GRID -H $outfile $fifo
#rivet -a MC_XS -a MC_SOFTDROP_UNSUB_GRID -a MC_SOFTDROP_UNSUB_PART -H $outfile $fifo
#rivet -a MC_XS -a MC_SOFTDROP_4MOMSUB -a MC_SOFTDROP_NOREC -H $outfile $fifo
#rivet --pwd -a MC_XS -a MC_SOFTDROP_4MOMSUB -a MC_SOFTDROP_NOREC -a MC_SOFTDROP_REC -a MC_SOFTDROP_NOREC_GRID -H $outfile $fifo
#rivet -a MC_XS -a MC_ETOT -H $outfile $fifo
#rivet --pwd -a MC_XS -a TEST_JETMASS -H $outfile $fifo
#rivet --pwd -a MC_XS -a CMS_SOFTDROP_4MOMSUB -H $outfile $fifo
#rivet --pwd -a MC_XS -a MC_SOFTDROP_4MOMSUB -H $outfile $fifo
#rivet --pwd -a MC_XS -a CMS_SOFTDROP_4MOMSUB -a CMS_GROOMEDMASS_4MOMSUB -a MC_JETMASS_TINY -a ATLAS_2018_I1673184 -H $outfile $fifo
#rivet --pwd -a MC_XS -a MC_TIMES -H $outfile $fifo
sed -i 's/'$fifo'/FIFO/g' $runcard
rm $fifo
Index: trunk/code/Makefile
===================================================================
--- trunk/code/Makefile (revision 504)
+++ trunk/code/Makefile (revision 505)
@@ -1,33 +1,44 @@
-all: jewel-2.3.0-vac jewel-2.3.0-simple jewel-2.4.0-vac jewel-2.4.0-simple jewel-240-hilmi-vac jewel-240-hilmi-simple
+all: jewel-2.3.0-vac jewel-2.3.0-simple jewel-2.4.0-vac jewel-2.4.0-simple jewel-2.5.0-vac jewel-2.5.0-simple jewel-240-hilmi-vac jewel-240-hilmi-simple pythiatests
# path to LHAPDF library
-LHAPDF_PATH := /media/hdmobil/korinna/arbeit/lhapdf6/lib
+LHAPDF_PATH := /media/hdmobil/korinna/arbeit/lhapdf6.5.1/lib
FC := gfortran
-FFLAGS := -O2
+FFLAGS := -O2
+#-fno-align-commons
jewel-2.3.0-vac: jewel-2.3.0.o medium-vac.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
jewel-2.3.0-simple: jewel-2.3.0.o medium-simple.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
jewel-2.4.0-vac: jewel-2.4.0.o medium-vac.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
jewel-2.4.0-simple: jewel-2.4.0.o medium-simple.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
+jewel-2.5.0-vac: jewel-2.5.0.o medium-vac.o pythia6425mod-lhapdf6.o
+ $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
+
+jewel-2.5.0-simple: jewel-2.5.0.o medium-simple.o pythia6425mod-lhapdf6.o
+ $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
+
jewel-240-hilmi-vac: jewel-240-hilmi.o medium-vac.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
jewel-240-hilmi-simple: jewel-240-hilmi.o medium-simple.o pythia6425mod-lhapdf6.o
$(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
+pythiatests: pythiatests.o pythia6425mod-lhapdf6.o
+ $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++
+
clean:
rm -f medium-*.o
rm -f jewel*.o
rm -f pythia6425mod-lhapdf6.o
+ rm -f pythiatests.o
rm -f *~
.PHONY: all
Index: trunk/code/jewel-2.5.0.f
===================================================================
--- trunk/code/jewel-2.5.0.f (revision 0)
+++ trunk/code/jewel-2.5.0.f (revision 505)
@@ -0,0 +1,8511 @@
+
+ PROGRAM JEWEL
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ INTEGER MSEL,MSELPD,MSUB,KFIN
+ DOUBLE PRECISION CKIN
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ INTEGER MRPY
+ DOUBLE PRECISION RRPY
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--number of protons
+ common/np/nproton,mass
+ integer nproton,mass
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--local variables
+ integer j,i,kk,poissonian
+ integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
+ double precision sumofweightstot,wdisctot,scalefac
+ double precision gettemp,r,tau
+ character*2 b1,b2
+
+ call init()
+
+ SUMOFWEIGHTSTOT=0.d0
+ WDISCTOT=0.d0
+
+C--e+ + e- event generation
+ if (collider.eq.'EEJJ') then
+ b1 = 'e+'
+ b2 = 'e-'
+ write(logfid,*)
+ write(logfid,*)
+ &'####################################################'
+ write(logfid,*)
+ write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
+ &' channel'
+ write(logfid,*)
+ write(logfid,*)
+ &'####################################################'
+ write(logfid,*)
+ SUMOFWEIGHTS=0.d0
+ WDISC=0.d0
+ call initpythia(b1,b2)
+ write(logfid,*)
+C--e+ + e- event loop
+ DO 100 J=1,NSIM
+ call genevent(j,b1,b2)
+ 100 CONTINUE
+ sumofweightstot = sumofweightstot+sumofweights
+ wdisctot = wdisctot + wdisc
+ write(logfid,*)
+ write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb'
+ write(logfid,*)'sum of event weights in e+ + e- channel:',
+ & sumofweights-wdisc
+ write(logfid,*)
+
+ else
+C--hadronic event generation
+ if (isochannel.eq.'PP') then
+ nsimpp = nsim
+ nsimpn = 0
+ nsimnp = 0
+ nsimnn = 0
+ elseif (isochannel.eq.'PN') then
+ nsimpp = 0
+ nsimpn = nsim
+ nsimnp = 0
+ nsimnn = 0
+ elseif (isochannel.eq.'NP') then
+ nsimpp = 0
+ nsimpn = 0
+ nsimnp = nsim
+ nsimnn = 0
+ elseif (isochannel.eq.'NN') then
+ nsimpp = 0
+ nsimpn = 0
+ nsimnp = 0
+ nsimnn = nsim
+ else
+ nsimpp = poissonian(1.d0*nsim*nproton**2/mass**2)
+ nsimpn = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
+ nsimnp = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2)
+ nsimnn = poissonian(1.d0*nsim*(mass-nproton)**2/mass**2)
+ nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
+ scalefac = nsim*1.d0/(nsimsum*1.d0)
+ nsimpp = int(nsimpp*scalefac)
+ nsimpn = int(nsimpn*scalefac)
+ nsimnp = int(nsimnp*scalefac)
+ nsimnn = int(nsimnn*scalefac)
+ nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
+ endif
+C--loop over channels
+ do 101 kk=1,4
+ if (kk.eq.1) then
+ b1 = 'p+'
+ b2 = 'p+'
+ nsimchn = nsimpp
+ elseif (kk.eq.2) then
+ b1 = 'p+'
+ b2 = 'n0'
+ nsimchn = nsimpn
+ elseif (kk.eq.3) then
+ b1 = 'n0'
+ b2 = 'p+'
+ nsimchn = nsimnp
+ else
+ b1 = 'n0'
+ b2 = 'n0'
+ nsimchn = nsimnn
+ endif
+ write(logfid,*)
+ write(logfid,*)
+ &'####################################################'
+ write(logfid,*)
+ write(logfid,*)'generating ',nsimchn,' events in ',
+ &b1,' + ',b2,' channel'
+ write(logfid,*)
+ write(logfid,*)
+ &'####################################################'
+ write(logfid,*)
+ SUMOFWEIGHTS=0.d0
+ WDISC=0.d0
+ call initpythia(b1,b2)
+ write(logfid,*)
+C--event loop
+ DO 102 J=1,nsimchn
+ call genevent(j,b1,b2)
+ 102 CONTINUE
+ sumofweightstot = sumofweightstot+sumofweights
+ wdisctot = wdisctot + wdisc
+ write(logfid,*)
+ write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
+ & PARI(1),'mb'
+ write(logfid,*)'sum of event weights in ',b1,' + ',b2,
+ & ' channel:',sumofweights-wdisc
+ write(logfid,*)
+ 101 continue
+ endif
+
+C--finish
+ WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
+ WRITE(HPMCFID,*)
+ CLOSE(HPMCFID,status='keep')
+
+ write(logfid,*)
+ write(logfid,*)'mean number of scatterings:',
+ & NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT)
+ write(logfid,*)'mean number of effective scatterings:',
+ & NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT)
+ write(logfid,*)'mean number of splittings:',
+ & NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT)
+ write(logfid,*)'mean number of splittings from IS shower:',
+ & nspliti/(SUMOFWEIGHTSTOT-WDISCTOT)
+ write(logfid,*)'mean number of splittings from FS shower:',
+ & nsplitf/(SUMOFWEIGHTSTOT-WDISCTOT)
+ write(logfid,*)'fraction of rejected IS splittings:',
+ & nisfail/nistry
+ write(logfid,*)'fraction of rejected FS splittings:',
+ & nfsfail/nfstry
+ write(logfid,*)'fraction of rejected momentum transfers:',
+ & ntrej/nttot
+ write(logfid,*)
+ write(logfid,*)'number of extrapolations in splitting integral: ',
+ & noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
+ write(logfid,*)
+ & 'number of extrapolations in splitting partonic PDFs: ',
+ & noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
+ write(logfid,*)
+ & 'number of extrapolations in splitting cross sections: ',
+ & noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
+ write(logfid,*)
+ & 'number of extrapolations in Sudakov form factor: ',
+ & noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
+ write(logfid,*)
+ write(logfid,*)'number of good events: ',ngood
+ write(logfid,*)'total number of discarded events: ',NDISC
+ write(logfid,*)'number of events for which conversion '//
+ &'to hepmc failed: ',NSTRANGE
+ call printtime
+
+ close(logfid,status='keep')
+
+ END
+
+
+
+***********************************************************************
+***********************************************************************
+*** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES ****************
+***********************************************************************
+***********************************************************************
+
+
+***********************************************************************
+*** subroutine init
+***********************************************************************
+ subroutine init()
+ implicit none
+ INTEGER PYCOMP
+ INTEGER NMXHEP
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ INTEGER MSEL,MSELPD,MSUB,KFIN
+ DOUBLE PRECISION CKIN
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ INTEGER MRPY
+ DOUBLE PRECISION RRPY
+C--pdfset
+ common/pdf/pdfset
+ integer pdfset
+C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
+ common/pdfas/pdfalphas
+ double precision pdfalphas
+C--number of protons
+ common/np/nproton,mass
+ integer nproton,mass
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--splitting integral
+ COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
+ &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
+ INTEGER NPOINT
+ DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
+ &QVAL,ZMVAL,QMAX,ZMMIN
+C--pdf common block
+ COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
+ &GINGX(2,1000)
+ DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
+C--cross secttion common block
+ COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
+ &INTG1(1001,101),INTG2(1001,101)
+ DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
+C--Sudakov common block
+ COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2)
+ &,SUDAGC(1000,2)
+ DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
+C--exponential integral for negative arguments
+ COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
+ INTEGER NVAL
+ DOUBLE PRECISION EIXS,VALMAX
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--factor in front of alphas argument
+ COMMON/ALPHASFAC/PTFAC
+ DOUBLE PRECISION PTFAC
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--event weight exponent
+ COMMON/WEXPO/WEIGHTEX
+ DOUBLE PRECISION WEIGHTEX
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--memory for error message from getdeltat
+ common/errline/errl
+ integer errl
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--extra storage for scattering centres before interactions
+ common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
+ &scatcen(23000,5),writescatcen,writedummies
+ integer nscatcen,maxnscatcen,scatflav
+ double precision scatcen
+ logical writescatcen,writedummies
+C--Pythia parameters
+ common/pythiaparams/PTMIN,PTMAX,weighted,mpi,pi0dec
+ double precision PTMIN,PTMAX
+ LOGICAL WEIGHTED,mpi,pi0dec
+
+C--Variables local to this program
+ INTEGER NJOB,ios,pos,i,j,jj,intmass
+ DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr
+ character firstchar
+ CHARACTER*2 SNSET
+ CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer,
+ &label,value
+ CHARACTER*120 HEPMCFILE,LOGFILE,FILENAME2
+ CHARACTER(LEN=100) filename
+ LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST
+
+ data maxnscatcen/22990/
+
+ HPMCFID = 4
+ logfid = 3
+
+C--default settings
+ nsim = 10000
+ njob = 0
+ logfile = 'out.log'
+ hepmcfile = 'out.hepmc'
+ filesplit = 'splitint.dat'
+ pdffile = 'pdfs.dat'
+ xsecfile = 'xsecs.dat'
+ filemed = 'medium-params.dat'
+ nf = 3
+ lqcd = 0.4
+ q0 = 1.5
+ ptmin = 5.
+ ptmax = 350.
+ etamax = 3.1
+ collider = 'PPJJ'
+ isochannel = 'XX'
+ channel = 'MUON'
+ sqrts = 2760
+ pdfset = 13100
+ pdfalphas = 0.118
+ mass = 208
+ nproton = 82
+ weighted = .true.
+ weightex = 5.
+ mpi = .false.
+ mpifsr = .true.
+ angord = .true.
+ allhad = .false.
+ hadro = .true.
+ hadrotype = 0
+ pi0dec = .true.
+ isrscat = .true.
+ shorthepmc = .true.
+ compress = .true.
+ writescatcen = .false.
+ writedummies = .false.
+ scatrecoil = .false.
+ recsoftcut = 0.
+ rechardcut = 5.
+ kinmode = 1
+ recmode = 0
+
+ if (iargc().eq.0) then
+ write(*,*)'No parameter file given, '//
+ &'will run with default settings.'
+ else
+ call getarg(1,filename)
+ write(*,*)'Reading parameters from ',filename
+ open(unit=1,file=filename,status='old',err=110)
+ do 120 i=1,1000
+ read(1, '(A)', iostat=ios) buffer
+ if(ios.ne.0) goto 130
+ firstchar = buffer(1:1)
+ if (firstchar.eq.'#') goto 120
+ pos=scan(buffer,' ')
+ label=buffer(1:pos)
+ value=buffer(pos+1:)
+ if(label.eq."NEVENT")then
+ read(value,*,iostat=ios) nsim
+ elseif(label.eq."NJOB")then
+ read(value,*,iostat=ios) njob
+ elseif(label.eq."LOGFILE")then
+ read(value,'(a)',iostat=ios) logfile
+ elseif(label.eq."HEPMCFILE")then
+ read(value,'(a)',iostat=ios) hepmcfile
+ elseif(label.eq."SPLITINTFILE")then
+ read(value,'(a)',iostat=ios) filesplit
+ elseif(label.eq."PDFFILE")then
+ read(value,'(a)',iostat=ios) pdffile
+ elseif(label.eq."XSECFILE")then
+ read(value,'(a)',iostat=ios) xsecfile
+ elseif(label.eq."MEDIUMPARAMS")then
+ read(value,'(a)',iostat=ios) filemed
+ elseif(label.eq."NF")then
+ read(value,*,iostat=ios) nf
+ elseif(label.eq."LAMBDAQCD")then
+ read(value,*,iostat=ios) lqcd
+ elseif(label.eq."Q0")then
+ read(value,*,iostat=ios) q0
+ elseif(label.eq."PTMIN")then
+ read(value,*,iostat=ios) ptmin
+ elseif(label.eq."PTMAX")then
+ read(value,*,iostat=ios) ptmax
+ elseif(label.eq."ETAMAX")then
+ read(value,*,iostat=ios) etamax
+ elseif(label.eq."PROCESS")then
+ read(value,*,iostat=ios) collider
+ elseif(label.eq."ISOCHANNEL")then
+ read(value,*,iostat=ios) isochannel
+ elseif(label.eq."CHANNEL")then
+ read(value,*,iostat=ios) channel
+ elseif(label.eq."SQRTS")then
+ read(value,*,iostat=ios) sqrts
+ elseif(label.eq."PDFSET")then
+ read(value,*,iostat=ios) pdfset
+ elseif(label.eq."PDFALPHAS")then
+ read(value,*,iostat=ios) pdfalphas
+ elseif(label.eq."MASS")then
+ read(value,*,iostat=ios) mass
+ elseif(label.eq."NPROTON")then
+ read(value,*,iostat=ios) nproton
+ elseif(label.eq."WEIGHTED")then
+ read(value,*,iostat=ios) weighted
+ elseif(label.eq."WEXPO")then
+ read(value,*,iostat=ios) weightex
+ elseif(label.eq."MPI")then
+ read(value,*,iostat=ios) mpi
+ elseif(label.eq."MPIFSR")then
+ read(value,*,iostat=ios) mpifsr
+ elseif(label.eq."ANGORD")then
+ read(value,*,iostat=ios) angord
+ elseif(label.eq."KEEPRECOILS")then
+ read(value,*,iostat=ios) allhad
+ elseif(label.eq."SCATRECOIL")then
+ read(value,*,iostat=ios) scatrecoil
+ elseif(label.eq."HADRO")then
+ read(value,*,iostat=ios) hadro
+ elseif(label.eq."HADROTYPE")then
+ read(value,*,iostat=ios) hadrotype
+ elseif(label.eq."PI0DEC")then
+ read(value,*,iostat=ios) pi0dec
+ elseif(label.eq."ISRSCAT")then
+ read(value,*,iostat=ios) isrscat
+ elseif(label.eq."SHORTHEPMC")then
+ read(value,*,iostat=ios) shorthepmc
+ elseif(label.eq."COMPRESS")then
+ read(value,*,iostat=ios) compress
+ elseif(label.eq."WRITESCATCEN")then
+ read(value,*,iostat=ios) writescatcen
+ elseif(label.eq."WRITEDUMMIES")then
+ read(value,*,iostat=ios) writedummies
+ elseif(label.eq."RECSOFTCUT")then
+ read(value,*,iostat=ios) recsoftcut
+ elseif(label.eq."RECHARDCUT")then
+ read(value,*,iostat=ios) rechardcut
+ elseif(label.eq."KINMODE")then
+ read(value,*,iostat=ios) kinmode
+ elseif(label.eq."RECMODE")then
+ read(value,*,iostat=ios) recmode
+ else
+ write(*,*)'unknown label ',label
+ endif
+ 120 continue
+
+
+ 110 write(*,*)
+ & 'Unable to open parameter file, will exit the run.'
+ call exit(1)
+
+ 130 close(1,status='keep')
+ write(*,*)'...done'
+ endif
+
+ lps = lqcd
+! scatrecoil = .false.
+! if (.not.hadro) shorthepmc = .true.
+
+ if (recmode.eq.2) then
+ allhad = .false.
+ scatrecoil = .false.
+ endif
+
+ SCALEFACM=1.
+ ptfac=1.
+ ftfac=1.d0
+
+ if (ptmin.lt.3.d0) ptmin = 3.d0
+ if (.not.writescatcen) writedummies = .false.
+
+ OPEN(unit=logfid,file=LOGFILE,status='unknown')
+ MSTU(11)=logfid
+
+ call printtime
+ call printlogo(logfid)
+
+
+ write(logfid,*)
+ write(logfid,*)'parameters of the run:'
+ write(logfid,*)'NEVENT = ',nsim
+ write(logfid,*)'NJOB = ',njob
+ write(logfid,*)'LOGFILE = ',logfile
+ write(logfid,*)'HEPMCFILE = ',hepmcfile
+ write(logfid,*)'SPLITINTFILE = ',filesplit
+ write(logfid,*)'PDFFILE = ',pdffile
+ write(logfid,*)'XSECFILE = ',xsecfile
+ write(logfid,*)'MEDIUMPARAMS = ',filemed
+ write(logfid,*)'NF = ',nf
+ write(logfid,*)'LAMBDAQCD = ',lqcd
+ write(logfid,*)'Q0 = ',q0
+ write(logfid,*)'PTMIN = ',ptmin
+ write(logfid,*)'PTMAX = ',ptmax
+ write(logfid,*)'ETAMAX = ',etamax
+ write(logfid,*)'PROCESS = ',collider
+ write(logfid,*)'ISOCHANNEL = ',isochannel
+ write(logfid,*)'CHANNEL = ',channel
+ write(logfid,*)'SQRTS = ',sqrts
+ write(logfid,*)'PDFSET = ',pdfset
+ write(logfid,*)'PDFALPHAS = ',pdfalphas
+ write(logfid,*)'MASS = ',mass
+ write(logfid,*)'NPROTON = ',nproton
+ write(logfid,*)'WEIGHTED = ',weighted
+ write(logfid,*)'WEXPO = ',weightex
+ write(logfid,*)'MPI = ',mpi
+ write(logfid,*)'MPIFSR = ',mpifsr
+ write(logfid,*)'ANGORD = ',angord
+ write(logfid,*)'HADRO = ',hadro
+ write(logfid,*)'HADROTYPE = ',hadrotype
+ write(logfid,*)'PI0DEC = ',pi0dec
+ write(logfid,*)'ISRSCAT = ',isrscat
+ write(logfid,*)'SHORTHEPMC = ',shorthepmc
+ write(logfid,*)'COMPRESS = ',compress
+ write(logfid,*)'KEEPRECOILS = ',allhad
+ write(logfid,*)'SCATRECOIL = ',scatrecoil
+ write(logfid,*)'RECSOFTCUT = ',recsoftcut
+ write(logfid,*)'RECHARDCUT = ',rechardcut
+ write(logfid,*)'WRITESCATCEN = ',writescatcen
+ write(logfid,*)'WRITEDUMMIES = ',writedummies
+ write(logfid,*)'KINMODE = ',kinmode
+ write(logfid,*)'RECMODE = ',recmode
+ write(logfid,*)
+ call flush(logfid)
+
+ if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
+ & .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
+ & .and.(collider.ne.'PPYG')
+ & .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
+ & .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
+ & .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
+ & .and.(collider.ne.'PPDY')) then
+ write(logfid,*)'Fatal error: colliding system unknown, '//
+ & 'will exit now'
+ call exit(1)
+ endif
+
+C--initialize medium
+ intmass = int(mass)
+ CALL MEDINIT(FILEMED,logfid,etamax,intmass)
+ CALL MEDNEXTEVT
+
+ OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown')
+ WRITE(HPMCFID,*)
+ WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05'
+ WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
+
+ NPART=2
+
+ if(ptmax.gt.0.)then
+ EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.)
+ else
+ EOVEST=sqrts/2.
+ endif
+
+
+ CALL EIXINT
+ CALL INSUDAINT(EOVEST)
+
+ write(logfid,*)
+ INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
+ IF(SPLITIEXIST)THEN
+ write(logfid,*)'read splitting integrals from ',FILESPLIT
+ OPEN(unit=10,file=FILESPLIT,status='old')
+ READ(10,*)QMAX,ZMMIN,NPOINT
+ DO 893 I=1,NPOINT+1
+ READ(10,*) QVAL(I),ZMVAL(I)
+ 893 CONTINUE
+ DO 891 I=1,NPOINT+1
+ DO 892 J=1,NPOINT+1
+ READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
+ 892 CONTINUE
+ 891 CONTINUE
+ CLOSE(10,status='keep')
+ ELSE
+ write(logfid,*)'have to integrate splitting functions, '//
+ &'this may take some time'
+ CALL SPLITFNCINT(EOVEST)
+ INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
+ IF(.NOT.SPLITIEXIST)THEN
+ write(logfid,*)'write splitting integrals to ',FILESPLIT
+ OPEN(unit=10,file=FILESPLIT,status='new')
+ WRITE(10,*)QMAX,ZMMIN,NPOINT
+ DO 896 I=1,NPOINT+1
+ WRITE(10,*) QVAL(I),ZMVAL(I)
+ 896 CONTINUE
+ DO 897 I=1,NPOINT+1
+ DO 898 J=1,NPOINT+1
+ WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
+ 898 CONTINUE
+ 897 CONTINUE
+ CLOSE(10,status='keep')
+ ENDIF
+ ENDIF
+ write(logfid,*)
+
+ INQUIRE(file=PDFFILE,exist=PDFEXIST)
+ IF(PDFEXIST)THEN
+ write(logfid,*)'read pdfs from ',PDFFILE
+ OPEN(unit=10,file=PDFFILE,status='old')
+ DO 872 I=1,2
+ DO 873 J=1,1000
+ READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 873 CONTINUE
+ 872 CONTINUE
+ CLOSE(10,status='keep')
+ ELSE
+ write(logfid,*)'have to integrate pdfs, this may take some time'
+ CALL PDFINT(EOVEST)
+ INQUIRE(file=PDFFILE,exist=PDFEXIST)
+ IF(.NOT.PDFEXIST)THEN
+ write(logfid,*)'write pdfs to ',PDFFILE
+ OPEN(unit=10,file=PDFFILE,status='new')
+ DO 876 I=1,2
+ DO 877 J=1,1000
+ WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 877 CONTINUE
+ 876 CONTINUE
+ CLOSE(10,status='keep')
+ ENDIF
+ ENDIF
+ write(logfid,*)
+
+ INQUIRE(file=XSECFILE,exist=XSECEXIST)
+ IF(XSECEXIST)THEN
+ write(logfid,*)'read cross sections from ',XSECFILE
+ OPEN(unit=10,file=XSECFILE,status='old')
+ DO 881 J=1,1001
+ DO 885 JJ=1,101
+ READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
+ &INTG1(J,JJ),INTG2(J,JJ)
+ 885 CONTINUE
+ 881 CONTINUE
+ CLOSE(10,status='keep')
+ ELSE
+ write(logfid,*)'have to integrate cross sections, '//
+ &'this may take some time'
+ CALL XSECINT(EOVEST)
+ INQUIRE(file=XSECFILE,exist=XSECEXIST)
+ IF(.NOT.XSECEXIST)THEN
+ write(logfid,*)'write cross sections to ',XSECFILE
+ OPEN(unit=10,file=XSECFILE,status='new')
+ DO 883 J=1,1001
+ DO 884 JJ=1,101
+ WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
+ &INTG1(J,JJ),INTG2(J,JJ)
+ 884 CONTINUE
+ 883 CONTINUE
+ CLOSE(10,status='keep')
+ ENDIF
+ ENDIF
+ write(logfid,*)
+ CALL FLUSH(3)
+
+
+
+C--initialise random number generator status
+ IF(NJOB.GT.0)THEN
+ MRPY(1)=NJOB*1000
+ MRPY(2)=0
+ ENDIF
+
+C--Call PYR once for initialization
+ R=PYR(0)
+
+ NDISC=0
+ NGOOD=0
+ NSTRANGE=0
+
+ ERRCOUNT=0
+ errl = 0
+
+ NSCAT=0.d0
+ NSCATEFF=0.d0
+ NSPLIT=0.d0
+ nspliti=0.d0
+ nsplitf=0.d0
+ nistry=0.d0
+ nisfail=0.d0
+ nfstry=0.d0
+ nfsfail=0.d0
+ nttot=0.d0
+ ntrej=0.d0
+
+ ntotspliti=0
+ noverspliti=0
+ ntotpdf=0
+ noverpdf=0
+ ntotxsec=0
+ noverxsec=0
+ ntotsuda=0
+ noversuda=0
+
+ end
+
+
+
+***********************************************************************
+*** subroutine initpythia
+***********************************************************************
+ subroutine initpythia(beam1,beam2)
+ implicit none
+ INTEGER PYCOMP
+ INTEGER NMXHEP
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ INTEGER MSEL,MSELPD,MSUB,KFIN
+ DOUBLE PRECISION CKIN
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ INTEGER MRPY
+ DOUBLE PRECISION RRPY
+C--pdfset
+ common/pdf/pdfset
+ integer pdfset
+C...Alpha_s(M_Z) to be set by hand if communication with LHAPDF doesn't work
+ common/pdfas/pdfalphas
+ double precision pdfalphas
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--event weight exponent
+ COMMON/WEXPO/WEIGHTEX
+ DOUBLE PRECISION WEIGHTEX
+C--memory for error message from getdeltat
+ common/errline/errl
+ integer errl
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--Pythia parameters
+ common/pythiaparams/PTMIN,PTMAX,weighted,mpi,pi0dec
+ double precision PTMIN,PTMAX
+ LOGICAL WEIGHTED,mpi,pi0dec
+
+C--Variables local to this program
+ character*2 beam1,beam2
+
+C--initialise PYTHIA
+C--keep parton shower history in PYJETS
+ MSTP(125)=2
+C--multiple interactions
+ if (mpi) then
+ MSTP(81) = 1
+ else
+ MSTP(81) = 0
+ endif
+C--initial state radiation
+ MSTP(61)=1
+C--switch off final state radiation off partons emitted from space-like shower
+! MSTP(63)=0
+C--switch off final state radiation
+ MSTP(71)=0
+C--No hadronisation (yet)
+ MSTP(111)=0
+C--Lambda_QCD and Q0
+ PARJ(81)=LQCD
+ PARJ(82)=Q0
+C--parameter affecting treatment of string corners
+ PARU(14)=1.
+C--Min shat in simulation
+ CKIN(1)=2.
+C--pT-cut
+ CKIN(3)=PTMIN
+ CKIN(4)=PTMAX
+C--ISR/FSR/UE tune
+ MSTP(5)=0
+
+C...# Tuned flavour parameters:
+ PARJ(1) = 0.073
+ PARJ(2) = 0.2
+ PARJ(3) = 0.94
+ PARJ(4) = 0.032
+ PARJ(11) = 0.31
+ PARJ(12) = 0.4
+ PARJ(13) = 0.54
+ PARJ(25) = 0.63
+ PARJ(26) = 0.12
+C...# Fragmentation tune
+ MSTJ(11) = 5
+ PARJ(21) = 0.325
+ PARJ(41) = 0.5
+ PARJ(42) = 0.6
+ PARJ(47) = 0.67
+ PARJ(81) = 0.29
+ PARJ(82) = 1.65
+
+C--particles stable if lifetime > PARJ(71), default = 10mm
+ MSTJ(22)=2
+C--switch off pi0 decay
+ if (pi0dec) then
+ MDCY(PYCOMP(111),1)=1
+ else
+ MDCY(PYCOMP(111),1)=0
+ endif
+
+C--use LHAPDF
+ MSTP(52)=2
+C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
+C MSTW2008 (LO central) - 21000
+ MSTP(51)=PDFSET
+ IF(COLLIDER.EQ.'PPYQ')THEN
+ MSEL=0
+ MSUB(29)=1
+ ELSEIF(COLLIDER.EQ.'PPYG')THEN
+ MSEL=0
+ MSUB(14)=1
+ MSUB(115)=1
+ ELSEIF(COLLIDER.EQ.'PPYJ')THEN
+ MSEL=0
+ MSUB(14)=1
+ MSUB(29)=1
+ MSUB(115)=1
+ ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')
+ & .or.(COLLIDER.EQ.'PPZG')
+ & .or.(collider.eq.'PPDY'))THEN
+ MSEL=0
+ IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1
+ IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1
+ IF(COLLIDER.EQ.'PPDY') MSUB(1)=1
+ MDME(174,1)=0 !Z decay into d dbar',
+ MDME(175,1)=0 !Z decay into u ubar',
+ MDME(176,1)=0 !Z decay into s sbar',
+ MDME(177,1)=0 !Z decay into c cbar',
+ MDME(178,1)=0 !Z decay into b bbar',
+ MDME(179,1)=0 !Z decay into t tbar',
+ MDME(182,1)=0 !Z decay into e- e+',
+ MDME(183,1)=0 !Z decay into nu_e nu_ebar',
+ MDME(184,1)=0 !Z decay into mu- mu+',
+ MDME(185,1)=0 !Z decay into nu_mu nu_mubar',
+ MDME(186,1)=0 !Z decay into tau- tau+',
+ MDME(187,1)=0 !Z decay into nu_tau nu_taubar',
+ if (channel.EQ.'ELEC')THEN
+ MDME(182,1)=1
+ ELSEIF(channel.EQ.'MUON')THEN
+ MDME(184,1)=1
+ ENDIF
+ ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')
+ & .or.(COLLIDER.EQ.'PPWG'))THEN
+ MSEL=0
+ IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1
+ IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1
+ MDME(190,1)=0 ! W+ decay into dbar u,
+ MDME(191,1)=0 ! W+ decay into dbar c,
+ MDME(192,1)=0 ! W+ decay into dbar t,
+ MDME(194,1)=0 ! W+ decay into sbar u,
+ MDME(195,1)=0 ! W+ decay into sbar c,
+ MDME(196,1)=0 ! W+ decay into sbar t,
+ MDME(198,1)=0 ! W+ decay into bbar u,
+ MDME(199,1)=0 ! W+ decay into bbar c,
+ MDME(200,1)=0 ! W+ decay into bbar t,
+ MDME(202,1)=0 ! W+ decay into b'bar u,
+ MDME(203,1)=0 ! W+ decay into b'bar c,
+ MDME(204,1)=0 ! W+ decay into b'bar t,
+ MDME(206,1)=0 ! W+ decay into e+ nu_e,
+ MDME(207,1)=0 ! W+ decay into mu+ nu_mu,
+ MDME(208,1)=0 ! W+ decay into tau+ nu_tau,
+ MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau,
+ if (channel.EQ.'ELEC')THEN
+ MDME(206,1)=1
+ ELSEIF(channel.EQ.'MUON')THEN
+ MDME(207,1)=1
+ ENDIF
+ ELSE
+C--All QCD processes are active
+ MSEL=1
+ ENDIF
+! MSEL=0
+! MSUB(11)=1
+! MSUB(12)=1
+! MSUB(53)=1
+! MSUB(13)=1
+! MSUB(68)=1
+! MSUB(28)=1
+
+C--weighted events
+ IF(WEIGHTED) MSTP(142)=1
+
+C--number of errors to be printed
+ MSTU(22)=MAX(10,INT(5.*NSIM/100.))
+
+C--number of lines in event record
+ MSTU(4)=23000
+! MSTU(5)=23000
+ MSTU(5)=10000
+
+C--initialisation call
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ OFFSET=9
+ CALL PYINIT('CMS',beam1,beam2,sqrts)
+ ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR.
+ & (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN
+ OFFSET=8
+ CALL PYINIT('CMS',beam1,beam2,sqrts)
+ ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or.
+ & (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or.
+ & (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN
+ OFFSET=10
+ CALL PYINIT('CMS',beam1,beam2,sqrts)
+ elseif (collider.eq.'PPDY') then
+ CALL PYINIT('CMS',beam1,beam2,sqrts)
+ ENDIF
+
+ end
+
+
+
+***********************************************************************
+*** subroutine genevent
+***********************************************************************
+ subroutine genevent(j,b1,b2)
+ implicit none
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ INTEGER PYCOMP
+ INTEGER NMXHEP
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ INTEGER MSEL,MSELPD,MSUB,KFIN
+ DOUBLE PRECISION CKIN
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ INTEGER MRPY
+ DOUBLE PRECISION RRPY
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--event weight exponent
+ COMMON/WEXPO/WEIGHTEX
+ DOUBLE PRECISION WEIGHTEX
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--production point
+ common/jetpoint/x0,y0
+ double precision x0,y0
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--extra storage for scattering centres before interactions
+ common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
+ &scatcen(23000,5),writescatcen,writedummies
+ integer nscatcen,maxnscatcen,scatflav
+ double precision scatcen
+ logical writescatcen,writedummies
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--Variables local to this program
+ INTEGER NOLD,PID,IPART,j,i
+ integer nnew,lprev,l1,l2,l3,lstart,jj,ii,ntmp,slen
+ DOUBLE PRECISION PYR,R,Z1,Z2,getltimemax,pi,lambda,q1,q2,
+ &pymass,pyp
+ character*2 b1,b2
+ LOGICAL WHICH1,WHICH2,isparton
+ DATA PI/3.141592653589793d0/
+
+ N=0
+ COLMAX=600
+ DISCARD=.FALSE.
+ DO 91 I=1,23000
+ MV(I,1)=0.d0
+ MV(I,2)=0.d0
+ MV(I,3)=0.d0
+ MV(I,4)=0.d0
+ MV(I,5)=0.d0
+ ZA(I)=0.d0
+ ZD(I)=0.d0
+ THETAA(I)=0.d0
+ QQBARD(I)=.FALSE.
+ 91 CONTINUE
+ nscatcen = 0
+
+ CALL MEDNEXTEVT
+
+C--initialisation with matrix element
+C--production vertex
+ CALL PICKVTX(X0,Y0)
+ LTIME=GETLTIMEMAX()
+
+ 99 CALL PYEVNT
+ NPART=N-OFFSET
+ EVWEIGHT=PARI(10)
+ SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
+ IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN
+ WDISC=WDISC+EVWEIGHT
+ NDISC=NDISC+1
+ GOTO 102
+ ELSE
+ NGOOD=NGOOD+1
+ ENDIF
+
+! call pevrec(3,.false.)
+! write(logfid,*)'Number of scatterings:', MSTI(31)
+! call exit(1)
+
+C--DY: don't have to do anything
+ if (collider.eq.'PPDY') then
+ CALL PYEXEC
+ call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
+ goto 102
+ endif
+
+
+C--prepare event record
+ call interpretpyhtiaevent(ltime,x0,y0)
+
+ call findspeclines()
+
+ call setcolour()
+
+C--set status codes
+ if (k(lme1,1).lt.11) K(LME1,1)=1
+ if (k(lme2,1).lt.11) K(LME2,1)=1
+ PID=K(LME1,2)
+ DO 183 IPART=OFFSET+1, OFFSET+NPART
+ IF((IPART.NE.LME1).AND.(IPART.NE.LME2)
+ & .AND.(K(IPART,1).LT.11)) then
+ if (p(ipart,5).gt.pymass(k(ipart,2))) then
+ k(ipart,1)=1
+ else
+ if ((isparton(k(ipart,2))).and.
+ & (abs(pyp(ipart,19)).lt.etamax)) then
+ if (p(ipart,5).gt.0.d0) call makemassless(ipart,lme1,lme2)
+ k(ipart,1)=1
+ else
+ k(ipart,1)=4
+ endif
+ endif
+ endif
+ if (k(ipart,2).eq.22) k(ipart,1)=4
+C--let (semi-)hard partons from MPI's interact in background medium
+! if ((k(ipart,3).eq.0).and.(abs(k(ipart,2)).lt.22)) k(ipart,1)=1
+C--end MPI treatment
+ 183 CONTINUE
+
+ call findvirtualities(0,0,x0,y0,.false.)
+
+ call findmpivirtualities(x0,y0)
+
+! write(logfid,*)'after finding virtualities'
+! call pevrec(2,.false.)
+
+ call storeinitpt(z1,z2)
+
+! call pevrec(3,.false.)
+! write(logfid,*)'Number of scatterings:', MSTI(31)
+
+C--develop parton shower
+ CALL MAKECASCADE
+ IF(DISCARD) THEN
+ NGOOD=NGOOD-1
+ WDISC=WDISC+EVWEIGHT
+ NDISC=NDISC+1
+ write(logfid,*)'discard event',J
+ GOTO 102
+ ENDIF
+
+ IF(.NOT.ALLHAD)THEN
+ DO 86 I=1,N
+ IF(K(I,1).EQ.3) K(I,1)=22
+ 86 CONTINUE
+ ENDIF
+ IF(HADRO)THEN
+ CALL MAKESTRINGS(HADROTYPE)
+! call combinegluons()
+ IF(DISCARD) THEN
+ write(logfid,*)'discard event',J
+ WDISC=WDISC+EVWEIGHT
+ NDISC=NDISC+1
+ NGOOD=NGOOD-1
+ GOTO 102
+ ENDIF
+ CALL PYEXEC
+ IF(MSTU(30).NE.ERRCOUNT)THEN
+ write(logfid,*)'PYTHIA discards event',J,
+ & ' (error number',MSTU(30),')'
+ ERRCOUNT=MSTU(30)
+ WDISC=WDISC+EVWEIGHT
+ NDISC=NDISC+1
+ NGOOD=NGOOD-1
+ GOTO 102
+ ENDIF
+ ENDIF
+
+! DO 888 I=1,N
+! IF(K(I,2).EQ.94)THEN
+! NGOOD=NGOOD-1
+! NSTRANGE=NSTRANGE+1
+! NDISC=NDISC+1
+! call pevrec(2,.false.)
+! GOTO 102
+! ENDIF
+! 888 CONTINUE
+ IF(MSTU(30).NE.ERRCOUNT)THEN
+ ERRCOUNT=MSTU(30)
+ ELSE
+ CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2)
+ ENDIF
+
+C--write message to log-file
+ 102 IF(NSIM.GT.100)THEN
+ IF(MOD(J,NSIM/100).EQ.0)THEN
+ write(logfid,*) 'done with event number ',J,
+ & PARI(1), (sumofweights-wdisc)/j
+ ENDIF
+ else
+ write(logfid,*) 'done with event number ',J
+ ENDIF
+ call flush(logfid)
+ end
+
+
+***********************************************************************
+*** subroutine interpretpyhtiaevent
+***********************************************************************
+ SUBROUTINE interpretpyhtiaevent(ltime,x0,y0)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ INTEGER PYCOMP
+ INTEGER NMXHEP
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--local parameters
+ integer nnew,lstart,i,lprev,jj,l1,l2,l3,ntmp,mother,slen
+ double precision ltime,x0,y0,lambda,pyr,pyp,pymass
+ logical isparton,onlyzeros,recomb,isdiquark
+
+C--special treatment for Jeweling intial state radiation (currently only available for di-jets)
+ if (collider.eq.'PPJJ') then
+! write(logfid,*)'begin special treatment'
+! call pevrec(2,.false.)
+C--find non-strongly interacting particles and move them up first
+ nnew=8
+ do 300 i=107,n
+ if ((k(i,1).le.2).and.(.not.isparton(k(i,2)))) then
+ k(i,1)=11
+ nnew=nnew+1
+ call copyline(i,nnew,0)
+ endif
+ 300 continue
+C--walk backwards from ME to beam and set production vertices and times
+ do 400 i=0,1
+ lstart=105+i
+ lambda=1.d0/(ftfac*p(lstart,4)*0.2/p(lstart,5)**2)
+ if (isrscat) then
+ mv(lstart,5)=0.d0
+ else
+ mv(lstart,5)=-1.d6
+ endif
+ mv(lstart,4)=mv(lstart,5) + log(1.d0-pyr(0))/lambda
+ mv(lstart,1)=x0 +
+ & mv(lstart,4)*p(lstart,1)/max(pyp(lstart,8),p(lstart,4))
+ mv(lstart,2)=y0 +
+ & mv(lstart,4)*p(lstart,2)/max(pyp(lstart,8),p(lstart,4))
+ mv(lstart,3)=
+ & mv(lstart,4)*p(lstart,3)/max(pyp(lstart,8),p(lstart,4))
+ lprev=lstart
+ l1=k(lprev,3)
+ do while (k(lprev,3).gt.4)
+ do 302 jj=105,n
+ if (k(jj,3).eq.l1) l2=jj
+ 302 continue
+ if ((k(l1,3).eq.3).or.(k(l1,3).eq.4)) then
+ mv(l1,1)=1.d6
+ mv(l1,2)=1.d6
+ if (k(l1,3).eq.3) then
+ mv(l1,3)=1.d6
+ else
+ mv(l1,3)=-1.d6
+ endif
+ mv(l1,4)=-1.d6
+ mv(l1,5)=mv(lprev,4)
+ else
+ lambda=1.d0/(ftfac*p(l1,4)*0.2/p(l1,5)**2)
+ mv(l1,4)=mv(lprev,4) + log(1.d0-pyr(0))/lambda
+ mv(l1,5)=mv(lprev,4)
+ mv(l1,1)=mv(lprev,1) +
+ & (mv(l1,4)-mv(l1,5))*p(l1,1)/max(pyp(l1,8),p(l1,4))
+ mv(l1,2)=mv(lprev,2) +
+ & (mv(l1,4)-mv(l1,5))*p(l1,2)/max(pyp(l1,8),p(l1,4))
+ mv(l1,3)=mv(lprev,3) +
+ & (mv(l1,4)-mv(l1,5))*p(l1,3)/max(pyp(l1,8),p(l1,4))
+ endif
+ mv(l2,4)=mv(lprev,4)
+ if (p(l2,5).eq.pymass(k(l2,2))) then
+ mv(l2,5)=ltime
+ else
+ lambda=1.d0/(ftfac*p(l2,4)*0.2/p(l2,5)**2)
+ mv(l2,5)=mv(lprev,4) - log(1.d0-pyr(0))/lambda
+ endif
+ mv(l2,1)=mv(lprev,1)
+ mv(l2,2)=mv(lprev,2)
+ mv(l2,3)=mv(lprev,3)
+ lprev=l1
+ l1=k(lprev,3)
+ end do
+ 400 continue
+! call pevrec(3,.false.)
+C--order all singlets from triplet to antitriplet
+ do 401 i=lstart,n
+ if ((k(i,1).eq.2).and.
+ & ((k(i,2).lt.0).or.isdiquark(k(i,2)))) then
+ ntmp=n
+ do 402 jj=i,n
+ ntmp=ntmp+1
+ call copyline(jj,ntmp,1)
+ k(ntmp,3)=k(jj,3)
+ if (k(jj,1).eq.1) goto 403
+ 402 continue
+ 403 do 404 jj=0,ntmp-n-1
+ call copyline(ntmp-jj,i+jj,1)
+ k(i+jj,3)=k(ntmp-jj,3)
+ if (jj.eq.ntmp-n-1) then
+ k(i+jj,1)=1
+ else
+ k(i+jj,1)=2
+ endif
+ 404 continue
+! write(logfid,*)'had to change order of singlets'
+! call pevrec(3,.false.)
+ endif
+ 401 continue
+C--undo final state splittings
+ lstart=0
+ do 303 i=107,n
+ if ((lstart.eq.0).and.(k(i,1).le.2)) lstart=i
+ if (k(i,1).le.2) then
+ do 310 jj=1,5
+ mv(i,jj)=mv(k(i,3),jj)
+ 310 continue
+ k(i,3)=k(k(i,3),3)
+ endif
+ 303 continue
+! write(logfid,*)'start undoing FS splittings'
+! call pevrec(3,.false.)
+ recomb=.true.
+ do while (recomb)
+ recomb=.false.
+ do 304 i=lstart,n
+ if (k(i,3).gt.106) then
+ onlyzeros=.true.
+ do 307 jj=i+1,n
+ if (k(i,3).eq.k(jj,3)) then
+ l1=i
+ l2=jj
+ recomb=.true.
+ goto 308
+ else
+ if ((jj.gt.i+1).and.(k(jj,1).gt.0)) onlyzeros=.false.
+ endif
+ 307 continue
+ endif
+ 304 continue
+ 308 if (recomb) then
+ if (onlyzeros) then
+! write(logfid,*)'normal recombination step',l1,l2
+ if (k(k(l1,3),2).eq.21) then
+ zd(l1)=p(l1,4)/p(k(l1,3),4)
+ if (k(l1,2).ne.21) then
+ qqbard(l1)=.true.
+ else
+ qqbard(l1)=.false.
+ endif
+ else
+ if (k(l1,2).eq.21) then
+ zd(l1)=p(l2,4)/p(k(l2,3),4)
+ else
+ zd(l1)=p(l1,4)/p(k(l1,3),4)
+ endif
+ qqbard(l1)=.false.
+ endif
+ do 305 i=1,5
+ p(l1,i)=p(k(l1,3),i)
+ 305 continue
+ k(l1,2)=k(k(l1,3),2)
+ k(l1,3)=k(k(l1,3),3)
+ if (k(l1,2).eq.21) k(l1,1)=2
+ if (k(l2,1).eq.1) k(l1,1)=1
+ k(l2,1)=0
+ else
+C--have to change order in which singlets appear
+! write(logfid,*)'have to change order of singlets',l1,l2
+ if (k(l1,1).eq.2) then
+ ntmp=n
+ do 405 i=l1,n
+ ntmp=ntmp+1
+ call copyline(i,ntmp,1)
+ k(ntmp,3)=k(i,3)
+ if (k(i,1).eq.1) goto 406
+ 405 continue
+ 406 continue
+ slen=ntmp-n
+ do 407 i=l1+slen,l2
+ call copyline(i,i-slen,1)
+ k(i-slen,3)=k(i,3)
+ 407 continue
+ do 408 i=1,slen
+ call copyline(n+i,l2-slen+i,1)
+ k(l2-slen+i,3)=k(n+i,3)
+ 408 continue
+ else
+ do 410 i=1,l1-lstart
+ if ((k(l1-i,2).ne.21).and.(k(l1-i,1).ne.0)) then
+ l3=l1-i
+ goto 411
+ endif
+ 410 continue
+ 411 ntmp=n
+ do 415 i=l3,l1
+ ntmp=ntmp+1
+ call copyline(i,ntmp,1)
+ k(ntmp,3)=k(i,3)
+ 415 continue
+ slen=ntmp-n
+ do 417 i=l3+slen,l2-1
+ call copyline(i,i-slen,1)
+ k(i-slen,3)=k(i,3)
+ 417 continue
+ do 418 i=1,slen
+ call copyline(n+i,l2-slen-1+i,1)
+ k(l2-slen-1+i,3)=k(n+i,3)
+ 418 continue
+ endif
+ endif
+ endif
+! write(logfid,*)'after one iteration'
+! call pevrec(3,.false.)
+ end do
+! write(logfid,*)'before copying everything up'
+! call pevrec(3,.false.)
+C--copy remaining lines to top of event record
+ do 309 jj=lstart,n
+ if(k(jj,1).gt.0) then
+ if ((k(jj,3).gt.106).and.
+ & (p(jj,5).ne.pymass(k(jj,2)))) then
+ do 311 i=1,5
+ mv(jj,i)=mv(k(jj,3),i)
+ 311 continue
+ endif
+ if ((k(jj,3).eq.1).or.(k(jj,3).eq.2)) then
+ mv(jj,1)=x0
+ mv(jj,2)=y0
+ mv(jj,3)=0.d0
+ mv(jj,4)=0.d0
+ mv(jj,5)=ltime
+ endif
+ nnew=nnew+1
+ call copyline(jj,nnew,1)
+ if (k(jj,3).lt.100) then
+ k(nnew,3)=k(jj,3)
+ else
+ mother=k(jj,3)
+ do while (mother.gt.100)
+ mother=k(mother,3)
+ end do
+ k(nnew,3)=mother
+ endif
+ za(nnew)=1.d0
+ zd(nnew)=zd(jj)
+ qqbard(nnew)=qqbard(jj)
+ thetaa(nnew)=p(nnew,5)/
+ & (sqrt(zd(nnew)*(1.-zd(nnew)))*p(nnew,4))
+ endif
+ 309 continue
+ n=nnew
+ NPART=N-OFFSET
+ endif
+
+! write(logfid,*)'end special treatment'
+! call pevrec(3,.false.)
+! call flush(logfid)
+! call exit(1)
+C--end special treatment
+ end
+
+
+***********************************************************************
+*** subroutine findspeclines
+***********************************************************************
+ subroutine findspeclines()
+ implicit none
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--local variables
+ integer ipart
+
+c--preparatory steps
+ if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
+ & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
+ & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
+ LME1ORIG=7
+ LME2ORIG=8
+ if(abs(k(7,2)).gt.21) then
+ lv=7
+ else
+ lv=8
+ endif
+ ELSE
+ LME1ORIG=OFFSET-1
+ LME2ORIG=OFFSET
+ ENDIF
+ DO 181 IPART=OFFSET+1, OFFSET+NPART
+C--find decay leptons in V+jet events
+ if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
+ & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
+ & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN
+ if(k(ipart,3).eq.offset-1) llep1=ipart
+ if(k(ipart,3).eq.offset) llep2=ipart
+ endif
+ IF(K(IPART,3).EQ.(LME1ORIG))THEN
+ LME1=IPART
+ IF(K(IPART,2).EQ.21)THEN
+ TYPE1='GC'
+ ELSE
+ TYPE1='QQ'
+ ENDIF
+ ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN
+ LME2=IPART
+ IF(K(IPART,2).EQ.21)THEN
+ TYPE2='GC'
+ ELSE
+ TYPE2='QQ'
+ ENDIF
+ ENDIF
+ 181 continue
+ end
+
+
+
+***********************************************************************
+*** subroutine setcolour
+***********************************************************************
+ subroutine setcolour()
+ implicit none
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--local variables
+ integer ipart
+ logical firsttrip,isdiquark
+
+
+ DO 180 IPART=OFFSET+1, OFFSET+NPART
+ IF(K(IPART,3).NE.(LME1ORIG).and.(K(IPART,3).NE.LME2ORIG))THEN
+ TRIP(IPART)=0
+ ANTI(IPART)=0
+ ENDIF
+C--assign colour indices
+ IF(K(IPART,1).EQ.2)THEN
+ IF(K(IPART-1,1).EQ.2)THEN
+C--in middle of colour singlet
+ IF(FIRSTTRIP)THEN
+ TRIP(IPART)=COLMAX+1
+ ANTI(IPART)=TRIP(IPART-1)
+ ELSE
+ TRIP(IPART)=ANTI(IPART-1)
+ ANTI(IPART)=COLMAX+1
+ ENDIF
+ COLMAX=COLMAX+1
+ ELSE
+C--beginning of colour singlet
+ IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0))
+ & .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN
+ TRIP(IPART)=COLMAX+1
+ ANTI(IPART)=0
+ FIRSTTRIP=.TRUE.
+ ELSE
+ TRIP(IPART)=0
+ ANTI(IPART)=COLMAX+1
+ FIRSTTRIP=.FALSE.
+ ENDIF
+ COLMAX=COLMAX+1
+ ENDIF
+ ENDIF
+ IF(K(IPART,1).EQ.1)THEN
+C--end of colour singlet
+ IF(FIRSTTRIP)THEN
+ TRIP(IPART)=0
+ ANTI(IPART)=TRIP(IPART-1)
+ ELSE
+ TRIP(IPART)=ANTI(IPART-1)
+ ANTI(IPART)=0
+ ENDIF
+ ENDIF
+ 180 CONTINUE
+ end
+
+
+***********************************************************************
+*** subroutine findvirtualities
+***********************************************************************
+ SUBROUTINE findvirtualities(line1,line2,x0,y0,mpiscat)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--local variables
+ integer line1,line2,l1,l2
+ double precision qmax1,qmax2,emax,theta1,theta2,en1,en2,beta(3),
+ &etot,m1,m2,p21,p22,weight,q1,q2,enew1,enew2,eps1,eps2,pold,
+ &z1,z2,getmass,pyr,pyp,x0,y0,lambda
+ double precision x1,x2,x3,meweight,psweight
+ logical mpiscat,which1,which2
+
+
+C--find virtualities and adapt four-vectors
+ l1=lme1
+ l2=lme2
+ if(((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
+ & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
+ & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG')).and.
+ & (.not.mpiscat))THEN
+ if (abs(k(l1,2)).gt.21) then
+ QMAX1=0.d0
+ QMAX2=sqrt(pari(18)+p(l1,5)**2)
+ else
+ QMAX1=sqrt(pari(18)+p(l2,5)**2)
+ QMAX2=0.d0
+ endif
+ EMAX=P(L1,4)+P(L2,4)
+ THETA1=-1.d0
+ THETA2=-1.d0
+ ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ')
+ & .OR.(COLLIDER.EQ.'PPYQ').OR.(COLLIDER.EQ.'PPYG')
+ & .or.mpiscat)THEN
+ if (mpiscat) then
+ l1=line1
+ l2=line2
+ endif
+ if ((k(l1,1).eq.4).or.(mpiscat.and.(.not.mpifsr))) then
+ qmax1 = 0.d0
+ else
+ if (mpiscat) then
+ QMAX1=PYP(L1,10)*exp(0.3*abs(pyp(l1,17)-pyp(l2,17))/2.)/2.
+ else
+ QMAX1=pari(17)
+ endif
+ endif
+ if ((k(l2,1).eq.4).or.(mpiscat.and.(.not.mpifsr))) then
+ qmax2 = 0.d0
+ else
+ if (mpiscat) then
+ QMAX2=PYP(L2,10)*exp(0.3*abs(pyp(l1,17)-pyp(l2,17))/2.)/2.
+ else
+ QMAX2=pari(17)
+ endif
+ endif
+! QMAX1=PYP(L1,10)*exp(0.3*abs(pyp(l1,17)-pyp(l2,17))/2.)/2.
+! QMAX2=PYP(L2,10)*exp(0.3*abs(pyp(l1,17)-pyp(l2,17))/2.)/2.
+ EMAX=P(L1,4)+P(L2,4)
+ THETA1=-1.d0
+ THETA2=-1.d0
+ ENDIF
+ EN1=P(L1,4)
+ EN2=P(L2,4)
+ BETA(1)=(P(L1,1)+P(L2,1))/(P(L1,4)+P(L2,4))
+ BETA(2)=(P(L1,2)+P(L2,2))/(P(L1,4)+P(L2,4))
+ BETA(3)=(P(L1,3)+P(L2,3))/(P(L1,4)+P(L2,4))
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ ETOT=P(L1,4)+P(L2,4)
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ QMAX1=ETOT
+ QMAX2=ETOT
+ EMAX=P(L1,4)+P(L2,4)
+ THETA1=-1.d0
+ THETA2=-1.d0
+ ENDIF
+C--find virtuality
+ Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
+ & Z1,WHICH1)
+ Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
+ & Z2,WHICH2)
+ 182 if (abs(k(l1,2)).gt.21) then
+ m1=p(l1,5)
+ else
+ m1=q1
+ endif
+ if (abs(k(l2,2)).gt.21) then
+ m2=p(l2,5)
+ else
+ m2=q2
+ endif
+ ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT)
+ ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT)
+ P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2
+ P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2
+ WEIGHT=1.d0
+ IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0)
+ & .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0)
+ & )THEN
+ IF(Q1.GT.Q2)THEN
+ Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
+ & Z1,WHICH1)
+ ELSE
+ Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
+ & Z2,WHICH2)
+ ENDIF
+ GOTO 182
+ ENDIF
+ POLD=PYP(L1,8)
+ P(L1,1)=P(L1,1)*SQRT(P21)/POLD
+ P(L1,2)=P(L1,2)*SQRT(P21)/POLD
+ P(L1,3)=P(L1,3)*SQRT(P21)/POLD
+ P(L1,4)=ENEW1
+ P(L1,5)=m1
+ POLD=PYP(L2,8)
+ P(L2,1)=P(L2,1)*SQRT(P22)/POLD
+ P(L2,2)=P(L2,2)*SQRT(P22)/POLD
+ P(L2,3)=P(L2,3)*SQRT(P22)/POLD
+ P(L2,4)=ENEW2
+ P(L2,5)=m2
+ CALL PYROBO(L1,L1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,BETA(1),BETA(2),BETA(3))
+C--correct for overestimated energy
+ IF(Q1.GT.0.d0)THEN
+ EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
+ & *SQRT(1.-Q1**2/P(L1,4)**2)
+ IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
+ Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
+ & Z1,WHICH1)
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ GOTO 182
+ ENDIF
+ ENDIF
+ IF(Q2.GT.0.d0)THEN
+ EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
+ & *SQRT(1.-Q2**2/P(L2,4)**2)
+ IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
+ Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
+ & Z2,WHICH2)
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ GOTO 182
+ ENDIF
+ ENDIF
+
+C--correct to ME for first parton
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ BETA(1)=(P(L1,1)+P(L2,1))/(P(L1,4)+P(L2,4))
+ BETA(2)=(P(L1,2)+P(L2,2))/(P(L1,4)+P(L2,4))
+ BETA(3)=(P(L1,3)+P(L2,3))/(P(L1,4)+P(L2,4))
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ IF(Q1.GT.0.d0)THEN
+C--generate z value
+ X1=Z1*(ETOT**2+Q1**2)/ETOT**2
+ X2=(ETOT**2-Q1**2)/ETOT**2
+ X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2
+ PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
+ & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
+ MEWEIGHT=X1**2+X2**2
+ WEIGHT=MEWEIGHT/PSWEIGHT
+ IF(PYR(0).GT.WEIGHT)THEN
+ 184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
+ & Z1,WHICH1)
+ ENDIF
+ ENDIF
+C--correct to ME for second parton
+ IF(Q2.GT.0.d0)THEN
+C--generate z value
+ X1=(ETOT**2-Q2**2)/ETOT**2
+ X2=Z2*(ETOT**2+Q2**2)/ETOT**2
+ X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2
+ PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3
+ & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3
+ MEWEIGHT=X1**2+X2**2
+ WEIGHT=MEWEIGHT/PSWEIGHT
+ IF(PYR(0).GT.WEIGHT)THEN
+ 185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
+ & Z2,WHICH2)
+ ENDIF
+ ENDIF
+ 186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT)
+ ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT)
+ P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2
+ P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2
+ POLD=PYP(L1,8)
+ P(L1,1)=P(L1,1)*SQRT(P21)/POLD
+ P(L1,2)=P(L1,2)*SQRT(P21)/POLD
+ P(L1,3)=P(L1,3)*SQRT(P21)/POLD
+ P(L1,4)=ENEW1
+ P(L1,5)=Q1
+ POLD=PYP(L2,8)
+ P(L2,1)=P(L2,1)*SQRT(P22)/POLD
+ P(L2,2)=P(L2,2)*SQRT(P22)/POLD
+ P(L2,3)=P(L2,3)*SQRT(P22)/POLD
+ P(L2,4)=ENEW2
+ P(L2,5)=Q2
+ CALL PYROBO(L1,L1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,BETA(1),BETA(2),BETA(3))
+C--correct for overestimated energy
+ IF(Q1.GT.0.d0)THEN
+ EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2)
+ & *SQRT(1.-Q1**2/P(L1,4)**2)
+ IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN
+ Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE.,
+ & Z1,WHICH1)
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ GOTO 186
+ ENDIF
+ ENDIF
+ IF(Q2.GT.0.d0)THEN
+ EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2)
+ & *SQRT(1.-Q2**2/P(L2,4)**2)
+ IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN
+ Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE.,
+ & Z2,WHICH2)
+ CALL PYROBO(L1,L1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(L2,L2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ GOTO 186
+ ENDIF
+ ENDIF
+ ENDIF
+
+C--transfer recoil to decay leptons in V+jet
+ if(((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or.
+ & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or.
+ & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG')).and.
+ & (.not.mpiscat))THEN
+ beta(1)=p(lv,1)/p(lv,4)
+ beta(2)=p(lv,2)/p(lv,4)
+ beta(3)=p(lv,3)/p(lv,4)
+ CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ if (abs(k(l1,2)).gt.21) then
+ beta(1)=p(l1,1)/p(l1,4)
+ beta(2)=p(l1,2)/p(l1,4)
+ beta(3)=p(l1,3)/p(l1,4)
+ else
+ beta(1)=p(l2,1)/p(l2,4)
+ beta(2)=p(l2,2)/p(l2,4)
+ beta(3)=p(l2,3)/p(l2,4)
+ endif
+ CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ endif
+
+ ZA(L1)=1.d0
+ ZA(L2)=1.d0
+ THETAA(L1)=P(L1,5)/(SQRT(Z1*(1.-Z1))*P(L1,4))
+ THETAA(L2)=P(L2,5)/(SQRT(Z2*(1.-Z2))*P(L2,4))
+ ZD(L1)=Z1
+ ZD(L2)=Z2
+ QQBARD(L1)=WHICH1
+ QQBARD(L2)=WHICH2
+
+ MV(L1,1)=X0
+ MV(L1,2)=Y0
+ MV(L1,3)=0.d0
+ MV(L1,4)=0.d0
+ IF(P(L1,5).GT.0.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(L1,4)*0.2/Q1**2)
+ MV(L1,5)=-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(L1,5)=LTIME
+ ENDIF
+
+ MV(L2,1)=X0
+ MV(L2,2)=Y0
+ MV(L2,3)=0.d0
+ MV(L2,4)=0.d0
+ IF(P(L2,5).GT.0.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(L2,4)*0.2/Q2**2)
+ MV(L2,5)=-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(L2,5)=LTIME
+ ENDIF
+
+ end
+
+
+***********************************************************************
+*** subroutine findmpivirtualities
+***********************************************************************
+ SUBROUTINE findmpivirtualities(x0,y0)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--local variables
+ integer i,j
+ double precision x0,y0,pyp
+
+ do 200 i=offset+1, offset+npart
+C--check whether this is an mpi parton
+ if (k(i,3).eq.0) then
+C--find partner parton from same scattering
+ do 201 j=i+1, offset+npart
+ if (abs(pyp(i,10)-pyp(j,10)).lt.1.d-4) then
+ call findvirtualities(i,j,x0,y0,.true.)
+ goto 200
+ endif
+ 201 continue
+ endif
+ 200 continue
+ end
+
+***********************************************************************
+*** subroutine storeinitpt
+***********************************************************************
+ SUBROUTINE storeinitpt(z1,z2)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--initial pt and virtuality
+ common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
+ &inz(2),intheta(2)
+ integer isgluon
+ double precision inpt,inmass,inphi,ineta,inz,intheta
+C--special lines in event record
+ common/speclines/lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig,
+ &type1,type2
+ integer lme1,lme2,lv,llep1,llep2,lme1orig,lme2orig
+ character*2 type1,type2
+
+C--local variables
+ double precision z1,z2,pyp
+
+C--store initial parton pt and mass for output
+ if (k(lme1,1).eq.1) then
+ inpt(1) = pyp(lme1,10)
+! inpt(1) = p(lme1,4)*sin(pyp(lme1,13))
+ inmass(1) = p(lme1,5)
+ inphi(1) = pyp(lme1,15)
+ ineta(1) = pyp(lme1,19)
+ inpt(2) = pyp(lme2,10)
+! inpt(2) = p(lme2,4)*sin(pyp(lme2,13))
+ inmass(2) = p(lme2,5)
+ inphi(2) = pyp(lme2,15)
+ ineta(2) = pyp(lme2,19)
+ if (k(lme1,2).eq.21) then
+ isgluon(1) = 1
+ elseif (abs(k(lme1,2)).le.5) then
+ isgluon(1) = 0
+ else
+ isgluon(1) = 2
+ endif
+ if (k(lme2,2).eq.21) then
+ isgluon(2) = 1
+ elseif (abs(k(lme2,2)).le.5) then
+ isgluon(2) = 0
+ else
+ isgluon(2) = 2
+ endif
+ inz(1) = z1
+ inz(2) = z2
+ if(z1.gt.0.d0) then
+ intheta(1) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
+ else
+ intheta(1) = 0.d0
+ endif
+ if(z2.gt.0.d0) then
+ intheta(2) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
+ else
+ intheta(2) = 0.d0
+ endif
+ else
+ inpt(1) = pyp(lme2,10)
+! inpt(1) = p(lme2,4)*sin(pyp(lme2,13))
+ inmass(1) = p(lme2,5)
+ inphi(1) = pyp(lme2,15)
+ ineta(1) = pyp(lme2,19)
+ inpt(2) = pyp(lme1,10)
+! inpt(2) = p(lme1,4)*sin(pyp(lme1,13))
+ inmass(2) = p(lme1,5)
+ inphi(2) = pyp(lme1,15)
+ ineta(2) = pyp(lme1,19)
+ if (k(lme2,2).eq.21) then
+ isgluon(1) = 1
+ elseif (abs(k(lme2,2)).le.5) then
+ isgluon(1) = 0
+ else
+ isgluon(1) = 2
+ endif
+ if (k(lme1,2).eq.21) then
+ isgluon(2) = 1
+ elseif (abs(k(lme1,2)).le.5) then
+ isgluon(2) = 0
+ else
+ isgluon(2) = 2
+ endif
+ inz(1) = z2
+ inz(2) = z1
+ if(z2.gt.0.d0) then
+ intheta(1) = P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4))
+ else
+ intheta(1) = 0.d0
+ endif
+ if(z1.gt.0.d0) then
+ intheta(2) = P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4))
+ else
+ intheta(2) = 0.d0
+ endif
+ endif
+ end
+
+***********************************************************************
+*** subroutine makestrings
+***********************************************************************
+ SUBROUTINE MAKESTRINGS(WHICH)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ INTEGER WHICH
+ IF(WHICH.EQ.0)THEN
+ CALL MAKESTRINGS_VAC
+ ELSEIF(WHICH.EQ.1)THEN
+ CALL MAKESTRINGS_MINL
+ ELSE
+ WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS'
+ ENDIF
+ END
+
+
+***********************************************************************
+*** subroutine makestrings_vac
+***********************************************************************
+ SUBROUTINE MAKESTRINGS_VAC
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--local variables
+ INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1
+ DOUBLE PRECISION EADDEND,PYR,DIR
+ LOGICAL ISDIQUARK,compressevent,roomleft
+ DATA EADDEND/10.d0/
+
+ i = 0
+ if (compress) roomleft = compressevent(i)
+ NOLD1=N
+C--remove all active lines that are leptons, gammas, hadrons etc.
+ DO 52 I=1,NOLD1
+ IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
+C--copy line to end of event record
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=11
+ K(N,2)=K(I,2)
+ K(N,3)=I
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(I,1)
+ P(N,2)=P(I,2)
+ P(N,3)=P(I,3)
+ P(N,4)=P(I,4)
+ P(N,5)=P(I,5)
+ K(I,1)=17
+ K(I,4)=N
+ K(I,5)=N
+ TRIP(N)=TRIP(I)
+ ANTI(N)=ANTI(I)
+ ENDIF
+ 52 CONTINUE
+ NOLD=N
+C--first do strings with existing (anti)triplets
+C--find string end (=quark or antiquark)
+ 43 LQUARK=0
+ DO 40 I=1,NOLD
+ IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
+ & .OR.(K(I,1).EQ.14)) K(I,1)=17
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR.
+ & (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN
+ LQUARK=I
+ GOTO 41
+ ENDIF
+ 40 CONTINUE
+ GOTO 50
+ 41 CONTINUE
+C--copy string end to end of event record
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=2
+ K(N,2)=K(LQUARK,2)
+ K(N,3)=LQUARK
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(LQUARK,1)
+ P(N,2)=P(LQUARK,2)
+ P(N,3)=P(LQUARK,3)
+ P(N,4)=P(LQUARK,4)
+ P(N,5)=P(LQUARK,5)
+ K(LQUARK,1)=16
+ K(LQUARK,4)=N
+ K(LQUARK,5)=N
+ TRIP(N)=TRIP(LQUARK)
+ ANTI(N)=ANTI(LQUARK)
+C--append matching colour partner
+ LMATCH=0
+ DO 44 J=1,10000000
+ DO 42 I=1,NOLD
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
+ & .OR.(K(I,1).EQ.5))
+ & .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0))
+ & .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,2)=K(I,2)
+ K(N,3)=I
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(I,1)
+ P(N,2)=P(I,2)
+ P(N,3)=P(I,3)
+ P(N,4)=P(I,4)
+ P(N,5)=P(I,5)
+ TRIP(N)=TRIP(I)
+ ANTI(N)=ANTI(I)
+ K(I,1)=16
+ K(I,4)=N
+ K(I,5)=N
+ IF(K(I,2).EQ.21)THEN
+ K(N,1)=2
+ GOTO 44
+ ELSE
+ K(N,1)=1
+ GOTO 43
+ ENDIF
+ ENDIF
+ 42 CONTINUE
+C--no matching colour partner found
+ write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
+ &'colour singlet system, will discard event',n,trip(n),anti(n),i
+ call pevrec(2,.true.)
+ discard = .true.
+ return
+ 44 CONTINUE
+C--now take care of purely gluonic remainder system
+C-----------------------------------------
+C--find gluon where anti-triplet is not matched
+ 50 LLOOSE=0
+ DO 45 I=1,NOLD
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
+ & .OR.(K(I,1).EQ.5)))THEN
+ DO 46 J=1,NOLD
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
+ & .OR.(K(I,1).EQ.5)))THEN
+ IF(ANTI(I).EQ.TRIP(J)) GOTO 45
+ ENDIF
+ 46 CONTINUE
+ LLOOSE=I
+ GOTO 47
+ ENDIF
+ 45 CONTINUE
+ GOTO 51
+ 47 CONTINUE
+C--generate artificial triplet end
+ write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
+ &'colour singlet system, will discard event'
+ discard = .true.
+ return
+C--copy loose gluon to end of event record
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=2
+ K(N,2)=K(LLOOSE,2)
+ K(N,3)=LLOOSE
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(LLOOSE,1)
+ P(N,2)=P(LLOOSE,2)
+ P(N,3)=P(LLOOSE,3)
+ P(N,4)=P(LLOOSE,4)
+ P(N,5)=P(LLOOSE,5)
+ K(LLOOSE,1)=16
+ K(LLOOSE,4)=N
+ K(LLOOSE,5)=N
+ TRIP(N)=TRIP(LLOOSE)
+ ANTI(N)=ANTI(LLOOSE)
+C--append matching colour partner
+ LMATCH=0
+ DO 48 J=1,10000000
+ DO 49 I=1,NOLD
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
+ & .OR.(K(I,1).EQ.5))
+ & .AND.(ANTI(I).EQ.TRIP(N)))THEN
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,2)=K(I,2)
+ K(N,3)=I
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(I,1)
+ P(N,2)=P(I,2)
+ P(N,3)=P(I,3)
+ P(N,4)=P(I,4)
+ P(N,5)=P(I,5)
+ TRIP(N)=TRIP(I)
+ ANTI(N)=ANTI(I)
+ K(I,1)=16
+ K(I,4)=N
+ K(I,5)=N
+ K(N,1)=2
+ GOTO 48
+ ENDIF
+ 49 CONTINUE
+C--no matching colour partner found, add artificial end point
+ write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
+ &'colour singlet system, will discard event'
+ discard = .true.
+ return
+ 48 CONTINUE
+ 51 CONTINUE
+ CALL CLEANUP(NOLD1)
+ END
+
+
+***********************************************************************
+*** subroutine makestrings_minl
+***********************************************************************
+ SUBROUTINE MAKESTRINGS_MINL
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--local variables
+ INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1
+ DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR,
+ &pyp
+ DATA MCUT/1.d8/
+ DATA EADDEND/10.d0/
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+ logical compressevent,roomleft
+
+ i = 0
+ if (compress) roomleft = compressevent(i)
+ NOLD1=N
+C--remove all active lines that are leptons, gammas, hadrons etc.
+ DO 52 I=1,NOLD1
+ IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN
+C--copy line to end of event record
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=11
+ K(N,2)=K(I,2)
+ K(N,3)=I
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(I,1)
+ P(N,2)=P(I,2)
+ P(N,3)=P(I,3)
+ P(N,4)=P(I,4)
+ P(N,5)=P(I,5)
+ K(I,1)=17
+ K(I,4)=N
+ K(I,5)=N
+ TRIP(N)=TRIP(I)
+ ANTI(N)=ANTI(I)
+ ENDIF
+ 52 CONTINUE
+ NOLD=N
+C--find most energetic unfragmented parton in event
+ 43 EMAX=0
+ LMAX=0
+ DO 40 I=1,NOLD
+ IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13)
+ & .OR.(K(I,1).EQ.14)) K(I,1)=17
+ if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4)
+ & .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN
+ EMAX=P(I,4)
+ LMAX=I
+ ENDIF
+ 40 CONTINUE
+C--if there is non, we are done
+ IF(LMAX.EQ.0) GOTO 50
+C--check if highest energy parton is (anti)quark or gluon
+ IF(K(LMAX,2).EQ.21)THEN
+C--split gluon in qqbar pair and store one temporarily in line 1
+C--make new line in event record for string end
+ N=N+2
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ IF((N-2).GT.NOLD)THEN
+ DO 47 J=NOLD,N-3
+ K(N+NOLD-J,1)=K(N+NOLD-J-2,1)
+ K(N+NOLD-J,2)=K(N+NOLD-J-2,2)
+ IF(K(N+NOLD-J-2,3).GT.NOLD) THEN
+ K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2
+ ELSE
+ K(N+NOLD-J,3)=K(N+NOLD-J-2,3)
+ ENDIF
+ K(N+NOLD-J,4)=0
+ K(N+NOLD-J,5)=0
+ P(N+NOLD-J,1)=P(N+NOLD-J-2,1)
+ P(N+NOLD-J,2)=P(N+NOLD-J-2,2)
+ P(N+NOLD-J,3)=P(N+NOLD-J-2,3)
+ P(N+NOLD-J,4)=P(N+NOLD-J-2,4)
+ P(N+NOLD-J,5)=P(N+NOLD-J-2,5)
+ K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2
+ K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2
+ 47 CONTINUE
+ ENDIF
+ NOLD=NOLD+2
+ K(LMAX,1)=18
+ Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG')
+ IF(Z.GT.0.5)THEN
+ K(NOLD-1,2)=1
+ K(NOLD,2)=-1
+ ELSE
+ Z=1.-Z
+ K(NOLD-1,2)=-1
+ K(NOLD,2)=1
+ ENDIF
+ K(NOLD-1,1)=1
+ K(NOLD-1,3)=LMAX
+ K(NOLD-1,4)=0
+ K(NOLD-1,5)=0
+ P(NOLD-1,1)=(1.-Z)*P(LMAX,1)
+ P(NOLD-1,2)=(1.-Z)*P(LMAX,2)
+ P(NOLD-1,3)=(1.-Z)*P(LMAX,3)
+ P(NOLD-1,4)=(1.-Z)*P(LMAX,4)
+ P(NOLD-1,5)=P(LMAX,5)
+ K(NOLD,1)=1
+ K(NOLD,3)=LMAX
+ K(NOLD,4)=0
+ K(NOLD,5)=0
+ P(NOLD,1)=Z*P(LMAX,1)
+ P(NOLD,2)=Z*P(LMAX,2)
+ P(NOLD,3)=Z*P(LMAX,3)
+ P(NOLD,4)=Z*P(LMAX,4)
+ P(NOLD,5)=P(LMAX,5)
+ K(LMAX,1)=18
+ K(LMAX,4)=NOLD-1
+ K(LMAX,5)=NOLD
+ LMAX=NOLD
+ ENDIF
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=2
+ K(N,2)=K(LMAX,2)
+ K(N,3)=LMAX
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(LMAX,1)
+ P(N,2)=P(LMAX,2)
+ P(N,3)=P(LMAX,3)
+ P(N,4)=P(LMAX,4)
+ P(N,5)=P(LMAX,5)
+ K(LMAX,1)=16
+ K(LMAX,4)=N
+ K(LMAX,5)=N
+ LEND=LMAX
+C--find closest partner
+ 42 MMIN=1.d10
+ LMIN=0
+ DO 41 I=1,NOLD
+ IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1)
+ & .EQ.4).OR.(K(I,1).EQ.5))
+ & .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND.
+ & (K(I,3).NE.K(LEND,3))))
+ & .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN
+ MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2)
+ & -P(I,3)*P(LMAX,3)
+ IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN
+ MMIN=MINV
+ LMIN=I
+ ENDIF
+ ENDIF
+ 41 CONTINUE
+C--if no closest partner can be found, generate artificial end point for string
+ IF(LMIN.EQ.0)THEN
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,1)=1
+ K(N,2)=-K(LEND,2)
+ K(N,3)=0
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=0.d0
+ P(N,2)=0.d0
+ IF(PYR(0).LT.0.5)THEN
+ DIR=1.d0
+ ELSE
+ DIR=-1.d0
+ ENDIF
+ P(N,3)=DIR*EADDEND
+ P(N,4)=EADDEND
+ P(N,5)=0.d0
+ GOTO 43
+ ELSE
+C--else build closest partner in string
+ N=N+1
+ IF(N.GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+ K(N,2)=K(LMIN,2)
+ K(N,3)=LMIN
+ K(N,4)=0
+ K(N,5)=0
+ P(N,1)=P(LMIN,1)
+ P(N,2)=P(LMIN,2)
+ P(N,3)=P(LMIN,3)
+ P(N,4)=P(LMIN,4)
+ P(N,5)=P(LMIN,5)
+ K(LMIN,1)=16
+ K(LMIN,4)=N
+ K(LMIN,5)=N
+ IF(K(LMIN,2).EQ.21)THEN
+ K(N,1)=2
+ LMAX=LMIN
+ GOTO 42
+ ELSE
+ K(N,1)=1
+ GOTO 43
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+ CALL CLEANUP(NOLD)
+ END
+
+
+***********************************************************************
+*** subroutine cleanup
+***********************************************************************
+ SUBROUTINE CLEANUP(NFIRST)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--local variables
+ INTEGER NFIRST,NLAST,I,J
+
+ NLAST=N
+ DO 21 I=1,NLAST-NFIRST
+ DO 22 J=1,5
+ K(I,J)=K(NFIRST+I,J)
+ P(I,J)=P(NFIRST+I,J)
+ V(I,J)=V(NFIRST+I,J)
+ 22 CONTINUE
+ K(I,3)=0
+ 21 CONTINUE
+ N=NLAST-NFIRST
+ END
+
+
+***********************************************************************
+*** subroutine makecascade
+***********************************************************************
+ SUBROUTINE MAKECASCADE
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+
+C--local variables
+ INTEGER NOLD,I
+ LOGICAL CONT
+
+ 10 NOLD=N
+ CONT=.FALSE.
+ DO 11 I=2,NOLD
+ if (i.gt.n) goto 10
+C--check if parton may evolve, i.e. do splitting or scattering
+ IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN
+ CONT=.TRUE.
+ CALL MAKEBRANCH(I)
+ IF(DISCARD) GOTO 12
+ ENDIF
+ 11 CONTINUE
+ IF(CONT) GOTO 10
+ 12 END
+
+
+***********************************************************************
+*** subroutine makebranch
+***********************************************************************
+ SUBROUTINE MAKEBRANCH(L)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--variables for coherent scattering
+ COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
+ &QSUMVEC(4),QSUM2
+ INTEGER NSTART,NEND
+ DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--extra storage for scattering centres before interactions
+ common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
+ & scatcen(23000,5),writescatcen,writedummies
+ integer nscatcen,maxnscatcen,scatflav
+ double precision scatcen
+ logical writescatcen,writedummies
+C--local variables
+ INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold
+ integer oldstcode
+ DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT,
+ &TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR
+ LOGICAL OVERQ0,QQBARDEC
+ CHARACTER TYP
+ LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent
+
+ LINE=L
+ NSTART=0
+ NEND=0
+ if ((mv(line,4).lt.0.d0).and.(mv(line,5).gt.0.d0)) then
+ starttime=0.d0
+ else
+ STARTTIME=MV(LINE,4)
+ endif
+ TSUM=0.d0
+ QSUM2=0.d0
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ RETRYSPLIT=.FALSE.
+ MEDIND=.FALSE.
+ X=0.d0
+ Q=0.d0
+ TYPI=0
+
+
+20 IF(DISCARD) RETURN
+ IF ((N.GT.20000).and.compress) roomleft = compressevent(line)
+ IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
+ & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN
+ IF(MEDIND)THEN
+ FORMTIME=starttime
+ ELSE
+ FORMTIME=MIN(MV(LINE,5),LTIME)
+ ENDIF
+ RADIATION=.TRUE.
+ ELSE
+ FORMTIME=LTIME
+ RADIATION=.FALSE.
+ ENDIF
+ TLEFT=FORMTIME-STARTTIME
+ IF(K(LINE,2).EQ.21)THEN
+ TYP='G'
+ ELSE
+ TYP='Q'
+ ENDIF
+ MEDIND=.FALSE.
+
+! write(logfid,*)'makebranch: starttime tleft formtime radiation',
+! & line, starttime,tleft,formtime,radiation
+
+ IF((TLEFT.LE.1.d-10).or.(starttime.lt.0.d0))THEN
+C--no scattering
+ IF(RADIATION)THEN
+C--if there is radiation associated with the parton then form it now
+C--rotate such that momentum points in z-direction
+ NOLD=N
+ nscatcenold=nscatcen
+ THETA=PYP(LINE,13)
+ PHI=PYP(LINE,15)
+ CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
+ CALL MAKESPLITTING(LINE)
+C--rotate back
+ CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
+ IF(DISCARD) RETURN
+ CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
+C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
+ MV(N-1,1)=MV(LINE,1)
+ & +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
+ MV(N-1,2)=MV(LINE,2)
+ & +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
+ MV(N-1,3)=MV(LINE,3)
+ & +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
+ MV(N, 1)=MV(LINE,1)
+ & +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4))
+ MV(N, 2)=MV(LINE,2)
+ & +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4))
+ MV(N, 3)=MV(LINE,3)
+ & +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4))
+
+ LINE=N
+ NSTART=0
+ NEND=0
+ if ((mv(n,4).lt.0.d0).and.(mv(n,5).gt.0.d0)) then
+ starttime=0.d0
+ else
+ STARTTIME=MV(N,4)
+ endif
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ QSUM2=0.d0
+ TSUM=0.d0
+ GOTO 21
+ ELSE
+ NSTART=0
+ NEND=0
+ STARTTIME=FORMTIME
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ QSUM2=0.d0
+ TSUM=0.d0
+ GOTO 21
+ ENDIF
+ ELSE
+C--do scattering
+C--find delta t for the scattering
+ DELTAT=TLEFT
+ OVERQ0=.FALSE.
+ CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,
+ & OVERQ0,.FALSE.)
+ TSUM=TSUM+DELTAT
+ TLEFT=TLEFT-DELTAT
+C--do initial state splitting if there is one
+ NOLD=N
+ LINEOLD=LINE
+ oldstcode=k(line,1)
+ ZDEC=ZD(LINE)
+ QQBARDEC=QQBARD(LINE)
+ nscatcenold=nscatcen
+ 25 IF(X.LT.1.d0) THEN
+ CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT)
+ IF(DISCARD) RETURN
+ IF(X.LT.1.d0)THEN
+ LINE=N
+ LKINE=N
+ IF(K(LINE,2).EQ.21)THEN
+ NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
+ & 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
+ IF(ZDEC.GT.0.d0)THEN
+ THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
+ ELSE
+ THETAA(LINE)=0.d0
+ ENDIF
+ ZD(LINE)=ZDEC
+ QQBARD(LINE)=QQBARDEC
+ ELSE
+ NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4),
+ & 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC)
+ IF(ZDEC.GT.0.d0)THEN
+ THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4))
+ ELSE
+ THETAA(LINE)=0.d0
+ ENDIF
+ ZD(LINE)=ZDEC
+ QQBARD(LINE)=QQBARDEC
+ ENDIF
+ ZDEC=ZD(LINE)
+ QQBARDEC=QQBARD(LINE)
+ ELSE
+ LKINE=LINE
+ NEND=NSTART
+ QSUM2=ALLQS(NEND,1)
+ QSUMVEC(1)=ALLQS(NEND,2)
+ QSUMVEC(2)=ALLQS(NEND,3)
+ QSUMVEC(3)=ALLQS(NEND,4)
+ QSUMVEC(4)=ALLQS(NEND,5)
+ IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
+ OVERQ0=.TRUE.
+ ELSE
+ OVERQ0=.FALSE.
+ ENDIF
+ tleft = starttime+tsum+tleft-allqs(1,6)
+ tsum = allqs(1,6)-starttime
+ ENDIF
+ ENDIF
+ IF(X.EQ.1.d0)THEN
+ NEWMASS=0.d0
+ IF(NEND.GT.0)THEN
+ CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT,
+ & NEWMASS,OVERQ0,ZDEC,QQBARDEC)
+ IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN
+ MEDIND=.TRUE.
+ ELSE
+ MEDIND=.FALSE.
+ ZDEC=ZD(LINE)
+ QQBARDEC=QQBARD(LINE)
+ ENDIF
+ TSUM=TSUM+DELTAT
+ TLEFT=TLEFT-DELTAT
+ LKINE=LINE
+ ENDIF
+ ENDIF
+C--do kinematics
+ RETRYSPLIT=.FALSE.
+ IF(NEND.GT.0) THEN
+ nendold=nend
+ CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT,
+ & STARTTIME+TSUM,X,ZDEC,QQBARDEC)
+ IF(RETRYSPLIT) THEN
+ tleft = starttime+tsum+tleft-allqs(1,6)
+ tsum = allqs(1,6)-starttime
+ if (x.lt.1.d0) then
+ NEND=NSTART
+ QSUM2=ALLQS(NEND,1)
+ QSUMVEC(1)=ALLQS(NEND,2)
+ QSUMVEC(2)=ALLQS(NEND,3)
+ QSUMVEC(3)=ALLQS(NEND,4)
+ QSUMVEC(4)=ALLQS(NEND,5)
+ TYPI=K(L,2)
+ IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN
+ OVERQ0=.TRUE.
+ ELSE
+ OVERQ0=.FALSE.
+ ENDIF
+ N=NOLD
+ LINE=LINEOLD
+ X=1.d0
+ K(LINE,1)=oldstcode
+! K(LINE,1)=1
+ nscatcen=nscatcenold
+ NSPLIT=NSPLIT-EVWEIGHT
+ nspliti=nspliti-evweight
+ GOTO 25
+ else
+ LINE=N
+ STARTTIME=STARTTIME+TSUM
+ TSUM=0.d0
+ endif
+ ELSE
+ LINE=N
+ STARTTIME=STARTTIME+TSUM
+ TSUM=0.d0
+ ENDIF
+ ELSE
+ STARTTIME=STARTTIME+TSUM
+ TSUM=0.d0
+ ENDIF
+! IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE.
+ IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
+ & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))) RADIATION=.TRUE.
+ ENDIF
+ 21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
+ & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))
+ & .OR.(STARTTIME.LT.LTIME))THEN
+ GOTO 20
+ ENDIF
+ IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4
+ IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5
+ END
+
+
+***********************************************************************
+*** subroutine makesplitting
+***********************************************************************
+ SUBROUTINE MAKESPLITTING(L)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+
+C--local variables
+ INTEGER L,DIR
+ DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC,
+ &GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA,
+ &GETTEMP
+ LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC
+ integer bin
+ DATA PI/3.141592653589793d0/
+
+ IF((N+2).GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+
+ XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4)
+ XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4)
+ XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4)
+ IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN
+ THETA=-1.d0
+ ELSE
+ THETA=THETAA(L)
+ ENDIF
+
+C--on-shell partons cannot split
+ IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)
+ & .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3)
+ & .or.(zd(l).lt.0.d0)) GOTO 31
+C--quark or gluon?
+ IF(K(L,2).EQ.21)THEN
+ QUARK=.FALSE.
+ ELSE
+ QUARK=.TRUE.
+ QQBAR=.FALSE.
+ ENDIF
+C--if gluon decide on kind of splitting
+ QQBAR=QQBARD(L)
+C--if g->gg splitting decide on colour order
+ IF(QUARK.OR.QQBAR)THEN
+ DIR=0
+ ELSE
+ IF(PYR(0).LT.0.5)THEN
+ DIR=1
+ ELSE
+ DIR=-1
+ ENDIF
+ ENDIF
+ Z=ZD(L)
+ IF(Z.EQ.0.d0)THEN
+ write(logfid,*)'makesplitting: z=0',L,p(l,5)
+ goto 36
+ ENDIF
+ GOTO 35
+C--generate z value
+ 36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN
+C--additional z constraint due to angular ordering
+ QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2)
+ IF(QH.GT.1)THEN
+ write(logfid,*)L,': reject event: angular ordering
+ & conflict in medium'
+ CALL PYLIST(2)
+ DISCARD=.TRUE.
+ GOTO 31
+ ENDIF
+ EPS=0.5-0.5*SQRT(1.-QH)
+ ELSE
+ EPS=0d0
+ ENDIF
+ IF(QUARK)THEN
+ Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ')
+ ELSE
+ IF(QQBAR)THEN
+ Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG')
+ ELSE
+ Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG')
+ ENDIF
+ ENDIF
+ 35 CONTINUE
+C--maximum virtualities for daughters
+ BMAX1=MIN(P(L,5),Z*P(L,4))
+ CMAX1=MIN(P(L,5),(1.-Z)*P(L,4))
+C--generate mass of quark or gluon (particle b) from Sudakov FF
+ 30 IF(QUARK.OR.QQBAR)THEN
+ MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ',
+ & BMAX1,.FALSE.,ZDECB,QQBARDECB)
+ ELSE
+ MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC',
+ & BMAX1,.FALSE.,ZDECB,QQBARDECB)
+ ENDIF
+C--generate mass gluon (particle c) from Sudakov FF
+ IF(QUARK.OR.(.NOT.QQBAR))THEN
+ MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC',
+ & CMAX1,.FALSE.,ZDECC,QQBARDECC)
+ ELSE
+ MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ',
+ & CMAX1,.FALSE.,ZDECC,QQBARDECC)
+ ENDIF
+C--quark (parton b) momentum
+ 182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3))
+ PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2
+C--if kinematics doesn't work out, generate new virtualities
+C for daughters
+C--massive phase space weight
+ IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36
+ WEIGHT=1.d0
+ IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0)
+ & .OR.((MB+MC).GT.P(L,5)))THEN
+ IF(MB.GT.MC)THEN
+ IF(QUARK.OR.QQBAR)THEN
+ MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ',
+ & BMAX1,.FALSE.,ZDECB,QQBARDECB)
+ ELSE
+ MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC',
+ & BMAX1,.FALSE.,ZDECB,QQBARDECB)
+ ENDIF
+ ELSE
+ IF(QUARK.OR.(.NOT.QQBAR))THEN
+ MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC',
+ & CMAX1,.FALSE.,ZDECC,QQBARDECC)
+ ELSE
+ MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ',
+ & CMAX1,.FALSE.,ZDECC,QQBARDECC)
+ ENDIF
+ ENDIF
+ GOTO 182
+ ENDIF
+ N=N+2
+C--take care of first daughter (radiated gluon or antiquark)
+! K(N-1,1)=K(L,1)
+ K(N-1,1)=1
+ IF(QQBAR)THEN
+ K(N-1,2)=-1
+ TRIP(N-1)=0
+ ANTI(N-1)=ANTI(L)
+ ELSE
+ K(N-1,2)=21
+ IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
+ TRIP(N-1)=TRIP(L)
+ ANTI(N-1)=COLMAX+1
+ ELSE
+ TRIP(N-1)=COLMAX+1
+ ANTI(N-1)=ANTI(L)
+ ENDIF
+ COLMAX=COLMAX+1
+ ENDIF
+ K(N-1,3)=L
+ K(N-1,4)=0
+ K(N-1,5)=0
+ P(N-1,4)=(1-Z)*P(L,4)
+ P(N-1,5)=MC
+ ZA(N-1)=1.-Z
+ IF(ZDECC.GT.0.d0)THEN
+ THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4))
+ ELSE
+ THETAA(N-1)=0.d0
+ ENDIF
+ ZD(N-1)=ZDECC
+ QQBARD(N-1)=QQBARDECC
+C--take care of second daughter (final quark or gluon or quark from
+C gluon splitting)
+! K(N,1)=K(L,1)
+ K(N,1)=1
+ IF(QUARK)THEN
+ K(N,2)=K(L,2)
+ IF(K(N,2).GT.0)THEN
+ TRIP(N)=ANTI(N-1)
+ ANTI(N)=0
+ ELSE
+ TRIP(N)=0
+ ANTI(N)=TRIP(N-1)
+ ENDIF
+ ELSEIF(QQBAR)THEN
+ K(N,2)=1
+ TRIP(N)=TRIP(L)
+ ANTI(N)=0
+ ELSE
+ K(N,2)=21
+ IF(DIR.EQ.1)THEN
+ TRIP(N)=ANTI(N-1)
+ ANTI(N)=ANTI(L)
+ ELSE
+ TRIP(N)=TRIP(L)
+ ANTI(N)=TRIP(N-1)
+ ENDIF
+ ENDIF
+ K(N,3)=L
+ K(N,4)=0
+ K(N,5)=0
+ P(N,3)=PZ
+ P(N,4)=Z*P(L,4)
+ P(N,5)=MB
+ ZA(N)=Z
+ IF(ZDECB.GT.0.d0)THEN
+ THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4))
+ ELSE
+ THETAA(N)=0.d0
+ ENDIF
+ ZD(N)=ZDECB
+ QQBARD(N)=QQBARDECB
+C--azimuthal angle
+ PHIQ=2*PI*PYR(0)
+ P(N,1)=SQRT(PTS)*COS(PHIQ)
+ P(N,2)=SQRT(PTS)*SIN(PHIQ)
+C--gluon momentum
+ P(N-1,1)=P(L,1)-P(N,1)
+ P(N-1,2)=P(L,2)-P(N,2)
+ P(N-1,3)=P(L,3)-P(N,3)
+ MV(N-1,4)=MV(L,5)
+ IF(P(N-1,5).GT.0.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
+ MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(N-1,5)=0.d0
+ ENDIF
+ MV(N,4)=MV(L,5)
+ IF(P(N,5).GT.0.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
+ MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(N,5)=0.d0
+ ENDIF
+C--take care of initial quark (or gluon)
+ IF(K(L,1).EQ.2)THEN
+ K(L,1)=13
+ ELSE
+ K(L,1)=11
+ ENDIF
+ K(L,4)=N-1
+ K(L,5)=N
+ NSPLIT=NSPLIT+EVWEIGHT
+ nsplitf=nsplitf+evweight
+ 31 CONTINUE
+ END
+
+
+***********************************************************************
+*** subroutine makeinsplit
+***********************************************************************
+ SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+
+C--local variables
+ INTEGER L,TYPI,NOLD,DIR
+ DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
+ &PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC
+ LOGICAL QQBARDEC
+ CHARACTER*2 TYP2,TYPC
+ integer bin
+ DATA PI/3.141592653589793d0/
+
+ IF((N+2).GT.22990) THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+
+ IF(K(L,2).EQ.21)THEN
+ IF(TYPI.EQ.21)THEN
+ TYP2='GG'
+ TYPC='GC'
+ ELSE
+ TYP2='QG'
+ TYPC='QQ'
+ ENDIF
+ ELSE
+ IF(TYPI.EQ.21)THEN
+ TYP2='GQ'
+ TYPC='QQ'
+ ELSE
+ TYP2='QQ'
+ TYPC='GC'
+ ENDIF
+ ENDIF
+
+C--if g->gg decide on colour configuration
+ IF(TYP2.EQ.'GG')THEN
+ IF(PYR(0).LT.0.5)THEN
+ DIR=1
+ ELSE
+ DIR=-1
+ ENDIF
+ ELSE
+ DIR=0
+ ENDIF
+
+ MB2=VIRT**2
+ MB2=P(L,5)**2-MB2
+! MB2=-VIRT**2
+ MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0,
+ & (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4),
+ & .FALSE.,ZDEC,QQBARDEC)**2
+
+C--rotate such that momentum points in z-direction
+ NOLD=N
+ THETA=PYP(L,13)
+ PHI=PYP(L,15)
+ CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
+ PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
+ KT2=X**2*(P(L,4)**2)-PZ**2-MB2
+ IF(KT2.LT.0.d0)THEN
+ MC2=0.d0
+ IF(K(L,1).EQ.2) zdec = -1.d0
+ PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3))
+ KT2=X**2*(P(L,4)**2)-PZ**2-MB2
+ IF(KT2.LT.0.d0)THEN
+ CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
+ X=1.d0
+ RETURN
+ ENDIF
+ ENDIF
+ N=N+2
+C--take care of first daughter (radiated gluon or antiquark)
+! K(N-1,1)=K(L,1)
+ K(N-1,1)=1
+ IF(TYP2.EQ.'QG')THEN
+ K(N-1,2)=-TYPI
+ IF(K(N-1,2).GT.0)THEN
+ TRIP(N-1)=TRIP(L)
+ ANTI(N-1)=0
+ ELSE
+ TRIP(N-1)=0
+ ANTI(N-1)=ANTI(L)
+ ENDIF
+ ELSEIF(TYP2.EQ.'GQ')THEN
+ K(N-1,2)=K(L,2)
+ IF(K(N-1,2).GT.0)THEN
+ TRIP(N-1)=COLMAX+1
+ ANTI(N-1)=0
+ ELSE
+ TRIP(N-1)=0
+ ANTI(N-1)=COLMAX+1
+ ENDIF
+ COLMAX=COLMAX+1
+ ELSE
+ K(N-1,2)=21
+ IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN
+ TRIP(N-1)=TRIP(L)
+ ANTI(N-1)=COLMAX+1
+ ELSE
+ TRIP(N-1)=COLMAX+1
+ ANTI(N-1)=ANTI(L)
+ ENDIF
+ COLMAX=COLMAX+1
+ ENDIF
+ K(N-1,3)=L
+ K(N-1,4)=0
+ K(N-1,5)=0
+ P(N-1,4)=(1.-X)*P(L,4)
+ P(N-1,5)=SQRT(MC2)
+C--take care of second daughter (final quark or gluon or quark from
+C gluon splitting)
+! K(N,1)=K(L,1)
+ K(N,1)=1
+ IF(TYP2.EQ.'QG')THEN
+ K(N,2)=TYPI
+ IF(K(N,2).GT.0)THEN
+ TRIP(N)=TRIP(L)
+ ANTI(N)=0
+ ELSE
+ TRIP(N)=0
+ ANTI(N)=ANTI(L)
+ ENDIF
+ ELSEIF(TYPI.NE.21)THEN
+ K(N,2)=K(L,2)
+ IF(K(N,2).GT.0)THEN
+ TRIP(N)=ANTI(N-1)
+ ANTI(N)=0
+ ELSE
+ TRIP(N)=0
+ ANTI(N)=TRIP(N-1)
+ ENDIF
+ ELSE
+ K(N,2)=21
+ IF(K(N-1,2).EQ.21)THEN
+ IF(DIR.EQ.1)THEN
+ TRIP(N)=ANTI(N-1)
+ ANTI(N)=ANTI(L)
+ ELSE
+ TRIP(N)=TRIP(L)
+ ANTI(N)=TRIP(N-1)
+ ENDIF
+ ELSEIF(K(N-1,2).GT.0)THEN
+ TRIP(N)=TRIP(L)
+ ANTI(N)=TRIP(N-1)
+ ELSE
+ TRIP(N)=ANTI(N-1)
+ ANTI(N)=ANTI(L)
+ ENDIF
+ ENDIF
+ K(N,3)=L
+ K(N,4)=0
+ K(N,5)=0
+ P(N,3)=PZ
+ P(N,4)=X*P(L,4)
+ IF(MB2.LT.0.d0)THEN
+ P(N,5)=-SQRT(-MB2)
+ ELSE
+ P(N,5)=SQRT(MB2)
+ ENDIF
+C--azimuthal angle
+ PHIQ=2*PI*PYR(0)
+ P(N,1)=SQRT(KT2)*COS(PHIQ)
+ P(N,2)=SQRT(KT2)*SIN(PHIQ)
+C--gluon momentum
+ P(N-1,1)=P(L,1)-P(N,1)
+ P(N-1,2)=P(L,2)-P(N,2)
+ P(N-1,3)=P(L,3)-P(N,3)
+ MV(L,5)=TIME-TAURAD
+ MV(N-1,4)=MV(L,5)
+ IF(P(N-1,5).GT.0.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2)
+ MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(N-1,5)=0.d0
+ ENDIF
+ MV(N,4)=MV(L,5)
+ IF(P(N,5).GT.0.d0)THEN
+ MV(N,5)=TIME
+ ELSE
+ MV(N,5)=0.d0
+ ENDIF
+ ZA(N-1)=1.d0
+ THETAA(N-1)=-1.d0
+ ZD(N-1)=ZDEC
+ QQBARD(N-1)=QQBARDEC
+ ZA(N)=1.d0
+ THETAA(N)=-1.d0
+ ZD(N)=0.d0
+ QQBARD(N)=.FALSE.
+C--take care of initial quark (or gluon)
+ IF(K(L,1).EQ.2)THEN
+ K(L,1)=13
+ ELSE
+ K(L,1)=11
+ ENDIF
+ K(L,4)=N-1
+ K(L,5)=N
+ NSPLIT=NSPLIT+EVWEIGHT
+ nspliti=nspliti+evweight
+ CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
+
+C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
+ MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
+ MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
+ MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
+ MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4))
+ MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4))
+ MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4))
+
+ END
+
+
+***********************************************************************
+*** subroutine doinstatescat
+***********************************************************************
+ SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0,
+ & RETRYSPLIT)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for coherent scattering
+ COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
+ &QSUMVEC(4),QSUM2
+ INTEGER NSTART,NEND
+ DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--local variables
+ INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2
+ DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT,
+ &WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT,
+ &XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS,
+ &GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD,
+ &GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT,
+ &pyp
+ LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT,
+ &QQBARDUM
+ CHARACTER TYP
+ CHARACTER*2 TYP2
+ DATA PI/3.141592653589793d0/
+ DATA COUNTMAX/10000/
+
+ COUNTER=0
+
+ XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4)
+ YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4)
+ ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4)
+ TSC=TSTART
+ MD1=GETMD(XSC,YSC,ZSC,TSC)
+ MS1=GETMS(XSC,YSC,ZSC,TSC)
+
+ IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN
+ write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC),
+ &GETNEFF(XSC,YSC,ZSC,TSC)
+ ENDIF
+
+C--check for scattering
+ NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT)
+ IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116
+
+C--decide whether there will be radiation
+ PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc)
+ IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN
+ NORAD=.TRUE.
+ ELSE
+ NORAD=.FALSE.
+ ENDIF
+
+C--decide whether q or g is to be scattered
+ IF(K(L,2).EQ.21)THEN
+ TYP='G'
+ TYP2='GC'
+ SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & Q0,'G','C',xsc,ysc,zsc,tsc,0)
+ IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
+ PFCHANGE=0.d0
+ ELSE
+ PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & Q0,'G','Q',xsc,ysc,zsc,tsc,0)
+ & /SIGMATOT
+ ENDIF
+ SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & 0.d0,'G','C',xsc,ysc,zsc,tsc,0)
+ ELSE
+ TYP='Q'
+ TYP2='QQ'
+ SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & Q0,'Q','C',xsc,ysc,zsc,tsc,0)
+ IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
+ PFCHANGE=0.d0
+ ELSE
+ PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & Q0,'Q','G',xsc,ysc,zsc,tsc,0)
+ & /SIGMATOT
+ ENDIF
+ SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5),
+ & 0.d0,'Q','C',xsc,ysc,zsc,tsc,0)
+ ENDIF
+ IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN
+ write(logfid,*)'error: flavour change probability=',
+ & PFCHANGE,'for ',TYP
+ ENDIF
+ IF(PYR(0).LT.PFCHANGE)THEN
+ FCHANGE=.TRUE.
+ ELSE
+ FCHANGE=.FALSE.
+ ENDIF
+ IF (NORAD) FCHANGE=.FALSE.
+C--set TYPI
+ IF(TYP.EQ.'G')THEN
+ IF(FCHANGE)THEN
+ TYPI=INT(SIGN(2.d0,PYR(0)-0.5))
+ ELSE
+ TYPI=K(L,2)
+ ENDIF
+ ELSE
+ IF(FCHANGE)THEN
+ TYPI=21
+ ELSE
+ TYPI=K(L,2)
+ ENDIF
+ ENDIF
+ LOW=Q0**2/SCALEFACM**2
+ TMAX=4.*(P(L,4)**2-P(L,5)**2)
+ XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX)
+
+ IF(SIGMATOT.EQ.0.d0) GOTO 116
+
+ RTAU=PYR(0)
+
+C--generate a trial emission
+C--pick a x value from splitting function
+ 112 COUNTER=COUNTER+1
+ IF(TYP.EQ.'G')THEN
+ IF(FCHANGE)THEN
+ X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG')
+ ELSE
+ X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG')
+ ENDIF
+ ELSE
+ IF(FCHANGE)THEN
+ X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
+ ELSE
+ X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ')
+ ENDIF
+ ENDIF
+ IF(NORAD) X=1.d0
+C--initialisation
+ TMAXNEW=(X*P(L,4))**2
+ PHI=0.d0
+ TLEFT=DELTAT
+ TNOW=TSTART
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ QSUM2=-1.d-10
+ OVERQ0=.FALSE.
+ Q=P(L,5)
+ QOLD=P(L,5)
+ TAUEST=DELTAT
+C--generate first momentum transfer
+ DELTAL=DT
+ NSTART=1
+ NEND=1
+ TNOW=TNOW+DELTAL
+ TSUM=DELTAL
+ TLEFT=TLEFT-DELTAL
+ ALLQS(NEND,6)=TNOW
+ Q2OLD=QSUM2
+C--get new momentum transfer
+ COUNT2=0
+ 118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
+ IF(-QSUM2.GT.P(L,4)**2)THEN
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ QSUM2=Q2OLD
+ IF(COUNT2.LT.100)THEN
+ COUNT2=COUNT2+1
+ GOTO 118
+ ELSE
+ ALLQS(NEND,1)=0.d0
+ ALLQS(NEND,2)=0.d0
+ ALLQS(NEND,3)=0.d0
+ ALLQS(NEND,4)=0.d0
+ ALLQS(NEND,5)=0.d0
+ ENDIF
+ ENDIF
+C--update OVERQ0
+ IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE.
+C--get new virtuality
+ IF(OVERQ0.AND.(.NOT.NORAD))THEN
+ Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
+ & .TRUE.,X,ZDUM,QQBARDUM)
+ ELSE
+ Q=0.d0
+ ENDIF
+
+C--estimate formation time
+ 111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN
+ TAUEST=DELTAT
+ ELSE
+ TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2
+ ENDIF
+ LAMBDA=1.d0/TAUEST
+ TAUEST=-LOG(1.d0-RTAU)/LAMBDA
+
+C--find number, position and momentum transfers of further scatterings
+ NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL)
+ IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN
+C--add a momentum transfer
+ NEND=NEND+1
+ IF(NEND.GE.100)THEN
+ nend=nend-1
+ goto 114
+ ENDIF
+ TNOW=TNOW+DELTAL
+ TSUM=TSUM+DELTAL
+ TLEFT=TLEFT-DELTAL
+C--update phase
+ IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN
+ PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4))
+ ENDIF
+C--get new momentum transfer
+ ALLQS(NEND,6)=TNOW
+ Q2OLD=QSUM2
+ QSUMVECOLD(1)=QSUMVEC(1)
+ QSUMVECOLD(2)=QSUMVEC(2)
+ QSUMVECOLD(3)=QSUMVEC(3)
+ QSUMVECOLD(4)=QSUMVEC(4)
+ COUNT2=0
+ 119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X)
+ IF(-QSUM2.GT.P(L,4)**2)THEN
+ QSUMVEC(1)=QSUMVECOLD(1)
+ QSUMVEC(2)=QSUMVECOLD(2)
+ QSUMVEC(3)=QSUMVECOLD(3)
+ QSUMVEC(4)=QSUMVECOLD(4)
+ QSUM2=Q2OLD
+ IF(COUNT2.LT.100)THEN
+ COUNT2=COUNT2+1
+ GOTO 119
+ ELSE
+ ALLQS(NEND,1)=0.d0
+ ALLQS(NEND,2)=0.d0
+ ALLQS(NEND,3)=0.d0
+ ALLQS(NEND,4)=0.d0
+ ALLQS(NEND,5)=0.d0
+ ENDIF
+ ENDIF
+C--update OVERQ0
+ IF((-QSUM2.GT.LOW)
+ & .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE.
+C--get new virtuality
+ QOLD=Q
+ IF(OVERQ0.AND.(.NOT.NORAD))THEN
+ Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0,
+ & .TRUE.,X,ZDUM,QQBARDUM)
+ ELSE
+ Q=0.d0
+ ENDIF
+ GOTO 111
+ ENDIF
+
+C--do reweighting
+ 114 TMAXNEW=X**2*P(L,4)**2
+ IF(NORAD)THEN
+ WEIGHT=1.d0
+ Q=0.d0
+ X=1.d0
+ ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN
+ WEIGHT=0.d0
+ ELSEIF(-QSUM2.GT.P(L,4)**2)THEN
+ WEIGHT=0.d0
+ ELSE
+ IF(TYP.EQ.'G')THEN
+ FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2)
+ & *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
+ IF(QSUM2.EQ.0.d0)THEN
+ WEIGHT=0.d0
+ NORAD=.TRUE.
+ ELSE
+ IF(FCHANGE)THEN
+ WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX)
+ IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
+ write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
+ & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg',
+ & FMAX
+ ENDIF
+ ELSE
+ WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX)
+ IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
+ write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
+ & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg',
+ & FMAX
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2)
+ & *ALPHAS(Q0**2/4.,LPS)/(2.*PI)
+ IF(QSUM2.EQ.0.d0)THEN
+ WEIGHT=0.d0
+ NORAD=.TRUE.
+ ELSE
+ IF(FCHANGE)THEN
+ WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX)
+ IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
+ write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X,
+ & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq',
+ & FMAX
+ ENDIF
+ ELSE
+ WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX)
+ IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN
+ write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X,
+ & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq',
+ & FMAX
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))
+ & write(logfid,*)'error: weight=',WEIGHT
+ 115 IF(PYR(0).GT.WEIGHT)THEN
+ IF(COUNTER.LT.COUNTMAX)THEN
+ GOTO 112
+ ELSE
+ Q=0.d0
+ X=1.d0
+ NEND=NSTART
+ QSUM2=ALLQS(NEND,1)
+ QSUMVEC(1)=ALLQS(NEND,2)
+ QSUMVEC(2)=ALLQS(NEND,3)
+ QSUMVEC(3)=ALLQS(NEND,4)
+ QSUMVEC(4)=ALLQS(NEND,5)
+ TYPI=K(L,2)
+ IF(-ALLQS(NEND,1).GT.LOW)THEN
+ OVERQ0=.TRUE.
+ ELSE
+ OVERQ0=.FALSE.
+ ENDIF
+ DELTAT=ALLQS(NEND,6)-TSTART
+ TNOW=ALLQS(1,6)
+ RETURN
+ ENDIF
+ ENDIF
+C--found meaningful configuration, now do final checks
+C--check if phase is unity and weight with 1/Nscat
+ IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0)))
+ & .AND.(.NOT.NORAD))THEN
+ Q=0.d0
+ X=1.d0
+ NEND=NSTART
+ QSUM2=ALLQS(NEND,1)
+ QSUMVEC(1)=ALLQS(NEND,2)
+ QSUMVEC(2)=ALLQS(NEND,3)
+ QSUMVEC(3)=ALLQS(NEND,4)
+ QSUMVEC(4)=ALLQS(NEND,5)
+ TYPI=K(L,2)
+ IF(-ALLQS(NEND,1).GT.LOW)THEN
+ OVERQ0=.TRUE.
+ ELSE
+ OVERQ0=.FALSE.
+ ENDIF
+ DELTAT=ALLQS(NEND,6)-TSTART
+ TNOW=ALLQS(1,6)
+ ELSE
+ IF(.NOT.NORAD)THEN
+ TLEFT=TLEFT-TAUEST
+ TNOW=TNOW+TAUEST
+ TSUM=TSUM+TAUEST
+ ENDIF
+ DELTAT=TSUM
+ ENDIF
+ RETURN
+C--exit in case of failure
+ 116 Q=0.d0
+ X=1.d0
+ NSTART=0
+ NEND=0
+ QSUMVEC(1)=0.d0
+ QSUMVEC(2)=0.d0
+ QSUMVEC(3)=0.d0
+ QSUMVEC(4)=0.d0
+ QSUM2=0.d0
+ OVERQ0=.FALSE.
+ TYPI=K(L,2)
+ RETURN
+ END
+
+
+***********************************************************************
+*** subroutine dofistatescat
+***********************************************************************
+ SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS,
+ & OVERQ0,Z,QQBAR)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for coherent scattering
+ COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
+ &QSUMVEC(4),QSUM2
+ INTEGER NSTART,NEND
+ DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
+C--local variables
+ INTEGER L,COUNTER,COUNTMAX,COUNT2
+ DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD,
+ &GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI,
+ &TAUEST,LOW,Z,pyp
+ LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR
+ CHARACTER TYP
+ DATA COUNTMAX/100/
+ DELTAL=0.d0
+
+ IF(-QSUM2.GT.P(L,4)**2)
+ & write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2
+
+ IF(K(L,2).EQ.21)THEN
+ TYP='G'
+ ELSE
+ TYP='Q'
+ ENDIF
+ LOW=Q0**2/SCALEFACM**2
+
+ TSUM=0.d0
+ PHI=0.d0
+ DELTAT=0.d0
+
+C--check for radiation with first (given) momentum transfer
+ Q2OLD=0.d0
+ IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
+ NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
+ & NEWMASS,.FALSE.,1.d0,Z,QQBAR)
+ OVERQ0=.TRUE.
+ ELSE
+ NEWMASS=P(L,5)
+ ENDIF
+
+ RTAU=PYR(0)
+
+ TLEFT=DTLEFT
+ 222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN
+ TAUEST=TLEFT
+ ELSE
+ TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2
+ ENDIF
+ LAMBDA=1.d0/TAUEST
+ TAUEST=-LOG(1.d0-RTAU)/LAMBDA
+ NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL)
+ IF(.NOT.NOSCAT)THEN
+C--do scattering
+ NEND=NEND+1
+ IF(NEND.gt.countmax)THEN
+ nend=nend-1
+ goto 218
+ ENDIF
+ IF(NSTART.EQ.0) NSTART=1
+ TSUM=TSUM+DELTAL
+ TLEFT=TLEFT-DELTAL
+ IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN
+ PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4))
+ ENDIF
+ ALLQS(NEND,6)=TNOW+TSUM
+ QSUMVECOLD(1)=QSUMVEC(1)
+ QSUMVECOLD(2)=QSUMVEC(2)
+ QSUMVECOLD(3)=QSUMVEC(3)
+ QSUMVECOLD(4)=QSUMVEC(4)
+ Q2OLD=QSUM2
+C--get new momentum transfer
+ COUNT2=0
+ 219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0)
+ IF(-QSUM2.GT.P(L,4)**2)THEN
+ QSUMVEC(1)=QSUMVECOLD(1)
+ QSUMVEC(2)=QSUMVECOLD(2)
+ QSUMVEC(3)=QSUMVECOLD(3)
+ QSUMVEC(4)=QSUMVECOLD(4)
+ QSUM2=Q2OLD
+ IF(COUNT2.LT.100)THEN
+ COUNT2=COUNT2+1
+ GOTO 219
+ ELSE
+ ALLQS(NEND,1)=0.d0
+ ALLQS(NEND,2)=0.d0
+ ALLQS(NEND,3)=0.d0
+ ALLQS(NEND,4)=0.d0
+ ALLQS(NEND,5)=0.d0
+ ENDIF
+ ENDIF
+C--figure out new virtuality
+ IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN
+ NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,
+ & NEWMASS,.FALSE.,1.d0,Z,QQBAR)
+ OVERQ0=.TRUE.
+ ENDIF
+ GOTO 222
+ ENDIF
+C--no more scattering
+ 218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then
+ if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then
+ if (nend.eq.countmax) then
+ deltat=tsum
+ else if (TLEFT.LT.TAUEST) then
+ DELTAT=TSUM+tleft
+ else
+ DELTAT=TSUM+tauest
+ endif
+ NEWMASS=P(L,5)
+ ELSE
+ DELTAT=TSUM+TAUEST
+ ENDIF
+ else
+ DELTAT=0.d0
+ NSTART=1
+ NEND=1
+ QSUM2=ALLQS(NEND,1)
+ QSUMVEC(1)=ALLQS(NEND,2)
+ QSUMVEC(2)=ALLQS(NEND,3)
+ QSUMVEC(3)=ALLQS(NEND,4)
+ QSUMVEC(4)=ALLQS(NEND,5)
+ IF(-ALLQS(NEND,1).GT.LOW)THEN
+ OVERQ0=.TRUE.
+ ELSE
+ OVERQ0=.FALSE.
+ ENDIF
+ NEWMASS=P(L,5)
+ endif
+ return
+ END
+
+
+***********************************************************************
+*** function getnewmass
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X,
+ & ZDEC,QQBARDEC)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ INTEGER L
+ DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
+ &GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD
+ LOGICAL IN,QQBARDEC,QQBAROLD
+ CHARACTER*2 TYP
+
+ IF(x*P(L,4).LT.Q0)THEN
+ GETNEWMASS=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ RETURN
+ ENDIF
+ IF (-Q2.LT.Q0**2)THEN
+ GETNEWMASS=0.d0
+ RETURN
+ ENDIF
+ IF(K(L,2).EQ.21)THEN
+ TYP='GC'
+ ELSE
+ TYP='QQ'
+ ENDIF
+ IF(SQRT(-QOLD2).LE.Q0)THEN
+ IF(IN)THEN
+ GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
+ & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
+ ELSE
+ GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP,
+ & SQRT(-Q2),IN,ZDEC,QQBARDEC)
+ ENDIF
+ GETNEWMASS=MIN(GETNEWMASS,X*P(L,4))
+ RETURN
+ ENDIF
+ Z=1.d0
+ QA=1.d0
+ IF(MAX(P(L,5),MASS).GT.0.d0)THEN
+ IF(-Q2.GT.-QOLD2)THEN
+ ZOLD=ZDEC
+ QQBAROLD=QQBARDEC
+ QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
+ & SQRT(-Q2),IN,ZDEC,QQBARDEC)
+ IF(QTMP.LT.SQRT(-QOLD2))THEN
+ GETNEWMASS=MASS
+ ZDEC=ZOLD
+ QQBARDEC=QQBAROLD
+ ELSE
+ GETNEWMASS=QTMP
+ ENDIF
+ ELSE
+ PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4),
+ & TYP,MV(L,4),IN)
+ PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4),
+ & TYP,MV(L,4),IN)
+ PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
+ IF(PYR(0).LT.PKEEP)THEN
+ IF(P(L,5).LT.SQRT(-Q2))THEN
+ GETNEWMASS=MASS
+ ELSE
+ 55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP,
+ & SQRT(-Q2),IN,ZDEC,QQBARDEC)
+ IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55
+ ENDIF
+ ELSE
+ GETNEWMASS=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ ENDIF
+ ENDIF
+ ELSE
+ IF(-Q2.GT.-QOLD2)THEN
+ GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,
+ & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC)
+ if(getnewmass.lt.SQRT(-QOLD2))then
+ GETNEWMASS=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ endif
+ ELSE
+ GETNEWMASS=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ ENDIF
+ ENDIF
+ GETNEWMASS=MIN(GETNEWMASS,x*P(L,4))
+ END
+
+
+***********************************************************************
+*** function getpnorad1
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ INTEGER LINE
+ DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT,
+ &SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd
+
+ md1 = getmd(x,y,z,t)
+ call avscatcen(x,y,z,t,
+ &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ ms1 = avmom(5)
+ shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4)
+ & -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3))
+ pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2
+ up = 4.*pcms2
+ LOW=Q0**2/SCALEFACM**2
+ IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN
+ GETPNORAD1=1.d0
+ RETURN
+ ENDIF
+ IF(K(LINE,2).EQ.21)THEN
+ CCOL=3./2.
+C--probability for no initial state radiation
+ SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
+ & P(LINE,5),0.d0,'G','C',x,y,z,t,0)
+ IF(SIGMATOT.EQ.0.d0)THEN
+ GETPNORAD1=-1.d0
+ RETURN
+ ENDIF
+ GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
+ &SCATPRIMFUNC(0.d0,MD1))
+ & + GETXSECINT(UP,MD1,'GB'))/SIGMATOT
+ ELSE
+ CCOL=2./3.
+C--probability for no initial state radiation
+ SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
+ & P(LINE,5),0.d0,'Q','C',x,y,z,t,0)
+ IF(SIGMATOT.EQ.0.d0)THEN
+ GETPNORAD1=1.d0
+ RETURN
+ ENDIF
+ GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)-
+ &SCATPRIMFUNC(0.d0,MD1))
+ & + GETXSECINT(UP,MD1,'QB'))/SIGMATOT
+ ENDIF
+ IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN
+ write(logfid,*)'error: P_norad=',GETPNORAD1,
+ & P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1
+ ENDIF
+ END
+
+
+***********************************************************************
+*** subroutine getqvec
+***********************************************************************
+ SUBROUTINE GETQVEC(L,J,DT,X)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--variables for coherent scattering
+ COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
+ &QSUMVEC(4),QSUM2
+ INTEGER NSTART,NEND
+ DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i
+ DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4),
+ &T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS,
+ &savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2,
+ &avmom(5)
+ CHARACTER TYPS
+ DATA PI/3.141592653589793d0/
+ DATA COUNTMAX/1000/
+
+ IF (J.GT.10000)THEN
+ discard = .true.
+ return
+ ENDIF
+
+ COUNTER=0
+ COUNT2=0
+
+ XSC=MV(L,1)+DT*P(L,1)/P(L,4)
+ YSC=MV(L,2)+DT*P(L,2)/P(L,4)
+ ZSC=MV(L,3)+DT*P(L,3)/P(L,4)
+ TSC=MV(L,4)+DT
+ md = GETMD(XSC,YSC,ZSC,TSC)
+
+ call AVSCATCEN(xsc,ysc,zsc,tsc,
+ &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+
+ do 210 i=1,5
+ savemom(i) = p(l,i)
+ 210 continue
+
+ xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8)
+ p(l,1) = xi*p(l,1)
+ p(l,2) = xi*p(l,2)
+ p(l,3) = xi*p(l,3)
+ p(l,4) = max(x*p(l,4),p(l,5))
+
+
+ 444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
+ &K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5))
+ MV(1,1)=XSC
+ MV(1,2)=YSC
+ MV(1,3)=ZSC
+ MV(1,4)=TSC
+ TYPS='Q'
+ IF(K(1,2).EQ.21)TYPS='G'
+
+ shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4)
+ & -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3))
+ pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat)
+ & -savemom(5)**2
+ maxt = 4.*pcms2
+
+ K(1,1)=13
+ SCATCENTRES(J,1)=K(1,2)
+ SCATCENTRES(J,2)=P(1,1)
+ SCATCENTRES(J,3)=P(1,2)
+ SCATCENTRES(J,4)=P(1,3)
+ SCATCENTRES(J,5)=P(1,4)
+ SCATCENTRES(J,6)=P(1,5)
+ SCATCENTRES(J,7)=MV(1,1)
+ SCATCENTRES(J,8)=MV(1,2)
+ SCATCENTRES(J,9)=MV(1,3)
+ SCATCENTRES(J,10)=MV(1,4)
+C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
+ BETA(1)=P(1,1)/P(1,4)
+ BETA(2)=P(1,2)/P(1,4)
+ BETA(3)=P(1,3)/P(1,4)
+ CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ THETA=PYP(L,13)
+ PHI=PYP(L,15)
+ CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
+C--pick a t from differential scattering cross section
+ 204 T=-GETT(0.d0,MAXT,md)
+ 202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5))
+ NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3))
+ PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
+ IF(DABS(PT2).LT.1.d-10) PT2=0.d0
+ IF(T.EQ.0.d0) PT2=0.d0
+ IF(PT2.LT.0.d0)THEN
+ T=0.d0
+ GOTO 202
+ ENDIF
+ PT=SQRT(PT2)
+ PHI2=PYR(0)*2*PI
+ NEWMOM(1)=PT*COS(PHI2)
+ NEWMOM(2)=PT*SIN(PHI2)
+ P(1,1)=NEWMOM(1)-P(L,1)
+ P(1,2)=NEWMOM(2)-P(L,2)
+ P(1,3)=NEWMOM(3)-P(L,3)
+ P(1,4)=NEWMOM(4)-P(L,4)
+ P(1,5)=0.d0
+C--transformation to lab
+ CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ ALLQS(J,1)=T
+ ALLQS(J,2)=P(1,1)
+ ALLQS(J,3)=P(1,2)
+ ALLQS(J,4)=P(1,3)
+ ALLQS(J,5)=P(1,4)
+ QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2)
+ QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3)
+ QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4)
+ QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5)
+ QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
+ IF(QSUM2.GT.0.d0)THEN
+ QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2)
+ QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3)
+ QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4)
+ QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5)
+ QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
+ IF(COUNTER.GT.COUNTMAX)THEN
+ write(logfid,*)'GETQVEC unable to find q vector'
+ ALLQS(J,1)=0.d0
+ ALLQS(J,2)=0.d0
+ ALLQS(J,3)=0.d0
+ ALLQS(J,4)=0.d0
+ ALLQS(J,5)=0.d0
+ ELSE
+ COUNTER=COUNTER+1
+ GOTO 444
+ ENDIF
+ ENDIF
+ do 211 i=1,5
+ p(l,i) = savemom(i)
+ 211 continue
+ END
+
+***********************************************************************
+*** subroutine dokinematics
+***********************************************************************
+ SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT,
+ & TIME,X,Z,QQBAR)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of formation times
+ COMMON/FTIMEFAC/FTFAC
+ DOUBLE PRECISION FTFAC
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--discard event flag
+ COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
+ LOGICAL DISCARD
+ INTEGER NDISC,NSTRANGE,NGOOD,errcount
+ double precision wdisc
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--variables for coherent scattering
+ COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10),
+ &QSUMVEC(4),QSUM2
+ INTEGER NSTART,NEND
+ DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
+C--number of scattering events
+ COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+ DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT,nspliti,nsplitf,nistry,
+ &nisfail,nfsfail,nfstry,nttot,ntrej
+C--event weight
+ COMMON/WEIGHT/EVWEIGHT,sumofweights
+ double precision EVWEIGHT,sumofweights
+C--extra storage for scattering centres before interactions
+ common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
+ &scatcen(23000,5),writescatcen,writedummies
+ integer nscatcen,maxnscatcen,scatflav
+ double precision scatcen
+ logical writescatcen,writedummies
+C--extra storage for dummy particles for subtraction
+ common/storedummies/dummies(10000,5)
+ double precision dummies
+C--local variables
+ INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold
+ DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T,
+ &NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp,
+ &m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old,
+ &newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2,
+ &ys,p3boost,pboost,m42,localt,oldt,precoil,qmass2,pdummy,pproj
+ double precision m4,z4,getmass,getms,getmd
+ double precision thetasub,phisub,rapsub
+ CHARACTER*2 TYP
+ LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle,
+ &softrec,splitrec,isrecoil
+ DATA PI/3.141592653589793d0/
+ data pdummy/1.d-6/
+
+ if (newm.ne.p(l,5)) then
+ if (p(l,5).lt.0.d0) then
+ nistry = nistry+evweight
+ else
+ nfstry = nfstry+evweight
+ endif
+ endif
+
+ IF((N+2*(n2-n1+1)).GT.22990)THEN
+ write(logfid,*)'event too long for event record'
+ DISCARD=.TRUE.
+ RETURN
+ ENDIF
+
+ if (k(l,1).eq.2) then
+ isrecoil = .true.
+ else
+ isrecoil = .false.
+ endif
+
+ firsttime = mv(l,5)
+
+ redokin = .false.
+ nttot=nttot+(n2-n1+1)*evweight
+
+ newm2=newm
+ nold=n
+ nscatcenold=nscatcen
+ colmaxold=colmax
+ statold=k(l,1)
+ 204 DELTAM=NEWM2-P(L,5)
+ DMLEFT=DELTAM
+
+ TTOT=0.d0
+ DO 220 J=N1,N2
+ TTOT=TTOT+ALLQS(J,1)
+ 220 CONTINUE
+
+ LINE=L
+
+ DO 222 J=N1,N2
+
+ splitrec = .false.
+C--projectile type
+ IF(K(LINE,2).EQ.21)THEN
+ TYP='GC'
+ IF(PYR(0).LT.0.5)THEN
+ DIR=1
+ ELSE
+ DIR=-1
+ ENDIF
+ ELSE
+ TYP='QQ'
+ DIR=0
+ ENDIF
+ K(1,1)=6
+ K(1,2)=SCATCENTRES(J,1)
+ P(1,1)=SCATCENTRES(J,2)
+ P(1,2)=SCATCENTRES(J,3)
+ P(1,3)=SCATCENTRES(J,4)
+ P(1,4)=SCATCENTRES(J,5)
+ P(1,5)=SCATCENTRES(J,6)
+ MV(1,1)=SCATCENTRES(J,7)
+ MV(1,2)=SCATCENTRES(J,8)
+ MV(1,3)=SCATCENTRES(J,9)
+ MV(1,4)=SCATCENTRES(J,10)
+ T=ALLQS(J,1)
+ if (t.eq.0.d0) then
+ rejectt = .true.
+ else
+ rejectt = .false.
+ endif
+
+ IF(TTOT.EQ.0.d0)THEN
+ DM=0.d0
+ ELSE
+ if (dmleft.lt.0.d0) then
+ DM=max(DMLEFT*T/TTOT*1.5d0,dmleft)
+ else
+ DM=min(DMLEFT*T/TTOT*1.5d0,dmleft)
+ endif
+ ENDIF
+ TTOT=TTOT-ALLQS(J,1)
+
+C--transform to c.m.s. and rotate such that parton momentum is in z-direction
+ BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4))
+ BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4))
+ BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4))
+ IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0)
+ & .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN
+ reshuffle = .false.
+ else
+ reshuffle = .true.
+ endif
+! reshuffle = .false.
+ 205 if (.not.reshuffle) then
+ BETA(1)=P(1,1)/P(1,4)
+ BETA(2)=P(1,2)/P(1,4)
+ BETA(3)=P(1,3)/P(1,4)
+ CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ THETA=PYP(LINE,13)
+ PHI=PYP(LINE,15)
+ CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
+
+ if (kinmode.eq.0)then
+ m42 = 0.d0
+ elseif (kinmode.eq.1)then
+ m42 = p(1,5)**2
+ else
+ if (scalefacm*sqrt(-t).gt.q0) then
+ m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
+ & p(1,4),.false.,z4,qqbardec)
+ if (m4.gt.0.d0) splitrec = .true.
+ m42 = m4**2
+ else
+ m42 = p(1,5)**2
+ endif
+ endif
+ if (t.eq.0.d0) m42 = p(1,5)**2
+ maxt = -2.*p(1,5)*p(line,4) - p(1,5)**2 + m42
+ if (t.lt.maxt) then
+ t=0.d0
+ rejectt = .true.
+ dm = 0.d0
+ m42 = p(1,5)**2
+ endif
+ m12 = -p(line,5)**2
+ 203 newmass = p(line,5)+dm
+ if (newmass.lt.0.d0) then
+ m32 = -NEWMASS**2
+ else
+ m32 = NEWMASS**2
+ endif
+ if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
+ localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
+ oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
+ if (localt.gt.0.d0) then
+ m32 = (p(l,5)*localt/oldt)**2
+ newm2 = sqrt(m32)
+ endif
+ endif
+ if (t.eq.0.d0) then
+ enew = p(line,4)
+ else
+ enew = p(line,4)+(t+p(1,5)**2-m42)/(2.*p(1,5))
+ endif
+ pl = (t+2.*p(line,4)*enew-m12-m32)/(2.*p(line,3))
+ pt2 = enew**2-pl**2-m32
+ if (t.eq.0.d0) pt2 = 0.d0
+ if (dabs(pt2).lt.1.d-8) pt2 = 0.d0
+ if (pt2.lt.0.d0) then
+ if (splitrec) then
+ m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
+ & p(1,4),.false.,z4,qqbardec)
+ if (m4.eq.0.d0) splitrec = .false.
+ m42 = m4**2
+ goto 203
+ endif
+ if (dm.ne.0.d0) then
+ dm = 0.d0
+ goto 203
+ else
+ write(logfid,*)' This should not have happened: pt^2<0!'
+ write(logfid,*)t,enew,pl,pt2
+ t = 0.d0
+ m42 = p(1,5)**2
+ rejectt = .true.
+ goto 203
+ endif
+ endif
+ pt = sqrt(pt2)
+ phi2 = pyr(0)*2.*pi
+ n=n+2
+ p(n,1)=pt*cos(phi2)
+ p(n,2)=pt*sin(phi2)
+ p(n,3)=pl
+ p(n,4)=enew
+ p(n,5)=sign(sqrt(abs(m32)),newmass)
+!---------------------------------
+ P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
+ P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
+ P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
+ P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
+ mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
+ if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
+ if (mass2.lt.0.d0)
+ & write(logfid,*)'messed up scattering centres mass^2: ',
+ & mass2,p(1,5)**2
+ P(N-1,5)=SQRT(mass2)
+ if (abs(p(n-1,5)-sqrt(m42)).gt.1.d-6)
+ & write(logfid,*)'messed up scattering centres mass (no rs): ',
+ & p(n-1,5),p(1,5),p(l,5),sqrt(m42),rejectt
+ call flush(logfid)
+!---------------------------------
+! P(N-1,1)=P(1,1)
+! P(N-1,2)=P(1,2)
+! P(N-1,3)=P(1,3)
+! P(N-1,4)=P(1,4)
+! P(N-1,5)=P(1,5)
+!---------------------------------
+ else
+ CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3))
+ if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then
+ CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ reshuffle = .false.
+ goto 205
+ endif
+ THETA=PYP(LINE,13)
+ PHI=PYP(LINE,15)
+ CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0)
+ shat = (p(1,4)+p(line,4))**2
+ p3old = p(line,3)
+
+ maxt = -4.*p(line,3)**2
+ if (t.lt.maxt) then
+ t=0.d0
+ rejectt = .true.
+ ntrej=ntrej+evweight
+ endif
+ theta2 = acos(1.d0+t/(2.*p(line,3)**2))
+ phi2 = pyr(0)*2.*pi
+ n=n+2
+ p(n,1)=p(line,3)*sin(theta2)*cos(phi2)
+ p(n,2)=p(line,3)*sin(theta2)*sin(phi2)
+ p(n,3)=p(line,3)*cos(theta2)
+ p(n,4)=p(line,4)
+ p(n,5)=p(line,5)
+!---------------------------------
+ P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1)
+ P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2)
+ P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3)
+ P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4)
+ mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2
+ if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
+ if (mass2.lt.0.d0)
+ & write(logfid,*)'messed up scattering centres mass^2: ',
+ & mass2,p(1,5)**2
+ P(N-1,5)=SQRT(mass2)
+ if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
+ & write(logfid,*)'messed up scattering centres mass: ',
+ & p(n-1,5),p(1,5),p(l,5)
+ call flush(logfid)
+!---------------------------------
+! P(N-1,1)=P(1,1)
+! P(N-1,2)=P(1,2)
+! P(N-1,3)=P(1,3)
+! P(N-1,4)=P(1,4)
+! P(N-1,5)=P(1,5)
+!---------------------------------
+ endif
+C--outgoing projectile
+ K(N,1)=K(LINE,1)
+ if (isrecoil.and.(newm.gt.p(l,5)).and.(p(n,5).gt.q0)
+ & .and.(j.eq.n2)) then
+ k(n,1)=1
+ endif
+ K(N,2)=K(LINE,2)
+! K(N,3)=L
+ K(N,3)=LINE
+ K(N,4)=0
+ K(N,5)=0
+ ZA(N)=1.d0
+ THETAA(N)=-1.d0
+ if ((k(n,1).eq.2).and.(z.eq.0.d0)) then
+ zd(n) = -1.d0
+ else
+ ZD(N)=Z
+ endif
+ QQBARD(N)=QQBAR
+C--take care of incoming projectile
+ IF(K(LINE,1).EQ.1)THEN
+ K(LINE,1)=12
+ ELSE
+ write(*,*)line,k(line,1)
+ K(LINE,1)=14
+ call pevrec(2,.false.)
+ call exit(1)
+ ENDIF
+ K(LINE,4)=N-1
+ K(LINE,5)=N
+C--temporary status code, will be overwritten later
+ K(N-1,1)=3
+ K(N-1,2)=21
+ K(N-1,3)=0
+ K(N-1,4)=0
+ K(N-1,5)=0
+
+ if (reshuffle) then
+C--adjust mass and re-shuffle momenta
+
+ if (kinmode.eq.0) then
+ m42 = 0.d0
+ elseif (kinmode.eq.1) then
+ m42 = p(1,5)**2
+ else
+ if (scalefacm*sqrt(-t).gt.q0) then
+ m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ,
+ & p(1,4),.false.,z4,qqbardec)
+ if (m4.gt.0.d0) splitrec = .true.
+ m42 = m4**2
+ else
+ m42 = p(1,5)**2
+ endif
+ endif
+ 206 newmass = p(n,5)+dm
+ if (newmass.lt.0.d0) then
+ m32 = -NEWMASS**2
+ else
+ m32 = NEWMASS**2
+ endif
+ if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then
+ localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
+ oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4))
+ if (localt.gt.0.d0) then
+ m32 = (p(l,5)*localt/oldt)**2
+ newm2 = sqrt(m32)
+ endif
+ endif
+ if (t.eq.0.d0) m42 = p(1,5)**2
+ E3new = (shat + m32 - m42)/(2.d0*sqrt(shat))
+ E4new = (shat - m32 + m42)/(2.d0*sqrt(shat))
+ p32 = E3new**2 - m32
+ p42 = E4new**2 - m42
+ if ((p32.lt.0.d0).or.(p42.lt.0.d0).or.
+ & (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
+ if (m42.eq.0.d0) then
+ p42 = 1.d-4
+ else
+ p42 = 0.d0
+ endif
+ E4new = sqrt(p42 + m42)
+ E3new = sqrt(shat) - E4new
+ p32 = E4new**2 - m42
+ m32 = E3new**2 - E4new**2 + m42
+ if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then
+ if (splitrec) then
+ m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ,
+ & p(1,4),.false.,z4,qqbardec)
+ if (m4.eq.0.d0) splitrec = .false.
+ m42 = m4**2
+ goto 206
+ endif
+ if (dm.ne.0.d0) then
+ dm = 0.d0
+ goto 206
+ endif
+ m42 = p(1,5)**2
+ E3new = p(n,4)
+ E4new = p(n-1,4)
+ p32 = p3old**2
+ p42 = p3old**2
+ if (p(n,5).lt.0.d0) then
+ m32 = -p(n,5)**2
+ else
+ m32 = p(n,5)**2
+ endif
+ endif
+ endif
+ p(n,1) = sqrt(p32)*p(n,1)/p3old
+ p(n,2) = sqrt(p32)*p(n,2)/p3old
+ p(n,3) = sqrt(p32)*p(n,3)/p3old
+ p(n,4) = E3new
+ p(n,5) = sign(sqrt(abs(m32)),newmass)
+ tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2-m32
+ if (abs(tmp).gt.1.d-6)
+ & write(logfid,*) 'Oups, messed up projectiles mass (rs):',
+ & tmp,m32,p(n,5),dm,m42,p32
+!---------------------------------
+ p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old
+ p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old
+ p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old
+ p(n-1,4) = E4new
+ p(n-1,5) = sqrt(m42)
+ tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
+ & -p(n-1,5)**2
+ if (abs(tmp).gt.1.d-6)
+ & write(logfid,*) 'Oups, messed up scattering centres mass (rs):',
+ & tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
+ if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or.
+ & (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or.
+ & (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) then
+ write(logfid,*) 'Oups, momentum not conserved (rs)',
+ & p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3)
+ write(logfid,*) m42,dm,E3new,E4new
+ endif
+!---------------------------------
+! P(N-1,1)=P(1,1)
+! P(N-1,2)=P(1,2)
+! P(N-1,3)=P(1,3)
+! P(N-1,4)=P(1,4)
+! P(N-1,5)=P(1,5)
+!---------------------------------
+ endif
+! write(*,*)((p(n-1,4)-p(1,4))**2-(p(n-1,1)-p(1,1))**2
+! & -(p(n-1,2)-p(1,2))**2-(p(n-1,3)-p(1,3))**2)/t
+
+C--transformation to lab
+ CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0)
+ CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3))
+ if (.not.allhad) then
+ k(n-1,1)=13
+ softrec=.false.
+ else
+C--boost to fluid rest frame
+ ys = 0.5*log((mv(1,4)+mv(1,3))/(mv(1,4)-mv(1,3)))
+ p3boost = sinh(-ys)*p(n-1,4) + cosh(-ys)*p(n-1,3)
+ pboost = sqrt(p3boost**2+p(n-1,1)**2+p(n-1,2)**2)
+ localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
+ if (pboost.lt.(recsoftcut*3.*localt)) then
+ softrec = .true.
+ k(n-1,1)=13
+ else
+ softrec = .false.
+ if (scatrecoil.and.(pboost.GT.(rechardcut*3.*localt))) THEN
+ K(N-1,1)=2
+ else
+ K(N-1,1)=3
+ ENDIF
+ endif
+ endif
+ if (rejectt) k(n-1,1)=11
+C--outgoing projectile
+ IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
+ IF(K(N,2).EQ.21)THEN
+ IF(DIR.EQ.1)THEN
+ TRIP(N)=COLMAX+1
+ ANTI(N)=ANTI(LINE)
+ ELSE
+ TRIP(N)=TRIP(LINE)
+ ANTI(N)=COLMAX+1
+ ENDIF
+ ELSEIF(K(N,2).GT.0)THEN
+ TRIP(N)=COLMAX+1
+ ANTI(N)=0
+ ELSE
+ TRIP(N)=0
+ ANTI(N)=COLMAX+1
+ ENDIF
+ COLMAX=COLMAX+1
+ ELSE
+ TRIP(N)=TRIP(LINE)
+ ANTI(N)=ANTI(LINE)
+ ENDIF
+C--outgoing scattering centre
+ IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN
+ IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN
+ TRIP(N-1)=TRIP(LINE)
+ ANTI(N-1)=TRIP(N)
+ ELSE
+ TRIP(N-1)=ANTI(N)
+ ANTI(N-1)=ANTI(LINE)
+ ENDIF
+ ELSE
+ TRIP(N-1)=0
+ ANTI(N-1)=0
+ ENDIF
+C--outgoing scattering centre
+ if (splitrec) then
+ if (k(n-1,1).eq.2) k(n-1,1)=1
+ ZA(N-1)=1.d0
+ THETAA(N-1)=P(n-1,5)/(SQRT(Z4*(1.-Z4))*P(n-1,4))
+ ZD(N-1)=z4
+ QQBARD(N-1)=qqbardec
+ else
+ ZA(N-1)=1.d0
+ THETAA(N-1)=-1.d0
+ ZD(N-1)=-1.d0
+ QQBARD(N-1)=.false.
+ endif
+ MV(N,4)=MV(1,4)
+ MV(N-1,4)=MV(1,4)
+C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
+ MV(N-1,1)=MV(line,1)
+ & +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
+ MV(N-1,2)=MV(line,2)
+ & +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
+ MV(N-1,3)=MV(line,3)
+ & +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
+ MV(N, 1)=MV(line,1)
+ & +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4))
+ MV(N, 2)=MV(line,2)
+ & +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4))
+ MV(N, 3)=MV(line,3)
+ & +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4))
+ IF(P(N-1,5).GT.P(1,5))THEN
+ LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2)
+ MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ MV(N-1,5)=0.d0
+ ENDIF
+ IF(J.LT.N2)THEN
+ MV(N,5)=SCATCENTRES(J+1,10)
+ ELSE
+ IF(P(N,5).GT.0.d0)THEN
+ IF(DELTAM.EQ.0.d0)THEN
+ ENDTIME=firsttime
+ ELSE
+ IF(X.LT.1.d0)THEN
+ LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2)
+ ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA
+ ELSE
+ ENDTIME=TIME
+ ENDIF
+ ENDIF
+ MV(N,5)=ENDTIME
+ ELSE
+ MV(N,5)=0.d0
+ ENDIF
+ ENDIF
+ MV(LINE,5)=ALLQS(J,6)
+
+ if ((.not.redokin).and.(.not.rejectt)) NSCAT=NSCAT+EVWEIGHT
+
+C--store scattering centre before interaction in separate common block
+ if (writescatcen.and.(.not.rejectt).and.
+ & (nscatcen.lt.maxnscatcen)) then
+ nscatcen = nscatcen+1
+ if (nscatcen.gt.maxnscatcen) then
+ write(logfid,*)
+ &'WARNING: no room left to store further scattering centres'
+ goto 230
+ endif
+ if (recmode.eq.0) then
+ if (.not.softrec) then
+ scatflav(nscatcen) = k(1,2)
+ scatcen(nscatcen,1) = p(1,1)
+ scatcen(nscatcen,2) = p(1,2)
+ scatcen(nscatcen,3) = p(1,3)
+ scatcen(nscatcen,4) = p(1,4)
+ scatcen(nscatcen,5) = p(1,5)
+C--------------------
+c phisub = pyp(1,15)
+c rapsub = pyp(1,17)
+c thetasub = 2.*atan(exp(-rapsub))
+c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
+c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
+c dummies(nscatcen,3) = pdummy*cos(thetasub)
+c dummies(nscatcen,4) = pdummy
+c dummies(nscatcen,5) = 0.d0
+C--------------------
+ dummies(nscatcen,1) = scatcen(nscatcen,1)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,2) = scatcen(nscatcen,2)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,3) = scatcen(nscatcen,3)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
+ & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
+ & dummies(nscatcen,3)**2)
+C--------------------
+ endif
+ elseif (recmode.eq.1) then
+ if (.not.softrec) then
+ scatflav(nscatcen) = k(1,2)
+ scatcen(nscatcen,1) = p(1,1)
+ scatcen(nscatcen,2) = p(1,2)
+ scatcen(nscatcen,3) = p(1,3)
+ scatcen(nscatcen,4) = p(1,4)
+ scatcen(nscatcen,5) = p(1,5)
+! precoil = sqrt(p(n-1,1)**2+p(n-1,2)**2+p(n-1,3)**2)
+! dummies(nscatcen,1) = pdummy*p(n-1,1)/precoil
+! dummies(nscatcen,2) = pdummy*p(n-1,2)/precoil
+! dummies(nscatcen,3) = pdummy*p(n-1,3)/precoil
+! dummies(nscatcen,4) = pdummy
+C--------------------
+c phisub = pyp(n-1,15)
+c rapsub = pyp(n-1,17)
+c thetasub = 2.*atan(exp(-rapsub))
+c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
+c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
+c dummies(nscatcen,3) = pdummy*cos(thetasub)
+c dummies(nscatcen,4) = pdummy
+c dummies(nscatcen,5) = 0.d0
+C--------------------
+ dummies(nscatcen,1) = p(n-1,1)*pdummy/p(n-1,4)
+ dummies(nscatcen,2) = p(n-1,2)*pdummy/p(n-1,4)
+ dummies(nscatcen,3) = p(n-1,3)*pdummy/p(n-1,4)
+ dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
+ & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
+ & dummies(nscatcen,3)**2)
+C--------------------
+ endif
+ elseif (recmode.eq.2) then
+ scatflav(nscatcen) = k(1,2)
+ scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
+ scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
+ scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
+ scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
+ qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
+ & - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
+ scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
+! precoil = sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
+! & +scatcen(nscatcen,3)**2)
+! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
+! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
+! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
+! dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,1) = scatcen(nscatcen,1)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,2) = scatcen(nscatcen,2)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,3) = scatcen(nscatcen,3)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
+ & dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
+ & dummies(nscatcen,4)**2)
+ if (scatcen(nscatcen,4).lt.0.d0) then
+ dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
+ dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
+ dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
+ endif
+ elseif (recmode.eq.3) then
+ if (softrec) then
+ scatflav(nscatcen) = k(1,2)
+ scatcen(nscatcen,1) = p(n-1,1) - p(1,1)
+ scatcen(nscatcen,2) = p(n-1,2) - p(1,2)
+ scatcen(nscatcen,3) = p(n-1,3) - p(1,3)
+ scatcen(nscatcen,4) = p(n-1,4) - p(1,4)
+ qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2
+ & - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2
+ scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2)
+! precoil=sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2
+! & +scatcen(nscatcen,3)**2)
+! dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil
+! dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil
+! dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil
+! dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,1) = scatcen(nscatcen,1)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,2) = scatcen(nscatcen,2)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,3) = scatcen(nscatcen,3)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 +
+ & dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 -
+ & dummies(nscatcen,4)**2)
+ if (scatcen(nscatcen,4).lt.0.d0) then
+ dummies(nscatcen,1) = -1.*dummies(nscatcen,1)
+ dummies(nscatcen,2) = -1.*dummies(nscatcen,2)
+ dummies(nscatcen,3) = -1.*dummies(nscatcen,3)
+ endif
+ else
+ scatflav(nscatcen) = k(1,2)
+ scatcen(nscatcen,1) = p(1,1)
+ scatcen(nscatcen,2) = p(1,2)
+ scatcen(nscatcen,3) = p(1,3)
+ scatcen(nscatcen,4) = p(1,4)
+ scatcen(nscatcen,5) = p(1,5)
+C--------------------
+c phisub = pyp(1,15)
+c rapsub = pyp(1,17)
+c thetasub = 2.*atan(exp(-rapsub))
+c dummies(nscatcen,1) = pdummy*sin(thetasub)*cos(phisub)
+c dummies(nscatcen,2) = pdummy*sin(thetasub)*sin(phisub)
+c dummies(nscatcen,3) = pdummy*cos(thetasub)
+c dummies(nscatcen,4) = pdummy
+c dummies(nscatcen,5) = 0.d0
+C--------------------
+ dummies(nscatcen,1) = scatcen(nscatcen,1)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,2) = scatcen(nscatcen,2)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,3) = scatcen(nscatcen,3)*
+ & pdummy/scatcen(nscatcen,4)
+ dummies(nscatcen,4) = pdummy
+ dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 -
+ & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 -
+ & dummies(nscatcen,3)**2)
+C--------------------
+ endif
+ endif
+ endif
+ 230 continue
+
+! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then
+! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5)
+! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5)
+! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5)
+! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
+! write(*,*)t
+! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
+! write(*,*)
+! endif
+
+ DMLEFT=DMLEFT-(p(n,5)-P(LINE,5))
+ LINE=N
+ tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2
+ if (abs(tmp).ge.1.d-6)
+ & write(logfid,*)'dokinematics 4-momentum test failed:',
+ & tmp,j,p(l,5),p(line,5),p(n,5),reshuffle
+ 222 CONTINUE
+ if (p(n,5).lt.0.d0) then
+ nisfail = nisfail+evweight
+ RETRYSPLIT=.TRUE.
+ return
+ endif
+ if (p(n,5).ne.newm2) then
+ RETRYSPLIT=.TRUE.
+ redokin = .true.
+ nfsfail = nfsfail+evweight
+ n=nold
+ colmax=colmaxold
+ nscatcen=nscatcenold
+ k(l,1)=statold
+ if (p(l,5).lt.0.d0) then
+ newm2 = 0.d0
+ else
+ if ((p(l,5).lt.q0).and.(k(l,1).ne.14)) then
+ if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then
+ newm2=q0+1.d-6
+ else
+ newm2=0.d0
+! nisfail = nisfail+evweight
+! RETRYSPLIT=.TRUE.
+! write(*,*)'dokinematics takes the dubious exit'
+! return
+ endif
+ else
+ newm2=p(l,5)
+ if (k(l,1).eq.14) z = 0.d0
+ endif
+ n2=n1
+ endif
+ goto 204
+ endif
+ if ((k(n,1).eq.1).and.
+ & ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))))
+ &write(logfid,*)'dokinematics did not reach sensible mass: ',l,
+ &p(n,5),newm,p(l,5),newm2
+ NSCATEFF=NSCATEFF+EVWEIGHT
+ END
+
+
+
+***********************************************************************
+*** function getproba
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE,
+ & T1,INS2)
+ IMPLICIT NONE
+C--variables for Sudakov integration
+ COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
+ DOUBLE PRECISION QA,ZA2,EB,T
+ CHARACTER*2 TYP
+ LOGICAL INSTATE
+C--local variables
+ DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1
+ CHARACTER*2 TYPE
+ LOGICAL INS2
+
+ QA=QAA
+ ZA2=ZAA
+ EB=EBB
+ TYP=TYPE
+ T=T1
+ INSTATE=INS2
+ GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2)
+ & *DERIV(QF,1)
+ END
+
+
+***********************************************************************
+*** function getsudakov
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
+ & TYPE3,T2,INS)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for Sudakov integration
+ COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
+ DOUBLE PRECISION QA,ZA2,EB,T
+ CHARACTER*2 TYP
+ LOGICAL INSTATE
+C--local variables
+ DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI,
+ &HFIRST,T2,GETINSUDAFAST,QB2
+ CHARACTER*2 TYPE3
+ LOGICAL INS
+ DATA EPSI/1.d-4/
+
+ QB2=QB1
+ IF(INS)THEN
+ IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1
+ IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
+ ELSE
+ IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1
+ IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10
+ ENDIF
+ IF(QB2.GE.(QMAX1-1.d-10)) THEN
+ GETSUDAKOV=1.d0
+ ELSE
+ IF(INS)THEN
+ GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3)
+ ELSE
+ QA=QA1
+ ZA2=ZA1
+ EB=EB1
+ TYP=TYPE3
+ T=T2
+ INSTATE=.FALSE.
+ HFIRST=0.01*(QMAX1-QB1)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1)
+ GETSUDAKOV=EXP(-YSTART)
+ ENDIF
+ ENDIF
+ END
+
+
+***********************************************************************
+*** function getinsudakov
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for Sudakov integration
+ COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
+ DOUBLE PRECISION QA,ZA2,EB,T
+ CHARACTER*2 TYP
+ LOGICAL INSTATE
+C--local variables
+ DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI,
+ &HFIRST
+ CHARACTER*2 TYPE3
+ DATA EPSI/1.d-4/
+
+ QB1=QB
+ IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1
+ IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12
+ IF(QB1.GE.(QMAX1-1.d-12)) THEN
+ GETINSUDAKOV=1.d0
+ ELSE
+ TYP=TYPE3
+ HFIRST=0.01*(QMAX1-QB1)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6)
+ GETINSUDAKOV=EXP(-YSTART)
+ ENDIF
+ END
+
+
+***********************************************************************
+*** function deriv
+***********************************************************************
+ DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for splitting function integration
+ COMMON/INTSPLITF/QQUAD,FM
+ DOUBLE PRECISION QQUAD,FM
+C--variables for Sudakov integration
+ COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP
+ DOUBLE PRECISION QA,ZA2,EB,T
+ CHARACTER*2 TYP
+ LOGICAL INSTATE
+C--variables for pdf integration
+ COMMON/PDFINTV/XMAX,Z
+ DOUBLE PRECISION XMAX,Z
+C--variables for cross section integration
+ COMMON/XSECV/QLOW,MDX
+ DOUBLE PRECISION QLOW,MDX
+C--local variables
+ INTEGER W4
+ DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI,
+ &GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ,
+ &MEDDERIV
+ DATA PI/3.141592653589793d0/
+
+ IF(W4.EQ.1)THEN
+C--Sudakov integration
+ IF(INSTATE)THEN
+ DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
+ ELSE
+ DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL
+ ENDIF
+ ELSEIF(W4.EQ.2)THEN
+C--P(q->qg) integration
+ DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)*
+ & PQQ(XVAL)/(2.*PI)
+ ELSEIF(W4.EQ.3)THEN
+C--P(g->gg) integration
+ DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)
+ & *PGG(XVAL)/(2.*PI)
+ ELSEIF(W4.EQ.4)THEN
+C--P(g->qq) integration
+ DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)*
+ & PQG(XVAL)/(2.*PI)
+ ELSEIF(W4.EQ.5)THEN
+ DERIV=EXP(-XVAL)/XVAL
+ ELSEIF(W4.EQ.6)THEN
+ DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
+ ELSEIF(W4.EQ.7)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
+ & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
+ & *PQQ(Z)/(2.*PI*XVAL)
+ ELSEIF(W4.EQ.8)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
+ & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
+ & *PGQ(Z)/(2.*PI*XVAL)
+ ELSEIF(W4.EQ.9)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
+ & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)
+ & *PQG(Z)/(2.*PI*XVAL)
+ ELSEIF(W4.EQ.10)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
+ & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)*
+ & *2.*PGG(Z)/(2.*PI*XVAL)
+ ELSEIF(W4.EQ.11)THEN
+ DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ')
+ & *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL)
+ ELSEIF(W4.EQ.12)THEN
+ DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG')
+ & *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL)
+ ELSEIF(W4.EQ.13)THEN
+ DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC')
+ & *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2)
+ ELSEIF(W4.EQ.14)THEN
+ DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ')
+ & *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2)
+ ELSEIF(W4.EQ.21)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ')
+ & /XVAL
+ ELSEIF(W4.EQ.22)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ')
+ & /XVAL
+ ELSEIF(W4.EQ.23)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG')
+ & /XVAL
+ ELSEIF(W4.EQ.24)THEN
+ DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2.
+ & *GETINSPLITI(XVAL,'GG')/XVAL
+ ELSE
+ DERIV=MEDDERIV(XVAL,W4-100)
+ ENDIF
+ END
+
+
+***********************************************************************
+*** function getspliti
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--splitting integral
+ COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
+ &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
+ INTEGER NPOINT
+ DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
+ &QVAL,ZMVAL,QMAX,ZMMIN
+C--variables for splitting function integration
+ COMMON/INTSPLITF/QQUAD,FM
+ DOUBLE PRECISION QQUAD,FM
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--local variables
+ INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE
+ DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y,
+ &SPLITINTGG,SPLITINTQG,A,B,YB(2)
+ CHARACTER*2 TYPE1
+
+ ntotspliti=ntotspliti+1
+ if (qb.gt.qmax) then
+ noverspliti=noverspliti+1
+ if (noverspliti.le.25)
+ & write(logfid,*)'WARNING in getspliti: need to extrapolate: ',
+ & qb,qmax
+ endif
+
+C--find boundaries for z integration
+ IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
+ LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2)
+ & *SQRT(1.-QB**2/EB**2),
+ & 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)))
+ ELSE
+ LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2)
+ & *SQRT(1.-QB**2/EB**2)
+ ENDIF
+C--find values in array
+ QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1)
+ QLINE=MAX(QLMAX,1)
+ QLINE=MIN(QLINE,NPOINT)
+ ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/
+ & (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1)
+ ZLINE=MAX(ZLMAX,1)
+ ZLINE=MIN(ZLINE,NPOINT)
+ IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR.
+ & (QLINE.LT.1).OR.(ZLINE.LT.1))THEN
+ write(logfid,*)'ERROR in GETSPLITI: line number out of bound',
+ & QLINE,ZLINE
+ ENDIF
+ IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
+ DO 17 I=1,2
+ X1A(I)=QVAL(QLINE-1+I)
+ X2A(I)=ZMVAL(ZLINE-1+I)
+ DO 16 J=1,2
+ YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
+ 16 CONTINUE
+ 17 CONTINUE
+ DO 30 I=1,2
+ A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
+ B=YA(I,1)-A*X2A(1)
+ YB(I)=A*LOW+B
+ 30 CONTINUE
+ IF(X1A(1).EQ.X1A(2))THEN
+ Y=(YB(1)+YB(2))/2.
+ ELSE
+ A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
+ B=YB(1)-A*X1A(1)
+ Y=A*QB+B
+ ENDIF
+ IF(TYPE1.EQ.'GG')THEN
+ GETSPLITI=MIN(Y,10.d0)
+ ELSE
+ SPLITINTGG=MIN(Y,10.d0)
+ ENDIF
+ ENDIF
+ IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
+ DO 19 I=1,2
+ X1A(I)=QVAL(QLINE-1+I)
+ X2A(I)=ZMVAL(ZLINE-1+I)
+ DO 18 J=1,2
+ YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
+ 18 CONTINUE
+ 19 CONTINUE
+ DO 31 I=1,2
+ A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
+ B=YA(I,1)-A*X2A(1)
+ YB(I)=A*LOW+B
+ 31 CONTINUE
+ IF(X1A(1).EQ.X1A(2))THEN
+ Y=(YB(1)+YB(2))/2.
+ ELSE
+ A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
+ B=YB(1)-A*X1A(1)
+ Y=A*QB+B
+ ENDIF
+ IF(TYPE1.EQ.'QG')THEN
+ GETSPLITI=NF*MIN(Y,10.d0)
+ ELSE
+ SPLITINTQG=NF*MIN(Y,10.d0)
+ ENDIF
+ ENDIF
+ IF(TYPE1.EQ.'QQ')THEN
+ DO 21 I=1,2
+ X1A(I)=QVAL(QLINE-1+I)
+ X2A(I)=ZMVAL(ZLINE-1+I)
+ DO 20 J=1,2
+ YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
+ 20 CONTINUE
+ 21 CONTINUE
+ DO 32 I=1,2
+ A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
+ B=YA(I,1)-A*X2A(1)
+ YB(I)=A*LOW+B
+ 32 CONTINUE
+ IF(X1A(1).EQ.X1A(2))THEN
+ Y=(YB(1)+YB(2))/2.
+ ELSE
+ A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
+ B=YB(1)-A*X1A(1)
+ Y=A*QB+B
+ ENDIF
+ GETSPLITI=MIN(Y,10.d0)
+ ENDIF
+ IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
+ END
+
+
+***********************************************************************
+*** function getinspliti
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI
+ CHARACTER*2 TYPE1
+ DATA PI/3.141592653589793d0/
+
+C--find boundaries for z integration
+ UP = 1. - Q0**2/(4.*QB**2)
+ IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
+ LOW=1.d0-UP
+ IF (UP.LE.LOW) THEN
+ GETINSPLITI=0.d0
+ RETURN
+ ENDIF
+ Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2))
+ & - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
+ & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
+ & - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
+ & - LOG(LOG((1.-UP)*QB**2/LPS**2))
+ & + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
+ & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
+ & + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
+ & + LOW - LOG(LOW) - UP + LOG(UP) )
+ & *3.*12.*PI/(2.*PI*(33.-2.*NF))
+ IF(TYPE1.EQ.'GG')THEN
+ GETINSPLITI=Y
+ ELSE
+ SPLITINTGG=Y
+ ENDIF
+ ENDIF
+ IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
+ LOW=0.d0
+ IF (UP.LE.LOW) THEN
+ GETINSPLITI=0.d0
+ RETURN
+ ENDIF
+ Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6
+ & - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
+ & + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
+ & - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6
+ & + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4
+ & - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 )
+ & *12.*PI/(2.*2.*PI*(33.-2.*NF))
+ IF(TYPE1.EQ.'QG')THEN
+ GETINSPLITI=NF*Y
+ ELSE
+ SPLITINTQG=NF*Y
+ ENDIF
+ ENDIF
+ IF(TYPE1.EQ.'QQ')THEN
+ LOW=0.d0
+ IF (UP.LE.LOW) THEN
+ GETINSPLITI=0.d0
+ RETURN
+ ENDIF
+ Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
+ & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
+ & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
+ & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
+ & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
+ & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
+ & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
+ GETINSPLITI=Y
+ ENDIF
+ IF(TYPE1.EQ.'GQ')THEN
+ LOW=1.d0-UP
+ IF (UP.LE.LOW) THEN
+ GETINSPLITI=0.d0
+ RETURN
+ ENDIF
+ Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW))
+ & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2))
+ GETINSPLITI=Y
+ ENDIF
+ IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
+ END
+
+
+***********************************************************************
+*** function getpdf
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--pdf common block
+ COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
+ &GINGX(2,1000)
+ DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for pdf integration
+ COMMON/PDFINTV/XMAX,Z
+ DOUBLE PRECISION XMAX,Z
+C--local variables
+ DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST
+ CHARACTER*2 TYP
+ DATA EPSI/1.d-4/
+
+ IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN
+ write(logfid,*)'error in GETPDF: parameter out of bound',X,Q
+ GETPDF=0.d0
+ RETURN
+ ENDIF
+
+ IF(TYP.EQ.'QQ')THEN
+ Z=X
+ XMAX=Q
+C--f_q^q
+ QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
+ QHIGH=Q
+ IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
+ YSTART=0.d0
+ ELSE
+ HFIRST=0.01*(QHIGH-QLOW)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7)
+ ENDIF
+ GETPDF=YSTART
+ ELSEIF(TYP.EQ.'GQ')THEN
+ Z=X
+ XMAX=Q
+C--f_q^g
+ QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
+ QHIGH=Q
+ IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
+ & .OR.(X.GT.1.d0-1.d-10))THEN
+ YSTART=0.d0
+ ELSE
+ HFIRST=0.01*(QHIGH-QLOW)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8)
+ ENDIF
+ GETPDF=YSTART
+ ELSEIF(TYP.EQ.'QG')THEN
+ Z=X
+ XMAX=Q
+C--f_q^g
+ QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X)))
+ QHIGH=Q
+ IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
+ YSTART=0.d0
+ ELSE
+ HFIRST=0.01*(QHIGH-QLOW)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9)
+ ENDIF
+ GETPDF=YSTART
+ ELSEIF(TYP.EQ.'GG')THEN
+ Z=X
+ XMAX=Q
+C--f_q^q
+ QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X))))
+ QHIGH=Q
+ IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10)
+ & .OR.(X.GT.1.d0-1d-10))THEN
+ YSTART=0.d0
+ ELSE
+ HFIRST=0.01*(QHIGH-QLOW)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10)
+ ENDIF
+ GETPDF=YSTART
+ ELSE
+ write(logfid,*)'error: pdf-type ',TYP,' does not exist'
+ GETPDF=0.d0
+ ENDIF
+ END
+
+***********************************************************************
+*** function getpdfxint
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--pdf common block
+ COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
+ &GINGX(2,1000)
+ DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--local variables
+ INTEGER J,Q2CLOSE,Q2LINE
+ DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
+ CHARACTER*2 TYP
+
+ ntotpdf=ntotpdf+1
+ if (q**2.gt.QINQX(1,1000)) then
+ noverpdf=noverpdf+1
+ if (noverpdf.le.25)
+ & write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ',
+ & q**2,QINQX(1,1000)
+ endif
+
+ Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/
+ & (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1)
+ Q2LINE=MAX(Q2CLOSE,1)
+ Q2LINE=MIN(Q2LINE,999)
+ IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN
+ write(logfid,*)'ERROR in GETPDFXINT: line number out of bound',
+ & Q2LINE
+ ENDIF
+
+ IF(TYP.EQ.'QQ')THEN
+ DO 11 J=1,2
+ XA(J)=QINQX(1,Q2LINE-1+J)
+ YA(J)=QINQX(2,Q2LINE-1+J)
+ 11 CONTINUE
+ ELSEIF(TYP.EQ.'GQ')THEN
+ DO 13 J=1,2
+ XA(J)=GINQX(1,Q2LINE-1+J)
+ YA(J)=GINQX(2,Q2LINE-1+J)
+ 13 CONTINUE
+ ELSEIF(TYP.EQ.'QG')THEN
+ DO 15 J=1,2
+ XA(J)=QINGX(1,Q2LINE-1+J)
+ YA(J)=QINGX(2,Q2LINE-1+J)
+ 15 CONTINUE
+ ELSEIF(TYP.EQ.'GG')THEN
+ DO 17 J=1,2
+ XA(J)=GINGX(1,Q2LINE-1+J)
+ YA(J)=GINGX(2,Q2LINE-1+J)
+ 17 CONTINUE
+ ELSE
+ write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP
+ ENDIF
+ A=(YA(2)-YA(1))/(XA(2)-XA(1))
+ B=YA(1)-A*XA(1)
+ Y=A*Q**2+B
+ GETPDFXINT=Y
+ END
+
+
+***********************************************************************
+*** subroutine getpdfxintexact
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for pdf integration
+ COMMON/PDFINTV/XMAX,Z
+ DOUBLE PRECISION XMAX,Z
+C--local variables
+ DOUBLE PRECISION Q,EPSI,YSTART,HFIRST
+ CHARACTER*2 TYP
+ DATA EPSI/1.d-4/
+
+ HFIRST=0.01d0
+ YSTART=0.d0
+ XMAX=Q
+ Z=0.d0
+ IF(TYP.EQ.'QQ')THEN
+ CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21)
+ ELSEIF(TYP.EQ.'QG')THEN
+ CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23)
+ ELSEIF(TYP.EQ.'GQ')THEN
+ CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22)
+ ELSEIF(TYP.EQ.'GG')THEN
+ CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24)
+ ENDIF
+ GETPDFXINTEXACT=YSTART
+ END
+
+
+***********************************************************************
+*** function getxsecint
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--cross secttion common block
+ COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
+ &INTG1(1001,101),INTG2(1001,101)
+ DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
+C--variables for cross section integration
+ COMMON/XSECV/QLOW,MDX
+ DOUBLE PRECISION QLOW,MDX
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--local variables
+ INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J
+ DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B
+ CHARACTER*2 TYP2
+
+ ntotxsec=ntotxsec+1
+ if (tm.gt.intq1(1000,101)) then
+ noverxsec=noverxsec+1
+ if (noverpdf.le.25)
+ & write(logfid,*)'WARNING in getxsecint: need to extrapolate: ',
+ & tm,intq1(1000,101)
+ endif
+
+ TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/
+ & (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1)
+ TLINE=MAX(TCLOSE,1)
+ TLINE=MIN(TLINE,999)
+ MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/
+ &(INTQ1(1001,100)-INTQ1(1001,1))+1)
+ MDLINE=MAX(MDCLOSE,1)
+ MDLINE=MIN(MDLINE,99)
+ IF((TLINE.GT.999).OR.(MDLINE.GT.99)
+ & .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN
+ write(logfid,*)'ERROR in GETXSECINT: line number out of bound',
+ & TLINE,MDLINE
+ ENDIF
+
+ IF(TYP2.EQ.'QA')THEN
+C--first quark integral
+ DO 12 I=1,2
+ X1A(I)=INTQ1(1001,MDLINE-1+I)
+ X2A(I)=INTQ1(TLINE-1+I,101)
+ DO 11 J=1,2
+ YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I)
+ 11 CONTINUE
+ 12 CONTINUE
+ ELSEIF(TYP2.EQ.'QB')THEN
+C--second quark integral
+ DO 18 I=1,2
+ X1A(I)=INTQ2(1001,MDLINE-1+I)
+ X2A(I)=INTQ2(TLINE-1+I,101)
+ DO 17 J=1,2
+ YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I)
+ 17 CONTINUE
+ 18 CONTINUE
+ ELSEIF(TYP2.EQ.'GA')THEN
+C--first gluon integral
+ DO 14 I=1,2
+ X1A(I)=INTG1(1001,MDLINE-1+I)
+ X2A(I)=INTG1(TLINE-1+I,101)
+ DO 13 J=1,2
+ YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I)
+ 13 CONTINUE
+ 14 CONTINUE
+ ELSEIF(TYP2.EQ.'GB')THEN
+C--second gluon integral
+ DO 16 I=1,2
+ X1A(I)=INTG2(1001,MDLINE-1+I)
+ X2A(I)=INTG2(TLINE-1+I,101)
+ DO 15 J=1,2
+ YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I)
+ 15 CONTINUE
+ 16 CONTINUE
+ ELSE
+ write(logfid,*)'error in GETXSECINT: unknown integral type ',
+ & TYP2
+ ENDIF
+ DO 19 I=1,2
+ A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1))
+ B=YA(I,1)-A*X2A(1)
+ YB(I)=A*TM+B
+ 19 CONTINUE
+ IF(X1A(1).EQ.X1A(2))THEN
+ Y=YB(1)
+ ELSE
+ A=(YB(2)-YB(1))/(X1A(2)-X1A(1))
+ B=YB(1)-A*X1A(1)
+ Y=A*MD+B
+ ENDIF
+ GETXSECINT=Y
+ END
+
+
+***********************************************************************
+*** function getinsudafast
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Q1,Q2,GETINSUDARED
+ CHARACTER*2 TYP
+
+ IF(Q2.LE.Q1)THEN
+ GETINSUDAFAST=1.d0
+ ELSEIF(Q1.LE.Q0)THEN
+ GETINSUDAFAST=GETINSUDARED(Q2,TYP)
+ ELSE
+ GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP)
+ ENDIF
+ IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0
+ IF(GETINSUDAFAST.LT.(-1.d-10))THEN
+ write(logfid,*)'ERROR: GETINSUDAFAST < 0:',
+ & GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP
+ ENDIF
+ if (getinsudafast.lt.0.d0) getinsudafast = 0.d0
+ END
+
+
+***********************************************************************
+*** function getinsudared
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--Sudakov common block
+ COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
+ &SUDAGC(1000,2)
+ DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
+C--number of extrapolations in tables
+ common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+ integer ntotspliti,noverspliti,ntotpdf,noverpdf,
+ &ntotxsec,noverxsec,ntotsuda,noversuda
+C--local variables
+ INTEGER QCLOSE,QBIN,I
+ DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B
+ CHARACTER*2 TYP2
+
+ ntotsuda=ntotsuda+1
+ if (q.gt.sudaqq(1000,1)) then
+ noversuda=noversuda+1
+ if (noversuda.le.25)
+ & write(logfid,*)'WARNING in getinsudared: need to extrapolate: ',
+ & q,sudaqq(1000,1)
+ endif
+
+ QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0
+ & /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1)
+ QBIN=MAX(QCLOSE,1)
+ QBIN=MIN(QBIN,999)
+ IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN
+ write(logfid,*)
+ & 'ERROR in GETINSUDARED: line number out of bound',QBIN
+ ENDIF
+ IF(TYP2.EQ.'QQ')THEN
+ DO 16 I=1,2
+ XA(I)=SUDAQQ(QBIN-1+I,1)
+ YA(I)=SUDAQQ(QBIN-1+I,2)
+ 16 CONTINUE
+ ELSEIF(TYP2.EQ.'QG')THEN
+ DO 17 I=1,2
+ XA(I)=SUDAQG(QBIN-1+I,1)
+ YA(I)=SUDAQG(QBIN-1+I,2)
+ 17 CONTINUE
+ ELSEIF(TYP2.EQ.'GG')THEN
+ DO 18 I=1,2
+ XA(I)=SUDAGG(QBIN-1+I,1)
+ YA(I)=SUDAGG(QBIN-1+I,2)
+ 18 CONTINUE
+ ELSEIF(TYP2.EQ.'GC')THEN
+ DO 19 I=1,2
+ XA(I)=SUDAGC(QBIN-1+I,1)
+ YA(I)=SUDAGC(QBIN-1+I,2)
+ 19 CONTINUE
+ ELSE
+ write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2
+ ENDIF
+ A=(YA(2)-YA(1))/(XA(2)-XA(1))
+ B=YA(1)-A*XA(1)
+ Y=A*Q+B
+ GETINSUDARED=Y
+ IF(GETINSUDARED.LT.(-1.d-10))THEN
+ write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2
+ ENDIF
+ if (getinsudared.lt.0.d0) getinsudared = 0.d0
+ END
+
+
+***********************************************************************
+*** function getsscat
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2,
+ & x,y,z,t,mode)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--variables for cross section integration
+ COMMON/XSECV/QLOW,MDX
+ DOUBLE PRECISION QLOW,MDX
+C--local variables
+ integer mode
+ DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP,
+ &LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp,
+ &x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct
+ CHARACTER TYPE1,TYPE2
+
+ IF(TYPE1.EQ.'Q')THEN
+ CCOL=2./3.
+ ELSE
+ CCOL=3./2.
+ ENDIF
+ if (mode.eq.0) then
+ mdeb = getmd(x,y,z,t)
+ call avscatcen(x,y,z,t,
+ & avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ shat = avmom(5)**2 + mp**2 +
+ & 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz)
+ pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
+ up = 4.*pcms2
+ else
+ if (mode.eq.1) then
+ mdeb = getmdmin()
+ else
+ mdeb = getmdmax()
+ endif
+ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)
+ pproj = sqrt(px**2+py**2+pz**2)
+ shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct)
+ pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
+ up = 4.*pcms2
+ endif
+ LOW=LW**2
+ IF(LOW.GT.UP)THEN
+ GETSSCAT=0.d0
+ RETURN
+ ENDIF
+ IF((TYPE2.EQ.'C').OR.
+ & ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR.
+ & ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN
+ GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB))
+! write(*,*)'getsscat 1',GETSSCAT
+ ELSE
+ GETSSCAT=0.d0
+ ENDIF
+ LOW=Q0**2/SCALEFACM**2
+ IF(UP.GT.LOW)THEN
+ IF(TYPE1.EQ.'Q')THEN
+ IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
+ GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ')
+ & *3.*SCATPRIMFUNC(UP,MDEB)/2.
+ GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA')
+ ENDIF
+ ELSE
+ IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
+ GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
+ & SCATPRIMFUNC(LOW,MDEB))
+ & - GETXSECINT(UP,MDEB,'GB')
+! write(*,*)'getsscat 2',GETSSCAT,CCOL*(SCATPRIMFUNC(UP,MDEB)-
+! & SCATPRIMFUNC(LOW,MDEB)),-GETXSECINT(UP,MDEB,'GB')
+ ENDIF
+ IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
+ GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG')
+ & *2.*SCATPRIMFUNC(UP,MDEB)/3.
+ GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA')
+! write(*,*)'getsscat 3',getsscat,-2.*GETXSECINT(UP,MDEB,'GA')
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(GETSSCAT.LT.-1.d-4) then
+ write(logfid,*) 'error: cross section < 0',GETSSCAT,'for',
+ & EN,mp,LW,TYPE1,TYPE2,LW**2,UP,mode
+ endif
+ GETSSCAT=MAX(GETSSCAT,0.d0)
+ END
+
+
+
+***********************************************************************
+*** function getmass
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE,
+ & MAX2,INS,ZDEC,QQBARDEC)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--factor in front of alphas argument
+ COMMON/ALPHASFAC/PTFAC
+ DOUBLE PRECISION PTFAC
+C--local variables
+ DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec,
+ &q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin,
+ &gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti,
+ &r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin
+ CHARACTER*2 TYPE
+ LOGICAL INS,QQBARDEC
+ DATA PI/3.141592653589793d0/
+
+ q2min = q0**2
+
+ alphmax = alphas(3.*ptfac*q2min/16.,lps)
+ log14 = log(0.25)
+
+ IF(TYPE.EQ.'QQ')THEN
+ pref=4.*alphmax/(3.*2.*PI)
+ ELSE
+ pref=29.*alphmax/(8.*2.*PI)
+ ENDIF
+
+C--check if phase space available, return 0.d0 otherwise
+ IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN
+ getmass=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ RETURN
+ ENDIF
+
+ q2max = qbmax**2
+! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2))
+! IF(pyr(0).LE.sudaover)THEN
+ 21 if (q2max-qbmin**2.lt.1e-4)then
+ getmass=qbmin
+ zdec=0.5
+ IF(TYPE.EQ.'QQ')THEN
+ QQBARDEC=.FALSE.
+ ELSE
+ IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN
+ QQBARDEC=.TRUE.
+ ELSE
+ QQBARDEC=.FALSE.
+ ENDIF
+ endif
+ return
+ endif
+ gmax = pref*log(q2min/(4.*q2max))**2
+ if (qbmin.gt.0.d0) then
+ rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax)
+ else
+ rmin = 0.d0
+ endif
+
+ r=pyr(0)*(1.d0-rmin)+rmin
+ arg=gmax+log(r)
+ if(arg.lt.0.d0)then
+ getmass=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ RETURN
+ endif
+! r=pyr(0)
+! gmin = pref*log14**2
+! gmax = pref*log(q2min/(4.*q2max))**2
+! arg = log(r*exp(gmax)+(1.-r)*exp(gmin))
+ cand = q2min*exp(sqrt(arg/pref))/4.
+ eps = q2min/(4.*cand)
+
+ if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then
+ getmass=0.d0
+ ZDEC=0.d0
+ QQBARDEC=.FALSE.
+ RETURN
+ endif
+
+ IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN
+ q2max=cand
+ goto 21
+ ENDIF
+
+ if (ins) then
+ trueval=getinspliti(sqrt(cand),type)
+ oest = -2.*pref*log(eps)
+ weight = trueval/oest
+ else
+C--find true z interval
+ TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand)
+ & *SQRT(1.-cand/EP**2)
+ IF(TRUEEPS.LT.EPS)
+ & WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS
+ RZ=PYR(0)
+ z = 1.-eps**rz
+ if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then
+ weight = 0.
+ else
+ if (type.eq.'QQ')then
+! if (ins) then
+! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
+! else
+ trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
+! endif
+ oest = 2.*pref/(1.-z)
+ weight = trueval/oest
+ else
+ if (pyr(0).lt.(17./29.)) z = 1.-z
+! if (ins)then
+! trueval = alphas(ptfac*(1.-z)*cand,lps)
+! & *(pgg(z)+pqg(z))/(2.*pi)
+! else
+ trueval = alphas(ptfac*z*(1.-z)*cand,lps)
+ & *(pgg(z)+pqg(z))/(2.*pi)
+! endif
+ oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi)
+ weight = trueval/oest
+ endif
+ thetanew = sqrt(cand/(z*(1.-z)))/ep
+ if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta))
+ & weight = 0.d0
+ endif
+ endif
+ IF (WEIGHT.GT.1.d0) WRITE(logfid,*)
+ & 'problem in getmass: weight> 1',
+ & WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND
+ R2=PYR(0)
+ IF(R2.GT.WEIGHT)THEN
+ q2max=cand
+ GOTO 21
+ ELSE
+ getmass=sqrt(cand)
+ if (.not.ins) then
+ ZDEC=Z
+ IF(TYPE.EQ.'QQ')THEN
+ QQBARDEC=.FALSE.
+ ELSE
+ IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN
+ QQBARDEC=.TRUE.
+ ELSE
+ QQBARDEC=.FALSE.
+ ENDIF
+ ENDIF
+ endif
+ ENDIF
+ END
+
+
+
+***********************************************************************
+*** function generatez
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
+ CHARACTER*2 TYPE
+
+ IF(TI.EQ.0.d0)THEN
+ EPS=EPSI
+ ELSE
+ EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
+ & *SQRT(1.-TI/EA**2),EPSI)
+ ENDIF
+ IF(EPS.GT.0.5)THEN
+ GENERATEZ=0.5
+ GOTO 61
+ ENDIF
+ 60 R=PYR(0)
+ IF(TYPE.EQ.'QQ')THEN
+ X=1.-(1.-EPS)*(EPS/(1.-EPS))**R
+ R=PYR(0)
+ IF(R.LT.((1.+X**2)/2.))THEN
+ GENERATEZ=X
+ ELSE
+ GOTO 60
+ ENDIF
+ ELSEIF(TYPE.EQ.'GG')THEN
+ X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R))
+ R=PYR(0)
+ HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X)
+ IF(R.LT.HELP)THEN
+ GENERATEZ=X
+ ELSE
+ GOTO 60
+ ENDIF
+ ELSE
+ R=PYR(0)*(1.-2.*EPS)+EPS
+ R1=PYR(0)/2.
+ HELP=0.5*(R**2+(1.-R)**2)
+ IF(R1.LT.HELP)THEN
+ GENERATEZ=R
+ ELSE
+ GOTO 60
+ ENDIF
+ ENDIF
+ 61 END
+
+
+
+***********************************************************************
+*** function scatprimfunc
+***********************************************************************
+ DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
+ DATA PI/3.141592653589793d0/
+
+ SCATPRIMFUNC = 2.*PI*(12.*PI)**2*(
+ & - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2
+ & - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2
+ END
+
+
+
+***********************************************************************
+*** function intpqq
+***********************************************************************
+ DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Z,Q
+
+ INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2)
+ & +LOG(1.-Z)))/((33.-2.*NF)*3.)
+ END
+
+
+
+***********************************************************************
+*** function intpgglow
+***********************************************************************
+ DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Z,Q
+
+ INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
+ END
+
+
+
+***********************************************************************
+*** function intpgghigh
+***********************************************************************
+ DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Z,Q
+
+ INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
+ END
+
+
+
+***********************************************************************
+*** function intpqglow
+***********************************************************************
+ DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Z,Q,EI
+
+ INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2
+ & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4
+ & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/
+ &((33.-2.*NF)*2.)
+ END
+
+
+
+***********************************************************************
+*** function intpqghigh
+***********************************************************************
+ DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION Z,Q,EI
+
+ INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2
+ & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4
+ & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/
+ &((33.-2.*NF)*2.)
+ END
+
+
+
+***********************************************************************
+*** function gett
+***********************************************************************
+ DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
+ &MDEB,MINT,T
+ DATA PI/3.141592653589793d0/
+
+ TMAX=MAXT+MDEB**2
+ TMIN=MINT+MDEB**2
+ IF(TMIN.GT.TMAX) THEN
+ GETT=0.d0
+ RETURN
+ ENDIF
+ 20 R1=PYR(0)
+ T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX))
+ R2=PYR(0)
+ IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN
+ GETT=T-MDEB**2
+ ELSE
+ GOTO 20
+ ENDIF
+
+! 20 R1 = pyr(0);
+! R2 = pyr(0);
+! t = abs(mdeb**2*sqrt(-2.*log(R1))*cos(2.*pi*R2))
+! if (t.gt.maxt) goto 20
+! gett=t
+! return
+
+ END
+
+
+
+***********************************************************************
+*** function ei
+***********************************************************************
+ DOUBLE PRECISION FUNCTION EI(X)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--exponential integral for negative arguments
+ COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
+ INTEGER NVAL
+ DOUBLE PRECISION EIXS,VALMAX
+C--local variables
+ INTEGER K,LINE,LMAX
+ DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B
+ DOUBLE PRECISION YSTART,EPSI,HFIRST
+ DATA EPSI/1.e-5/
+
+ IF(DABS(X).GT.VALMAX)
+ & write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX
+
+ IF(X.GE.0.d0)THEN
+ LMAX=INT(X*NVAL/VALMAX)
+ LINE=MAX(LMAX,1)
+ LINE=MIN(LINE,999)
+ IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
+ write(logfid,*)'ERROR in EI: line number out of bound',LINE
+ ENDIF
+ DO 26 K=1,2
+ XA(K)=EIXS(1,LINE-1+K)
+ YA(K)=EIXS(3,LINE-1+K)
+ 26 CONTINUE
+ A=(YA(2)-YA(1))/(XA(2)-XA(1))
+ B=YA(1)-A*XA(1)
+ Y=A*X+B
+ ELSE
+ LMAX=INT(-X*NVAL/VALMAX)
+ LINE=MAX(LMAX,1)
+ LINE=MIN(LINE,999)
+ IF((LINE.GT.999).OR.(LINE.LT.1)) THEN
+ write(logfid,*)'ERROR in EI: line number out of bound',LINE
+ ENDIF
+ DO 27 K=1,2
+ XA(K)=EIXS(1,LINE-1+K)
+ YA(K)=EIXS(2,LINE-1+K)
+ 27 CONTINUE
+ A=(YA(2)-YA(1))/(XA(2)-XA(1))
+ B=YA(1)-A*XA(1)
+ Y=-A*X+B
+ ENDIF
+ EI=Y
+ END
+
+
+
+***********************************************************************
+*** function pqq
+***********************************************************************
+ DOUBLE PRECISION FUNCTION PQQ(Z)
+ IMPLICIT NONE
+ DOUBLE PRECISION Z
+ PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
+ END
+
+
+
+***********************************************************************
+*** function pgq
+***********************************************************************
+ DOUBLE PRECISION FUNCTION PGQ(Z)
+ IMPLICIT NONE
+ DOUBLE PRECISION Z
+ PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
+ END
+
+
+
+***********************************************************************
+*** function pgg
+***********************************************************************
+ DOUBLE PRECISION FUNCTION PGG(Z)
+ IMPLICIT NONE
+ DOUBLE PRECISION Z
+ PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
+ END
+
+
+
+***********************************************************************
+*** function pqg
+***********************************************************************
+ DOUBLE PRECISION FUNCTION PQG(Z)
+ IMPLICIT NONE
+ DOUBLE PRECISION Z
+ PQG=0.5*(Z**2 + (1.-Z)**2)
+ END
+
+
+
+***********************************************************************
+*** function alphas
+***********************************************************************
+ DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--local variables
+ DOUBLE PRECISION T,L0,PI,LAMBDA
+ DATA PI/3.141592653589793d0/
+
+ ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
+ END
+
+
+
+***********************************************************************
+*** subroutine splitfncint
+***********************************************************************
+ SUBROUTINE SPLITFNCINT(EMAX)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--splitting integral
+ COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
+ &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
+ INTEGER NPOINT
+ DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
+ &QVAL,ZMVAL,QMAX,ZMMIN
+C--variables for splitting function integration
+ COMMON/INTSPLITF/QQUAD,FM
+ DOUBLE PRECISION QQUAD,FM
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--local variables
+ INTEGER NSTEP,I,J
+ DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
+ &LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2
+ DATA ZMMAX/0.5/
+ DATA NSTEP/999/
+ DATA EPSI/1.d-5/
+
+ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ shat = avmom(5)**2 +
+ & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
+ pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
+ qmax = sqrt(scalefacm*4.*pcms2)
+
+ ZMMIN=Q0/EMAX
+
+ LNZMMIN=LOG(ZMMIN)
+ LNZMMAX=LOG(ZMMAX)
+
+ NPOINT=NSTEP
+
+ DO 100 I=1,NSTEP+1
+ Q=(I-1)*(QMAX-Q0)/NSTEP+Q0
+ QVAL(I)=Q
+ QQUAD=Q**2
+ DO 110 J=1,NSTEP+1
+ ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
+ ZMVAL(J)=ZM
+ IF(Q**2.LT.Q0**2)THEN
+ ZM2=0.5
+ ELSE
+ ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2)
+ ENDIF
+ ZM=MAX(ZM,ZM2)
+ IF(ZM.EQ.0.5)THEN
+ SPLITIQQV(I,J)=0.d0
+ SPLITIGGV(I,J)=0.d0
+ SPLITIQGV(I,J)=0.d0
+ ELSE
+ YSTART=0d0
+ HFIRST=0.01
+ FM=0.d0
+ CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2)
+ SPLITIQQV(I,J)=YSTART
+ YSTART=0d0
+ HFIRST=0.01
+ FM=0.d0
+ CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3)
+ SPLITIGGV(I,J)=YSTART
+ YSTART=0d0
+ HFIRST=0.01
+ FM=0.d0
+ CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4)
+ SPLITIQGV(I,J)=YSTART
+ ENDIF
+ 110 CONTINUE
+ 100 CONTINUE
+
+ END
+
+
+
+***********************************************************************
+*** subroutine pdfint
+***********************************************************************
+ SUBROUTINE PDFINT(EMAX)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--pdf common block
+ COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
+ &GINGX(2,1000)
+ DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
+C--variables for pdf integration
+ COMMON/PDFINTV/XMAX,Z
+ DOUBLE PRECISION XMAX,Z
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--local variables
+ INTEGER I,J
+ DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI,
+ &Q2MAX,DELTAQ2,avmom(5),shat,pcms2
+ DATA EPSI/1.d-4/
+
+ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ shat = avmom(5)**2 +
+ & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
+ pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
+ q2max = scalefacm*4.*pcms2
+
+ DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
+ QINQX(1,1)=Q0**2
+ GINQX(1,1)=Q0**2
+ QINGX(1,1)=Q0**2
+ GINGX(1,1)=Q0**2
+ QINQX(2,1)=0.d0
+ GINQX(2,1)=0.d0
+ QINGX(2,1)=0.d0
+ GINGX(2,1)=0.d0
+ DO 12 J=2,1000
+ Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2))
+ QINQX(1,J)=Q2
+ GINQX(1,J)=Q2
+ QINGX(1,J)=Q2
+ GINGX(1,J)=Q2
+ QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ')
+ GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ')
+ QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG')
+ GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG')
+ 12 CONTINUE
+ END
+
+
+
+***********************************************************************
+*** subroutine xsecint
+***********************************************************************
+ SUBROUTINE XSECINT(EMAX)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--cross secttion common block
+ COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
+ &INTG1(1001,101),INTG2(1001,101)
+ DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
+C--variables for cross section integration
+ COMMON/XSECV/QLOW,MDX
+ DOUBLE PRECISION QLOW,MDX
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--local variables
+ INTEGER J,K
+ DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI,
+ &GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2
+ DATA EPSI/1.d-4/
+
+ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ shat = avmom(5)**2 +
+ & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
+ pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
+ tmaxmax = scalefacm*4.*pcms2
+ DELTATMAX=(LOG(TMAXMAX)-
+ & LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0
+ MDMIN=GETMDMIN()
+ MDMAX=MAX(MDMIN,GETMDMAX())
+ DELTAMD=(MDMAX-MDMIN)/99.d0
+
+ DO 12 J=1,1000
+ TMAX = EXP((J-1)*DELTATMAX
+ & + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))
+ INTQ1(J,101)=TMAX
+ INTQ2(J,101)=TMAX
+ INTG1(J,101)=TMAX
+ INTG2(J,101)=TMAX
+ DO 13 K=1,100
+ MDX=MDMIN+(K-1)*DELTAMD
+ INTQ1(1001,K)=MDX
+ INTQ2(1001,K)=MDX
+ INTG1(1001,K)=MDX
+ INTG2(1001,K)=MDX
+ IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN
+ INTQ1(J,K)=0.d0
+ INTQ2(J,K)=0.d0
+ INTG1(J,K)=0.d0
+ INTG2(J,K)=0.d0
+ ELSE
+C--first quark integral
+ QLOW=Q0
+ HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
+ & ,0.d0,11)
+ INTQ1(J,K)=YSTART
+C--second quark integral
+ QLOW=Q0
+ HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2)
+ YSTART=0.d0
+ CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
+ & ,0.d0,14)
+ INTQ2(J,K)=YSTART
+C--first gluon integral
+ QLOW=Q0
+ YSTART=0.d0
+ CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
+ & ,0.d0,12)
+ INTG1(J,K)=YSTART
+C--second gluon integral
+ QLOW=Q0
+ YSTART=0.d0
+ CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST
+ & ,0.d0,13)
+ INTG2(J,K)=YSTART
+ ENDIF
+ 13 CONTINUE
+ 12 CONTINUE
+ END
+
+
+
+***********************************************************************
+*** function insudaint
+***********************************************************************
+ SUBROUTINE INSUDAINT(EMAX)
+ IMPLICIT NONE
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--Sudakov common block
+ COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2),
+ &SUDAGC(1000,2)
+ DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--local variables
+ INTEGER I
+ DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5),
+ &shat,pcms2
+
+ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
+ shat = avmom(5)**2 +
+ & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
+ pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
+ qmax = sqrt(scalefacm*4.*pcms2)
+ DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0
+ DO 22 I=1,1000
+ Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6)))
+ SUDAQQ(I,1)=Q
+ SUDAQG(I,1)=Q
+ SUDAGG(I,1)=Q
+ SUDAGC(I,1)=Q
+ SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ')
+ SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG')
+ SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG')
+ SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC')
+ 22 CONTINUE
+ END
+
+
+
+***********************************************************************
+*** function eixint
+***********************************************************************
+ SUBROUTINE EIXINT
+ IMPLICIT NONE
+C--exponential integral for negative arguments
+ COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL
+ INTEGER NVAL
+ DOUBLE PRECISION EIXS,VALMAX
+C-local variables
+ INTEGER I,K
+ DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R
+ DATA EPSI/1.d-6/
+
+ NVAL=1000
+ VALMAX=55.
+
+ DO 10 I=1,NVAL
+ X=I*VALMAX/(NVAL*1.d0)
+ EIXS(1,I)=X
+C--do negative arguments first
+ YSTART=0d0
+ HFIRST=0.01
+ CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5)
+ EIXS(2,I)=-YSTART
+C--now do the positive arguments
+ IF (X.EQ.0.0) THEN
+ EI=-1.0D+300
+ ELSE IF (X.LE.40.0) THEN
+ EI=1.0D0
+ R=1.0D0
+ DO 15 K=1,100
+ R=R*K*X/(K+1.0D0)**2
+ EI=EI+R
+ IF (DABS(R/EI).LE.1.0D-15) GO TO 20
+15 CONTINUE
+20 GA=0.5772156649015328D0
+ EI=GA+DLOG(X)+X*EI
+ ELSE
+ EI=1.0D0
+ R=1.0D0
+ DO 25 K=1,20
+ R=R*K/X
+ EI=EI+R
+25 continue
+ EI=DEXP(X)/X*EI
+ ENDIF
+ EIXS(3,I)=EI
+ 10 CONTINUE
+ END
+
+
+
+***********************************************************************
+*** function odeint
+***********************************************************************
+ subroutine odeint(ystart,a,b,eps,h1,hmin,w1)
+ implicit none
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--local variables
+ integer nmax,nstep,w1
+ double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx,
+ &deriv,yscale,hdid,hnew
+ data nmax/100000/
+
+ x = a
+ y = ystart
+ h = sign(h1,b-a)
+ do 20 nstep=1,nmax
+ dydx = deriv(x,w1)
+ yscale = abs(y) + abs(h*dydx) + 1.e-25
+ if (((x + h - b)*h).gt.0.) h = b-x
+ call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1)
+ if ((x - b)*h.ge.0) then
+ ystart = y
+ return
+ endif
+ h = hnew
+ if (abs(h).lt.abs(hmin)) then
+ write(logfid,*)'Error in odeint: stepsize too small',w1
+ & ,ystart,a,b,h1
+ return
+ endif
+ 20 continue
+ write(logfid,*)'Error in odeint: too many steps',w1
+ & ,ystart,a,b,h1
+ end
+
+
+
+***********************************************************************
+*** function rkstepper
+***********************************************************************
+ subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1)
+ implicit none
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--local variables
+ integer w1
+ double precision x,y,dydx,htest,hdid,hnew,yscale,eps,
+ &yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown,
+ &powerup,maxup,maxdown,deriv,fac
+ logical reject
+ data powerdown/0.25/
+ data powerup/0.2/
+ data safety/0.9/
+ data maxdown/10./
+ data maxup/5./
+
+ reject = .false.
+ h = htest
+ 10 xnew = x + h
+ if (x.eq.xnew) then
+ write(logfid,*)'Error in rkstepper: step size not significant'
+ return
+ endif
+ yhalf = rk4step(x,y,dydx,h/2.,w1)
+ dydxhalf = deriv(x+h/2.,w1)
+ y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1)
+ y1 = rk4step(x,y,dydx,h,w1)
+ delta = y2-y1
+ err = abs(delta)/(yscale*eps)
+ if (err.gt.1.) then
+ reject = .true.
+ fac = max(1./maxdown,safety/err**powerdown)
+ h = h*fac
+ goto 10
+ else
+ if (reject) then
+ hnew = h
+ else
+ fac = min(maxup,safety/err**powerup)
+ hnew = fac*h
+ endif
+ x = xnew
+ y = y2 + delta/15.
+ hdid = h
+ endif
+ end
+
+
+
+***********************************************************************
+*** function rk4step
+***********************************************************************
+ double precision function rk4step(x,y,dydx,h,w1)
+ implicit none
+ integer w1
+ double precision x,y,dydx,h,k1,k2,k4,yout,deriv
+ k1 = h*dydx
+ k2 = h*deriv(x+h/2.,w1)
+ k4 = h*deriv(x+h,w1)
+ yout = y+k1/6.+2.*k2/3.+k4/6.
+ rk4step = yout
+ end
+
+
+
+***********************************************************************
+*** function getdeltat
+***********************************************************************
+ LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT)
+ IMPLICIT NONE
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--pythia common block
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--max rapidity
+ common/rapmax/etamax
+ double precision etamax
+C--memory for error message from getdeltat
+ common/errline/errl
+ integer errl
+C--local variables
+ INTEGER LINE,I,NNULL
+ DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR,
+ &R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN,
+ &XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF,
+ &GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN,
+ &SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT
+ CHARACTER PTYPE
+ LOGICAL STOPNOW
+
+C--initialization
+ GETDELTAT=.FALSE.
+ DELTAT=0.D0
+ DTMAX=DTMAX1
+ IF(K(LINE,2).EQ.21)THEN
+ PTYPE='G'
+ ELSE
+ PTYPE='Q'
+ ENDIF
+
+ NNULL=0
+ STOPNOW=.FALSE.
+
+C--check for upper bound from plasma lifetime
+ IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART
+ IF(DTMAX.LT.0.D0) RETURN
+
+C--calculate time relative to production of the considered parton
+ TOFF=TSTART-MV(LINE,4)
+ XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4)
+ YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4)
+ ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4)
+
+C--calculate upper limit for density*cross section
+ SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
+! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
+ & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1)
+ SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
+! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
+ & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2)
+ NEFFMAX=GETNEFFMAX()
+ NEFFMIN=GETNATMDMIN()
+ LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN)
+ if(linvmax.eq.0.d0) return
+
+ DO 333 I=1,1000000
+ DELTAT=DELTAT-LOG(PYR(0))/LINVMAX
+ XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4)
+ YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4)
+ ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4)
+ TS=TSTART+DELTAT
+ IF(TS.LT.ZS)THEN
+ TAU=-1.d0
+ ELSE
+ TAU=SQRT(TS**2-ZS**2)
+ ENDIF
+ NEFF=GETNEFF(XS,YS,ZS,TS)
+ IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN
+ IF(NNULL.GT.4)THEN
+ STOPNOW=.TRUE.
+ ELSE
+ NNULL=NNULL+1
+ ENDIF
+ ELSE
+ NNULL=0
+ ENDIF
+ IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN
+ DELTAT=DTMAX
+ RETURN
+ ENDIF
+ IF(NEFF.GT.0.d0)THEN
+ SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3),
+ & P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0)
+ ELSE
+ SIGMA=0.d0
+ ENDIF
+ WEIGHT=5.d0*NEFF*SIGMA/LINVMAX
+ IF(WEIGHT.GT.1.d0+1d-6) then
+ if (line.ne.errl) then
+ write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT,
+ & NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX),
+ & p(line,4)
+ errl=line
+ endif
+ endif
+ R=PYR(0)
+ IF(R.LT.WEIGHT)THEN
+ GETDELTAT=.TRUE.
+ RETURN
+ ENDIF
+ 333 CONTINUE
+ END
+
+
+***********************************************************************
+*** function poissonian
+***********************************************************************
+ integer function poissonian(lambda)
+ implicit none
+ integer n
+ double precision lambda,disc,p,pyr,u,v,pi
+ data pi/3.141592653589793d0/
+
+ if (lambda.gt.745.d0) then
+ u = pyr(0);
+ v = pyr(0);
+ poissonian =
+ & int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda)
+ else
+ disc=exp(-lambda)
+ p=1.d0
+ n=0
+ 800 p = p*pyr(0)
+ if (p.gt.disc) then
+ n = n+1
+ goto 800
+ endif
+ poissonian=n
+ endif
+ end
+
+
+***********************************************************************
+*** subroutine makemassless
+***********************************************************************
+ subroutine makemassless(l3,l1,l2)
+ implicit none
+C--pythia common block
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--local variables
+ integer l1,l2,l3
+ double precision beta(3),Etot,E1new,E2new,E3new,p1new,p1new2
+ double precision m1,m2,pyp
+
+ beta(1)=(p(l1,1)+p(l2,1))/(p(l1,4)+p(l2,4))
+ beta(2)=(p(l1,2)+p(l2,2))/(p(l1,4)+p(l2,4))
+ beta(3)=(p(l1,3)+p(l2,3))/(p(l1,4)+p(l2,4))
+ call pyrobo(l1,l1,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
+ call pyrobo(l2,l2,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
+ call pyrobo(l3,l3,0.d0,0.d0,-beta(1),-beta(2),-beta(3))
+ Etot=p(l1,4)+p(l2,4)+p(l3,4)
+ E3new=pyp(l3,8)
+ m1=p(l1,5)
+ m2=p(l2,5)
+ p1new2=(((Etot-E3new)**2-m1**2-m2**2)**2 - 4.*m1**2*m2**2)/
+ & (4.*(Etot-E3new)**2)
+ if (p1new2.lt.0.d0) write(logfid,*)'negative mass squared: ',p1new2
+ p1new=sqrt(abs(p1new2))
+ E1new=sqrt(p1new2+m1**2)
+ E2new=sqrt(p1new2+m2**2)
+ p(l1,1)=p(l1,1)*p1new/pyp(l1,8)
+ p(l1,2)=p(l1,2)*p1new/pyp(l1,8)
+ p(l1,3)=p(l1,3)*p1new/pyp(l1,8)
+ p(l1,4)=E1new
+ p(l2,1)=p(l2,1)*p1new/pyp(l2,8)
+ p(l2,2)=p(l2,2)*p1new/pyp(l2,8)
+ p(l2,3)=p(l2,3)*p1new/pyp(l2,8)
+ p(l2,4)=E2new
+ p(l3,4)=E3new
+ p(l3,5)=0.d0
+ call pyrobo(l1,l1,0.d0,0.d0,beta(1),beta(2),beta(3))
+ call pyrobo(l2,l2,0.d0,0.d0,beta(1),beta(2),beta(3))
+ call pyrobo(l3,l3,0.d0,0.d0,beta(1),beta(2),beta(3))
+ return
+ end
+
+
+***********************************************************************
+*** function ishadron
+***********************************************************************
+ LOGICAL FUNCTION ISHADRON(ID)
+ IMPLICIT NONE
+C--local variables
+ INTEGER ID
+ IF(ABS(ID).LT.100) THEN
+ ISHADRON=.FALSE.
+ ELSE
+ IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN
+ ISHADRON = .FALSE.
+ ELSE
+ ISHADRON = .TRUE.
+ ENDIF
+ ENDIF
+ END
+
+
+
+***********************************************************************
+*** function isdiquark
+***********************************************************************
+ LOGICAL FUNCTION ISDIQUARK(ID)
+ IMPLICIT NONE
+C--local variables
+ INTEGER ID
+ IF(ABS(ID).LT.1000) THEN
+ ISDIQUARK=.FALSE.
+ ELSE
+ IF(MOD(INT(ID/10),10).EQ.0) THEN
+ ISDIQUARK = .TRUE.
+ ELSE
+ ISDIQUARK = .FALSE.
+ ENDIF
+ ENDIF
+ END
+
+***********************************************************************
+*** function islepton
+***********************************************************************
+ LOGICAL FUNCTION ISLEPTON(ID)
+ IMPLICIT NONE
+C-- local variables
+ INTEGER ID
+ IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN
+ ISLEPTON=.TRUE.
+ ELSE
+ ISLEPTON=.FALSE.
+ ENDIF
+ END
+
+***********************************************************************
+*** function isparton
+***********************************************************************
+ LOGICAL FUNCTION ISPARTON(ID)
+ IMPLICIT NONE
+C--local variables
+ INTEGER ID
+ LOGICAL ISDIQUARK
+ IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN
+ ISPARTON=.TRUE.
+ ELSE
+ ISPARTON=.FALSE.
+ ENDIF
+ END
+
+
+
+***********************************************************************
+*** function isprimstring
+***********************************************************************
+ logical function isprimstring(l)
+ implicit none
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--local variables
+ integer l
+ logical isparton
+ if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
+ isprimstring=.false.
+ return
+ endif
+ if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then
+ isprimstring=.true.
+ else
+ isprimstring=.false.
+ endif
+ end
+
+
+
+***********************************************************************
+*** function issecstring
+***********************************************************************
+ logical function issecstring(l)
+ implicit none
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--local variables
+ integer l
+ logical isparton,isprimstring
+ if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then
+ issecstring = .false.
+ return
+ endif
+ if (isprimstring(l)) then
+ issecstring = .false.
+ return
+ endif
+ if (isparton(K(K(K(l,3),3),2))) then
+ issecstring = .false.
+ else
+ issecstring = .true.
+ endif
+ end
+
+
+
+***********************************************************************
+*** function isprimhadron
+***********************************************************************
+ logical function isprimhadron(l)
+ implicit none
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--local variables
+ integer l
+ logical isprimstring,isparton
+ if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92))
+ & .and.isprimstring(K(l,3))
+ & .and.(.not.isparton(K(l,2)))) then
+ isprimhadron=.true.
+ else
+ isprimhadron=.false.
+ endif
+ if (k(l,1).eq.17) isprimhadron=.true.
+ end
+
+
+
+***********************************************************************
+*** function compressevent
+***********************************************************************
+ logical function compressevent(l1)
+ implicit none
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--local variables
+ integer l1,i,j,nold,nnew,nstart
+
+ nold = n
+
+ do 777 i=2,nold
+ if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)
+ & .or.(k(i,1).eq.14)).and.(i.ne.l1)) then
+ nnew = i
+ goto 778
+ endif
+ 777 continue
+ compressevent = .false.
+ return
+ 778 continue
+ nstart = nnew
+ do 779 i=nstart,nold
+ if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)
+ & .and.(k(i,1).ne.14)).or.(i.eq.l1)) then
+ do 780 j=1,5
+ p(nnew,j)=p(i,j)
+ v(nnew,j)=v(i,j)
+ mv(nnew,j)=mv(i,j)
+ 780 continue
+ trip(nnew)=trip(i)
+ anti(nnew)=anti(i)
+ za(nnew)=za(i)
+ zd(nnew)=zd(i)
+ thetaa(nnew)=thetaa(i)
+ qqbard(nnew)=qqbard(i)
+ k(nnew,1)=k(i,1)
+ k(nnew,2)=k(i,2)
+ k(nnew,3)=0
+ k(nnew,4)=0
+ k(nnew,5)=0
+ if (l1.eq.i) l1=nnew
+ nnew=nnew+1
+ endif
+ 779 continue
+ n=nnew-1
+ if ((nold-n).le.10) then
+ compressevent = .false.
+ else
+ compressevent = .true.
+ endif
+ do 781 i=nnew,nold
+ do 782 j=1,5
+ k(i,j)=0
+ p(i,j)=0.d0
+ v(i,j)=0.d0
+ mv(i,j)=0.d0
+ 782 continue
+ trip(i)=0
+ anti(i)=0
+ za(i)=0.d0
+ zd(i)=0.d0
+ thetaa(i)=0.d0
+ qqbard(i)=.false.
+ 781 continue
+ if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n
+ if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1
+ call flush(logfid)
+ return
+ end
+
+
+
+***********************************************************************
+*** subroutine pevrec
+***********************************************************************
+ SUBROUTINE PEVREC(NUM,COL)
+C--identifier of file for hepmc output and logfile
+ implicit none
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+ INTEGER NUM,i
+ LOGICAL COL
+
+ DO 202 I=1,N
+ V(I,1)=MV(I,1)
+ V(I,2)=MV(I,2)
+ V(I,3)=MV(I,3)
+ V(I,4)=MV(I,4)
+ V(I,5)=MV(I,5)
+! IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
+! &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
+! &ZD(I),THETAA(I)
+ IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [',
+ &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ',
+ &'{ ',ZD(I),THETAA(I),QQBARD(I),'}'
+ 202 CONTINUE
+ CALL PYLIST(NUM)
+
+ END
+
+
+
+***********************************************************************
+*** subroutine converttohepmc
+***********************************************************************
+ SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2)
+ IMPLICIT NONE
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+C--Parameter common block
+ COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT,
+ &ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr,
+ &NF,KINMODE,recmode
+ INTEGER NF,KINMODE,recmode
+ DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM,
+ &RECSOFTCUT,RECHARDCUT
+ LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress,mpifsr
+C--organisation of event record
+ common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
+ &shorthepmc,isrscat,channel,isochannel
+ integer nsim,npart,offset,hadrotype
+ double precision sqrts
+ character*4 collider,channel
+ character*2 isochannel
+ logical hadro,shorthepmc,isrscat
+C--production point
+ common/jetpoint/x0,y0
+ double precision x0,y0
+C--initial pt and virtuality
+ common/injet/isgluon(2),inpt(2),inmass(2),inphi(2),ineta(2),
+ &inz(2),intheta(2)
+ integer isgluon
+ double precision inpt,inmass,inphi,ineta,inz,intheta
+C--extra storage for scattering centres before interactions
+ common/storescatcen/nscatcen,maxnscatcen,scatflav(23000),
+ &scatcen(23000,5),writescatcen,writedummies
+ integer nscatcen,maxnscatcen,scatflav
+ double precision scatcen
+ logical writescatcen,writedummies
+C--extra storage for dummy particles for subtraction
+ common/storedummies/dummies(10000,5)
+ double precision dummies
+C--local variables
+ INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART,
+ &NFIRST,NVERTEX,NTOT,J,CODEFIRST
+ integer intinpt(2),intinmass(2),intinphi(2),intineta
+ integer intz,inttheta
+ DOUBLE PRECISION mproton,centr,getcentrality,jprodr,phi,pi,
+ &pdummy,pscatcen,mneutron
+ LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring,
+ &issecstring
+ character*2 beam1,beam2
+ data mproton/0.9383/
+ data mneutron/0.9396/
+ DATA PI/3.141592653589793d0/
+
+ 5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6)
+ 5100 FORMAT(A2,2E14.6)
+! 5200 FORMAT(A2,9I2,4E14.6)
+! 5200 FORMAT(A2,2I7,7I2,4E14.6)
+ 5200 FORMAT(A2,6I7,2I2,1I7,4E14.6)
+ 5300 FORMAT(A2,2I2,5E14.6,2I2)
+! 5400 FORMAT(A2,I6,6I2,I6,I2)
+ 5400 FORMAT(A2,2I6,5I2,I6,I2)
+ 5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2)
+
+ PBARCODE=0
+ VBARCODE=0
+
+ centr = getcentrality()
+ jprodr = sqrt(x0**2+y0**2)
+ if (abs(y0).lt.1.d-8) then
+ if (x0.gt.0.d0) then
+ phi = 0.d0
+ else
+ phi = pi
+ endif
+ else
+ if (x0.gt.0.d0) then
+ if (y0.gt.0.d0) then
+ phi = atan(y0/x0)
+ else
+ phi = (3.d0*pi/2.d0) - atan(x0/y0)
+ endif
+ else
+ if (y0.gt.0.d0) then
+ phi = (pi/2.d0) - atan(x0/y0)
+ else
+ phi = pi + atan(y0/x0)
+ endif
+ endif
+ endif
+
+ do 140 i=1,2
+ intinpt(i) = int(inpt(i)*100.)
+ intinmass(i) = int(inmass(i)*100.)
+ intinphi(i) = int(inphi(i)*100.)
+ 140 continue
+ intineta = int(ineta(1)*100.)
+ intz = int(inz(1)*10000.)
+ inttheta = int(intheta(1)*100.)
+
+ if (shorthepmc) then
+C--short output
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ NVERTEX=3
+ PBARCODE=5
+ ELSE
+ NVERTEX=1
+ PBARCODE=2
+ ENDIF
+ nfirst = 0
+ do 131 i=1,N
+ if (((k(i,1).lt.6).or.(k(i,1).eq.17)))
+ & nfirst = nfirst+1
+ 131 continue
+ if(writescatcen) NFIRST=NFIRST+nscatcen
+ if(writedummies) NFIRST=NFIRST+nscatcen
+
+ WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1,
+ &PARI(10)
+ WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
+ WRITE(J,'(A)')'U GEV MM'
+ WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
+! WRITE(J,5200)'H ',
+! & intinpt(1),intinmass(1),intinphi(1),
+! & intinpt(2),intinmass(2),intinphi(2),
+! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
+ WRITE(J,5200)'H ',
+ & intinpt(1),intinmass(1),intinphi(1),
+ & intinpt(2),intz,inttheta,
+ & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
+ WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
+C--write out vertex line
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
+ WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
+ & 91.2,2,0,0,-2,0
+ WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
+ WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0
+ ELSE
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
+ if (beam1.eq.'p+') then
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ if (beam2.eq.'p+') then
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ ENDIF
+C--write out scattering centres
+ if(writescatcen) then
+ do 133 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1),
+ & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
+ & 3,0,0,0,0
+ 133 continue
+ endif
+C--write out dummy particles
+ if(writedummies) then
+ do 137 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
+ & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
+ 137 continue
+ endif
+C--write out particle lines
+ do 132 i=1,N
+ if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then
+ pbarcode=pbarcode+1
+ if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),4,0,0,0,0
+ else
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),1,0,0,0,0
+ endif
+ endif
+ 132 continue
+
+ else
+C--long output
+ if (hadro) then
+C--hadronised events
+ NFIRST=0
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ NVERTEX=3
+ ELSE
+ NVERTEX=1
+ ENDIF
+ DO 123 I=1,N
+ IF(K(i,3).ne.0)THEN
+ NSTART=I
+ GOTO 124
+ ENDIF
+ 123 CONTINUE
+ 124 CONTINUE
+ nstart=0
+
+ DO 126 I=NSTART+1,N
+ IF(isprimhadron(i)) NFIRST=NFIRST+1
+ IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15))
+ & .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1
+ 126 CONTINUE
+ 127 CONTINUE
+
+ if(writescatcen) NFIRST=NFIRST+nscatcen
+ if(writedummies) NFIRST=NFIRST+nscatcen
+
+ WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
+ &1,2,0,1,PARI(10)
+ WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
+ WRITE(J,'(A)')'U GEV MM'
+ WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
+! WRITE(J,5200)'H ',
+! & intinpt(1),intinmass(1),intinphi(1),
+! & intinpt(2),intinmass(2),intinphi(2),
+! & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
+ WRITE(J,5200)'H ',
+ & intinpt(1),intinmass(1),intinphi(1),
+ & intinpt(2),intz,inttheta,
+ & isgluon(1),isgluon(2),intineta,centr,phi,jprodr,ineta(2)
+ WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
+
+C--write out vertex line
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ VBARCODE=-3
+ PBARCODE=5
+ ELSE
+ VBARCODE=-1
+ PBARCODE=2
+ ENDIF
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
+ WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
+ & 91.2,2,0,0,-2,0
+ WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
+ WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
+ ELSE
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
+ if (beam1.eq.'p+') then
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ if (beam2.eq.'p+') then
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ ENDIF
+
+ CODEFIRST=NFIRST+PBARCODE
+
+C--write out scattering centres
+ if(writescatcen) then
+ do 134 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
+ & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
+ & 3,0,0,0,0
+ 134 continue
+ endif
+C--write out dummy particles
+ if(writedummies) then
+ do 138 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
+ & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
+ 138 continue
+ endif
+
+C--first write out all particles coming directly from string or cluster decays
+ DO 125 I=NSTART+1,N
+ IF(.not.isprimhadron(i))THEN
+ GOTO 125
+ ELSE
+ IF (PBARCODE.EQ.CODEFIRST) GOTO 130
+ PBARCODE=PBARCODE+1
+C--write out particle line
+ IF(K(I,4).GT.0)THEN
+ VBARCODE=VBARCODE-1
+ CODELIST(I)=VBARCODE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),2,0,0,VBARCODE,0
+ ELSE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),1,0,0,0,0
+ ENDIF
+ ENDIF
+ 125 CONTINUE
+ 130 CONTINUE
+C--now write out all other particles and vertices
+ DO 129 I=NSTART+1,N
+ if (isprimhadron(i).or.isprimstring(i)) goto 129
+ if (isparton(K(i,2))) then
+ if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3))
+ goto 129
+ endif
+ if (issecstring(i)) then
+ codelist(i)=codelist(K(i,3))
+ goto 129
+ endif
+ PBARCODE=PBARCODE+1
+ IF((K(I,3).NE.K(I-1,3)))THEN
+C--write out vertex line
+ WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0,
+ & K(K(I,3),5)-K(K(I,3),4)+1,0
+ ENDIF
+C--write out particle line
+ IF(K(I,4).GT.0)THEN
+ VBARCODE=VBARCODE-1
+ CODELIST(I)=VBARCODE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),2,0,0,VBARCODE,0
+ ELSE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),1,0,0,0,0
+ ENDIF
+ 129 CONTINUE
+
+ else
+C---------------------------------------------------------------------------------------
+C--partonic events
+! call pevrec(2,.false.)
+C--hadronised events
+ NFIRST=0
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ NVERTEX=3
+ ELSE
+ NVERTEX=1
+ ENDIF
+
+ DO 150 I=9,N
+ IF((k(i,3).eq.1).or.(k(i,3).eq.2).or.
+ & (k(i,3).eq.7).or.(k(i,3).eq.8)) NFIRST=NFIRST+1
+ IF(K(I,4).NE.0) NVERTEX=NVERTEX+1
+ 150 CONTINUE
+ nstart = 9+nfirst
+
+ if(writescatcen) NFIRST=NFIRST+nscatcen
+ if(writedummies) NFIRST=NFIRST+nscatcen
+
+ WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,
+ &1,2,0,1,PARI(10)
+ WRITE(J,'(A2,I2,A5)')'N ',1,'"0"'
+ WRITE(J,'(A)')'U GEV MM'
+ WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0
+ WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,centr,0.d0,0.d0,0.d0
+ WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
+
+C--write out vertex line
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ VBARCODE=-3
+ PBARCODE=5
+ ELSE
+ VBARCODE=-1
+ PBARCODE=2
+ ENDIF
+ IF(COLLIDER.EQ.'EEJJ')THEN
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0
+ WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
+ & 0.00051,2,0,0,-1,0
+ WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
+ & 91.2,2,0,0,-2,0
+ WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0
+ WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2.,
+ & 0.000,2,0,0,-3,0
+ WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0
+ ELSE
+ WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0
+ if (beam1.eq.'p+') then
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',1,2212,0.d0,0.d0,
+ & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ if (beam2.eq.'p+') then
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
+ else
+ WRITE(J,5500)'P ',2,2212,0.d0,0.d0,
+ & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
+ endif
+ ENDIF
+
+C--write out scattering centres
+ if(writescatcen) then
+ do 151 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1),
+ & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5),
+ & 3,0,0,0,0
+ 151 continue
+ endif
+C--write out dummy particles
+ if(writedummies) then
+ do 152 i=1,nscatcen
+ pbarcode=pbarcode+1
+ WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2),
+ & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0
+ 152 continue
+ endif
+
+C--write out outgoing particles of first vertex
+ do 154 i=9,nstart-1
+ PBARCODE=PBARCODE+1
+C--write out particle line
+ IF(K(I,4).GT.0)THEN
+ VBARCODE=VBARCODE-1
+ CODELIST(I)=VBARCODE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),2,0,0,VBARCODE,0
+ ELSE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),1,0,0,0,0
+ endif
+ 154 continue
+
+C--now write out all other particles and vertices
+ DO 153 I=NSTART,N
+ PBARCODE=PBARCODE+1
+ if (k(i,3).eq.0) then
+C--write out vertex line - scattering
+ WRITE(J,5400)'V ',CODELIST(K(I+1,3)),k(k(i+1,3),1),0,0,
+ & 0,0,0,K(K(I+1,3),5)-K(K(I+1,3),4)+1,0
+ elseif ((k(i,3).ne.k(i-1,3)).and.(k(i-1,3).ne.0)) then
+C--write out vertex line - splitting
+ WRITE(J,5400)'V ',CODELIST(K(I,3)),k(k(i,3),1),0,0,0,0,0,
+ & K(K(I,3),5)-K(K(I,3),4)+1,0
+ endif
+C--write out particle line
+ IF(K(I,4).GT.0)THEN
+ VBARCODE=VBARCODE-1
+ CODELIST(I)=VBARCODE
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),2,0,0,VBARCODE,0
+ ELSE
+ if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),4,0,0,0,0
+ elseif ((k(i,1).eq.11).and.(k(i,3).eq.0)) then
+ WRITE(J,5500)'P ',PBARCODE,0,0.d0,0.d0,0.d0,
+ & 0.d0,0.d0,0,0,0,0,0
+ else
+ WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3),
+ & P(I,4),P(I,5),1,0,0,0,0
+ endif
+ ENDIF
+ 153 CONTINUE
+
+ endif
+ endif
+ call flush(j)
+ END
+
+
+ subroutine combinegluons()
+ implicit none
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ INTEGER MSTP,MSTI
+ DOUBLE PRECISION PARP,PARI
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+ integer ncomb,i,j
+ double precision mom(4),mass2
+ logical compress,compressevent
+ data ncomb/3/
+
+ do 100 i=1,n
+C-- find recoils (= gluons with finite mass)
+ if ((k(i,2).eq.21).and.(p(i,5).ne.0.d0).and.(k(i,1).eq.2)) then
+ mom(1) = p(i,1)
+ mom(2) = p(i,2)
+ mom(3) = p(i,3)
+ mom(4) = p(i,4)
+ do 101 j=1,ncomb-1
+ if ((k(i+j,2).eq.21).and.(p(i+j,5).ne.0.d0)
+ & .and.(k(i+j,1).eq.2)) then
+ mom(1) = mom(1) + p(i+j,1)
+ mom(2) = mom(2) + p(i+j,2)
+ mom(3) = mom(3) + p(i+j,3)
+ mom(4) = mom(4) + p(i+j,4)
+ k(i+j,1) = 11
+ else
+ goto 102
+ endif
+ 101 continue
+ 102 p(i,1) = mom(1)
+ p(i,2) = mom(2)
+ p(i,3) = mom(3)
+ p(i,4) = mom(4)
+ mass2 = mom(4)**2-mom(1)**2-mom(2)**2-mom(3)**2
+ if (mass2.lt.0.d0) write(logfid,*)mass2
+ endif
+ 100 continue
+C i=0
+C compress = compressevent(i)
+ return
+ end
+
+
+
+***********************************************************************
+*** subroutine copyline
+***********************************************************************
+ SUBROUTINE COPYLINE(NFR,NTO,MODE)
+ IMPLICIT NONE
+C--Common block of Pythia
+ COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+C--time common block
+ COMMON/TIME/MV(23000,5)
+ DOUBLE PRECISION MV
+C--colour index common block
+ COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX
+ INTEGER TRIP,ANTI,COLMAX
+C--variables for angular ordering
+ COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000)
+ DOUBLE PRECISION ZA,ZD,THETAA
+ LOGICAL QQBARD
+C--local variables
+ integer nfr,nto,mode,j
+
+ if (mode.ge.0) then
+ k(nto,1) = k(nfr,1)
+ k(nto,2) = k(nfr,2)
+ do 100 j=1,5
+ p(nto,j) = p(nfr,j)
+ 100 continue
+ za(nto)=za(nfr)
+ zd(nto)=zd(nfr)
+ thetaa(nto)=thetaa(nfr)
+ qqbard(nto)=qqbard(nfr)
+ endif
+ if (mode.ge.1) then
+ do 101 j=1,5
+ mv(nto,j) = mv(nfr,j)
+ 101 continue
+ endif
+ if (mode.eq.2) then
+ trip(nto)=trip(nfr)
+ anti(nto)=anti(nfr)
+ endif
+ return
+ end
+
+
+
+***********************************************************************
+*** subroutine printlogo
+***********************************************************************
+ subroutine printlogo(fid)
+ implicit none
+ integer fid
+
+ write(fid,*)
+ write(fid,*)' _______________'//
+ &'__________________________ '
+ write(fid,*)' | '//
+ &' | '
+ write(fid,*)' | JJJJJ EEEEE '//
+ &' W W EEEEE L | '
+ write(fid,*)' | J E '//
+ &' W W E L | '
+ write(fid,*)' _________________| J EEE '//
+ &' W W W EEE L |_________________ '
+ write(fid,*)'| | J J E '//
+ &' W W W W E L | |'
+ write(fid,*)'| | JJJ EEEEE '//
+ &' W W EEEEE LLLLL | |'
+ write(fid,*)'| |_______________'//
+ &'__________________________| |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| '//
+ &'this is JEWEL 2.5.0 |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| Copyright Korinna C. Zapp (2022)'//
+ &' [Korinna.Zapp@thep.lu.se] |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '//
+ &' |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| The medium model was partly '//
+ &'implemented by Jochen Klein |'
+ write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '//
+ &'Kunnawalkam Elayavalli helped with the |'
+ write(fid,*)'| implementation of the V+jet processes '//
+ &'[raghav.k.e@cern.ch]. |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| Please cite JHEP 1303 (2013) '//
+ &'080 [arXiv:1212.1599] for physics and |'
+ write(fid,*)'| EPJC 74 (2014) no.2, 2762 [arXiv:1311.0048] '//
+ &' for the code. |'
+ write(fid,*)'| The reference for '//
+ &'V+jet processes is EPJC 76 (2016) no.12 695 |'
+ write(fid,*)'| [arXiv:1608.03099] and for recoil effects'//
+ &' it is JHEP 07 (2017) 141 |'
+ write(fid,*)'| [arXiv:1707.01539] and '//
+ &'arXiv:2207.?????. |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| JEWEL relies heavily on PYTHIA 6'//
+ &' for the event generation. The modified |'
+ write(fid,*)'| version of PYTHIA 6.4.25 that is'//
+ &' shipped with JEWEL is, however, not an |'
+ write(fid,*)'| official PYTHIA release and must'//
+ &' not be used for anything else. Please |'
+ write(fid,*)'| refer to results as "JEWEL+PYTHIA".'//
+ &' |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'| JEWEL also uses code provided by'//
+ &'S. Zhang and J. M. Jing |'
+ write(fid,*)'| (Computation of Special Functions, '//
+ &'John Wiley & Sons, New York, 1996 and |'
+ write(fid,*)'| http://jin.ece.illinois.edu) for '//
+ &'computing the exponential integral Ei(x). |'
+ write(fid,*)'| '//
+ &' |'
+ write(fid,*)'|_________________________________'//
+ &'____________________________________________|'
+ write(fid,*)
+ write(fid,*)
+ end
+
+
+***********************************************************************
+*** subroutine printtime
+***********************************************************************
+ subroutine printtime
+ implicit none
+C--identifier of file for hepmc output and logfile
+ common/hepmcid/hpmcfid,logfid
+ integer hpmcfid,logfid
+C--local variables
+ integer*4 date(3),time(3)
+
+ 1000 format (i2.2, '.', i2.2, '.', i4.4, ', ',
+ & i2.2, ':', i2.2, ':', i2.2 )
+ call idate(date)
+ call itime(time)
+ write(logfid,1000)date,time
+ end
+
Index: trunk/code/MC_JETS_ISRAD.plot
===================================================================
--- trunk/code/MC_JETS_ISRAD.plot (revision 504)
+++ trunk/code/MC_JETS_ISRAD.plot (revision 505)
@@ -1,45 +1,51 @@
# BEGIN PLOT /MC_JETS_ISRAD/ptfrac_R
Rebin=5
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/jet_pT
RatioPlotYMin=0
Rebin=5
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/isfrac_sd
Rebin=10
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/isjetfrac_vs_pt
Rebin=10
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/isjetfrac_vs_y
Rebin=3
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/ptfrac_vs_pt
Rebin=10
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/ptfrac_vs_y
Rebin=3
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/jet_profile_isfrac
LogY=0
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/thetag
LogY=0
+NormalizeToIntegral=1
# END PLOT
# BEGIN PLOT /MC_JETS_ISRAD/zg
LogY=0
+NormalizeToIntegral=1
+# END PLOT
+
+# BEGIN PLOT /MC_JETS_ISRAD/deltaphi
+NormalizeToIntegral=1
# END PLOT
Index: trunk/code/CMS_2014_I1299142.cc
===================================================================
--- trunk/code/CMS_2014_I1299142.cc (revision 504)
+++ trunk/code/CMS_2014_I1299142.cc (revision 505)
@@ -1,306 +1,307 @@
// -*- C++ -*-
#include "Rivet/Analysis.hh"
#include "Rivet/Projections/FinalState.hh"
#include "Rivet/Projections/ChargedFinalState.hh"
#include "Rivet/Projections/FastJets.hh"
#include "Rivet/Projections/SubtractedJewelFinalState.hh"
namespace Rivet {
using namespace fastjet;
struct FourMomComp {
bool operator() (const FourMomentum& p1, const FourMomentum& p2) const
{return p1.pT()<p2.pT();}
};
struct jetcomp{
bool operator() (const Jet jet1, const Jet jet2) const
{
if (jet1.momentum().pT() < jet2.momentum().pT()) return true;
else return false;
}
};
/*#if MODE==0
class CMS_2014_I1299142_4MOMSUB : public Analysis {
#elif MODE==1
class CMS_2014_I1299142_CONSTSUB : public Analysis {
#endif*/
class CMS_2014_I1299142 : public Analysis {
public:
/// Constructor
/*#if MODE==0
CMS_2014_I1299142_4MOMSUB() : Analysis("CMS_2014_I1299142_4MOMSUB")
#elif MODE==1
CMS_2014_I1299142_CONSTSUB() : Analysis("CMS_2014_I1299142_CONSTSUB")
#endif*/
CMS_2014_I1299142() : Analysis("CMS_2014_I1299142")
{
_jetR=0.3; _trackptmin=1.; _etamin=0.3; _etamax=2.; _ptmin=100.; _ptmax=300.; _Nptbins=3;
_etaloose=2.3; _ptminloose=90.; _dRloose=1.0;
_nphibins = 120; _netabins = 160;
}
/// Book histograms and initialise projections before the run
void init() {
_ptedges = {100.0, 120.0, 150.0, 300.0};
#if MODE==0
FinalState fs(Cuts::abseta < _etaloose && Cuts::pt > 0.);
declare(fs, "FS");
ChargedFinalState cfs(Cuts::abseta < 5. && Cuts::pt > _trackptmin*GeV);
declare(cfs, "CFS");
FastJets fj(fs, FastJets::ANTIKT, _jetR);
declare(fj, "Jets");
#elif MODE==1
FinalState fs(Cuts::abseta < _etaloose && Cuts::pt > 0.*GeV);
FastJets fjl(fs, FastJets::ANTIKT, _jetR);
declare(fjl, "LooseJets");
SubtractedJewelEvent sev(1.);
SubtractedJewelFinalState sfs(sev, Cuts::pt > 0.);
FastJets fj(sfs, FastJets::ANTIKT, _jetR);
declare(fj, "Jets");
ChargedFinalState csfs(sfs);
declare(csfs, "CSFS");
#endif
for (size_t i = 0; i < _Nptbins+1; ++i) {
book(_h_xi_pp[i], i+1, 1, 1);
book(_h_xi_PbPb[i], i+1, 2, 1);
book(_h_xi_ratio[i], i+1, 3, 1);
book(_h_pt_pp[i], i+1, 1, 2);
book(_h_pt_PbPb[i], i+1, 2, 2);
book(_h_pt_diff[i], i+1, 3, 2);
book(_njets[i], "njets_"+to_string(i));
}
}
double ptsmear(const double pttrue, const double cent) {
double c(0.0246);
double s(1.213);
double n;
if (cent < 0. || cent > 0.5) n=0.001;
if (cent > 0.3 && cent < 0.5) n=3.88;
if (cent > 0.1 && cent < 0.3) n=5.10;
if (cent > 0. && cent < 0.1) n=5.23;
n=5.23;
double sigma(sqrt(c*c+s*s/pttrue+n*n/(pttrue*pttrue)));
double r1(1.0*rand()/RAND_MAX), r2(1.0*rand()/RAND_MAX);
double fac(max(sqrt(-2.*log(r1))*cos(2.*M_PI*r2)*sigma+1.,0.));
return fac*pttrue;
}
/// extract thermal momenta, that should be subtracted, from HepMC event
vector<FourMomentum> extractThermalMomenta(const Event & event) {
vector<FourMomentum> thermom;
for (const HepMC::GenParticle* p : Rivet::HepMCUtils::particles(event.genEvent())) {
FourMomentum mom(p->momentum());
if (p->status() == 3) {
thermom.push_back(mom);
}
}
return thermom;
}
/// build map from dummy particles to thermal momenta to speed up subtraction
map<FourMomentum, FourMomentum, FourMomComp> buildThMomMap(const Event & event, const vector<FourMomentum> * thermom) {
map<FourMomentum, FourMomentum, FourMomComp> thmap;
size_t j(0);
for (const HepMC::GenParticle* p : Rivet::HepMCUtils::particles(event.genEvent())) {
FourMomentum mom(p->momentum());
if (fuzzyEquals(mom.E(), 1e-6)) {
if (j == thermom->size()) {
cout<<"Error: number of dummies does not match number of subtractions, will veto Event"<<endl;
thmap.clear();
return thmap;
}
FourMomentum sc((*thermom)[j]);
thmap[mom]=sc;
j++;
}
}
return thmap;
}
/// 4-momentum subtraction
FourMomentum SubtractJetMom(Jet jet, map<FourMomentum, FourMomentum, FourMomComp> * tmmap) {
if (tmmap->empty()) return jet.momentum();
FourMomentum sub(0.,0.,0.,0.);
for (Particle part : jet.constituents()) {
if (fuzzyEquals(part.E(), 1e-6)) {
map<FourMomentum, FourMomentum, FourMomComp>::iterator mapit;
mapit = (*tmmap).find(part.momentum());
if (mapit == (*tmmap).end()) cout<<"Error: did not find matching scattering centre in map.\n"<<part.momentum()<<endl;
else sub += mapit->second;
}
}
FourMomentum jetmom(jet.momentum());
//cout<<"Original momentum: "<<jetmom<<endl;
jetmom -= sub;
//cout<<"subtracted momentum: "<<jetmom<<endl;
//cout<<"Subtracted pt: "<<subpt<<" "<<pjet.pt()<<endl;
return jetmom;
}
/// 4-momentum adapter
FourMomentum Get4Mom(PseudoJet pjet){
FourMomentum mom(pjet.E(), pjet.px(), pjet.py(), pjet.pz());
return mom;
}
/// Perform the per-event analysis
void analyze(const Event& event) {
const double cent = (event.genEvent()->heavy_ion()?event.genEvent()->heavy_ion()->impact_parameter():-1.);
if (cent > 0.1) vetoEvent;
//const Particles tracks;
Jets jetssub;
#if MODE==0
const Particles tracks = apply<ChargedFinalState>(event, "CFS").particles();
const Jets alljets = apply<FastJets>(event, "Jets").jetsByPt(3.*GeV);
vector<FourMomentum> thermom = extractThermalMomenta(event);
map<FourMomentum, FourMomentum, FourMomComp> thmommap = buildThMomMap(event, &thermom);
for (Jet jet : alljets) {
FourMomentum jetsub = SubtractJetMom(jet, &thmommap);
jetssub.push_back(Jet(jetsub));
}
#elif MODE==1
const Jets loosejets = apply<FastJets>(event, "LooseJets").jetsByPt(_ptminloose);
if (loosejets.empty()) vetoEvent;
const Particles tracks = apply<ChargedFinalState>(event, "CSFS").particles();
const FastJets fjs = apply<FastJets>(event, "Jets");
jetssub = fjs.jets( Cuts::pt > _ptminloose);
#endif
map<Jet, double, jetcomp> jetmap;
for (Jet jet : jetssub) {
double ptreco, ptgen;
ptgen = jet.momentum().pT();
ptreco = ptsmear(ptgen,cent);
jetmap[jet] = ptreco;
}
Jets jets;
for (Jet jet : jetssub) {
if (fabs(jet.momentum().eta()) > _etamin && fabs(jet.momentum().eta()) < _etamax &&
jetmap[jet] > _ptmin && jetmap[jet] < _ptmax)
jets.push_back(jet);
}
for (Jet jet : jets) {
_njets[0]->fill();
double jetpt = jetmap[jet];
int ptbin(-1);
for (size_t l = 0; l < _Nptbins; ++l) {
if (jetpt >= _ptedges[l] && jetpt < _ptedges[l+1]) ptbin=l;
}
//shift: first histo is inclusive
if (ptbin >= 0) ptbin+=1;
_njets[ptbin]->fill();
for (Particle part : tracks){
+ if (part.pT() < _trackptmin) continue;
double dR(deltaR(part,jet));
if (dR >= _jetR) continue;
double z,xi;
z = part.momentum().p3().dot(jet.momentum().p3())/sqr(jet.momentum().p3().mod());
//z*=jet.momentum().pT()/jetpt;
xi = log(1./z);
if (cent < 0.) {
if (ptbin > 0) {
_h_xi_pp[ptbin]->fill(xi);
_h_xi_pp[0]->fill(xi);
_h_pt_pp[ptbin]->fill(part.pT());
_h_pt_pp[0]->fill(part.pT());
}
}
else {
if (ptbin > 0) {
_h_xi_PbPb[ptbin]->fill(xi);
_h_xi_PbPb[0]->fill(xi);
_h_pt_PbPb[ptbin]->fill(part.pT());
_h_pt_PbPb[0]->fill(part.pT());
}
}
_h_xi_ratio[ptbin]->fill(xi);
_h_xi_ratio[0]->fill(xi);
_h_pt_diff[ptbin]->fill(part.pT());
_h_pt_diff[0]->fill(part.pT());
}
}
}
/// Normalise histograms etc., after the run
void finalize() {
for (size_t i = 0; i < _Nptbins+1; ++i) {
scale(_h_xi_pp[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
scale(_h_xi_PbPb[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
scale(_h_xi_ratio[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
scale(_h_pt_pp[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
scale(_h_pt_PbPb[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
scale(_h_pt_diff[i],1./(_njets[i]->val()>0.?_njets[i]->val():1.));
}
}
private:
vector<double> _ptedges;
double _jetR, _trackptmin, _etamin, _etamax, _ptmin, _ptmax;
double _etaloose, _ptminloose, _dRloose;
size_t _netabins, _nphibins;
size_t _Nptbins;
Histo1DPtr _h_xi_pp[4], _h_xi_PbPb[4], _h_xi_ratio[4];
Histo1DPtr _h_pt_pp[4], _h_pt_PbPb[4], _h_pt_diff[4];
CounterPtr _njets[4];
};
// The hook for the plugin system
/*#if MODE==0
DECLARE_RIVET_PLUGIN(CMS_2014_I1299142_4MOMSUB);
#elif MODE==1
DECLARE_RIVET_PLUGIN(CMS_2014_I1299142_CONSTSUB);
#endif*/
DECLARE_RIVET_PLUGIN(CMS_2014_I1299142);
}