Page MenuHomeHEPForge
Files F11222155

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: jewel/jewel-3.0.1.f
===================================================================
--- jewel/jewel-3.0.1.f (revision 7)
+++ jewel/jewel-3.0.1.f (revision 8)
@@ -1,5434 +1,5452 @@
PROGRAM MEDIUM_CASCADE
IMPLICIT NONE
INTEGER PYCOMP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2)
&,SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--technical variables for getmass
COMMON/VIOL/FACTOR,NINTV,NVIOLQ,NVSEVQ,NVIOLG,NVSEVG,NEWMC
INTEGER NINTV,NVIOLQ,NVIOLG,NVSEVQ,NVSEVG
DOUBLE PRECISION FACTOR
LOGICAL NEWMC
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--nuclear thickness function
COMMON /THICKFNC/ RMAX,TA(100,2)
DOUBLE PRECISION RMAX,TA
C--mean kt
COMMON/MEANKT/NKT1(20),SUMKT1(20)
INTEGER NKT1
DOUBLE PRECISION SUMKT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--Variables for ntuples
C--Note that you have to use REAL for PAW and HBOOK
CHARACTER*8 INFO(NINFO)
REAL RUN(NINFO)
INTEGER ISTAT,ICYCLE
DATA INFO/'n'/
C--Variables local to this program
INTEGER J,NSIM,I,NOLD,PID,JJ,NSKIPV,NSKIPM,NSKIP2,
&NJET
DOUBLE PRECISION PYR,ENI,QMAXI,PI,R,GETMASS,TMP,Q,GETPROBA,
&PNOSCAT,GETNOSCAT,DELTAT,PYP,D3,ZETA3,X0,Y0,L,X1,X2,Y1,
&Y2,Z,ZVAL,PHI,RAU,X,Y,POWER,PTMIN,PTMAX,ECUT,WEIGHTEX,
&SUMOFWEIGHTS,NDISC,NNULL,GETPDFXINT,GETINSUDAFAST,GETINSUDAKOV,
&GETINSUDARED,GETNEFF,GETTEMP,DX,DY
CHARACTER TYPE1
CHARACTER*2 TYPE2
CHARACTER*80 VERSION,FILENAME,FILENAME2,FILENAME3,FILENAMEIN,
&PDFFILE,XSECFILE
LOGICAL READRAN,CONT,VARYL,ALLHAD,NJETFR,HADRO,PDFEXIST,
&XSECEXIST,WEIGHTED
DATA PI/3.141592653589793d0/
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA VERSION/'JEWEL 3.0.1'/
***********************************************************************
*** Read input for simulation from job-file
***********************************************************************
C--Number of simulated events
READ(*,*) NSIM
C--Filename for hb-file
READ(*,'(a)') FILENAME
C--Filename for dat-file
READ(*,'(a)') FILENAME2
C--Output file for random number generator status
READ(*,'(a)') FILENAME3
C--Read random number generator status from file?
READ(*,*) READRAN
C--Input file for random number generator status
READ(*,'(a)') FILENAMEIN
C--Input file for pdf's
READ(*,'(a)') PDFFILE
C PDFFILE='pdfs.100.dat'
C--Input file for cross section integrals
READ(*,'(a)') XSECFILE
C XSECFILE='xsecs.100.dat'
C--number of light flavours
READ(*,*) NF
C--Lambda for parton shower
READ(*,*) LPS
C--Lambda
READ(*,*) LQCD
C--Q_0
READ(*,*) Q0
C--minimum kt in splitting and gluon radiation
READ(*,*) KTMIN
C--initiating parton ID
READ(*,*) PID
C--power of pt-spectrum
READ(*,*) POWER
C--minimum pt
READ(*,*) PTMIN
C--maximum pt
READ(*,*) PTMAX
C--angular ordering?
READ(*,*) ANGORD
C--constrained evolution?
READ(*,*) CONSTR
C--minimum energy for daughters
READ(*,*) MINEN
C--fmed
READ(*,*) FMED
C--temperature
READ(*,*) TEMP
C--nuclear radius
READ(*,*) RAU
C--vary path length?
READ(*,*) VARYL
C--keep recoiling scattering centre in shower?
READ(*,*) KEEPRECOIL
C--use new MC routine?
READ(*,*) NEWMC
C--number of intervals
READ(*,*) NINTV
C--factor
READ(*,*) FACTOR
C--scattering of recoiling scattering centre?
READ(*,*) SCATRECOIL
C--hadronise all particles inlcuding recoiling scattering centres?
READ(*,*) ALLHAD
C--look at n-jet fraction?
READ(*,*) NJETFR
C--hadronise?
READ(*,*) HADRO
C--brick problem?
READ(*,*) BRICK
C--exact solution of splitting integral?
READ(*,*) EXACT
C--veto algorithm?
READ(*,*) VETO
C--weighted events?
READ(*,*) WEIGHTED
C--weight exponent
READ(*,*) WEIGHTEX
IF(BRICK) THEN
HADRO=.FALSE.
SCATRECOIL=.FALSE.
VARYL=.FALSE.
ENDIF
QMIN=SQRT(Q0**2+4.*(KTMIN*LPS)**2)
MD=3.*TEMP
MS=MD/SQRT(2.)
NP=(2.*12.*NF*D3/3.+3.*16.*ZETA3/2.)*TEMP**3/PI**2
C NP=NP*3.d0
C MD=1.
C MS=0.7
C NP=5.11
IF(NF.EQ.0) PID=21
IF(PID.EQ.21)THEN
TYPE1='G'
TYPE2='GC'
ELSE
TYPE1='Q'
TYPE2='QQ'
ENDIF
IF(EXACT) CALL SPLITFNCINT(PTMAX)
CALL EIXINT
CALL INSUDAINT(PTMAX)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(PDFEXIST)THEN
OPEN(unit=10,file=PDFFILE,status='old')
- READ(10,*)QINQ
- READ(10,*)GINQ
- READ(10,*)QING
- READ(10,*)GING
- READ(10,*)QINQX
- READ(10,*)GINQX
- READ(10,*)QINGX
- READ(10,*)GINGX
+ DO 870 I=1,101
+ DO 871 J=1,101
+ READ(10,*)QINQ(I,J),GINQ(I,J),QING(I,J),GING(I,J)
+ 871 CONTINUE
+ 870 CONTINUE
+ DO 872 I=1,101
+ DO 873 J=1,101
+ READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 873 CONTINUE
+ 872 CONTINUE
CLOSE(10,status='keep')
ELSE
CALL PDFINT(PTMAX)
OPEN(unit=10,file=PDFFILE,status='new')
- WRITE(10,*)QINQ
- WRITE(10,*)GINQ
- WRITE(10,*)QING
- WRITE(10,*)GING
- WRITE(10,*)QINQX
- WRITE(10,*)GINQX
- WRITE(10,*)QINGX
- WRITE(10,*)GINGX
+ DO 874 I=1,101
+ DO 875 J=1,101
+ WRITE(10,*)QINQ(I,J),GINQ(I,J),QING(I,J),GING(I,J)
+ 875 CONTINUE
+ 874 CONTINUE
+ DO 876 I=1,101
+ DO 877 J=1,101
+ WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 877 CONTINUE
+ 876 CONTINUE
CLOSE(10,status='keep')
ENDIF
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(XSECEXIST)THEN
OPEN(unit=10,file=XSECFILE,status='old')
- READ(10,*)INTQ1
- READ(10,*)INTQ2
- READ(10,*)INTG1
- READ(10,*)INTG2
+ DO 880 I=1,101
+ DO 881 J=1,101
+ READ(10,*)INTQ1(I,J),INTQ2(I,J),INTG1(I,J),INTG2(I,J)
+ 881 CONTINUE
+ 880 CONTINUE
CLOSE(10,status='keep')
ELSE
CALL XSECINT(PTMAX)
OPEN(unit=10,file=XSECFILE,status='new')
- WRITE(10,*)INTQ1
- WRITE(10,*)INTQ2
- WRITE(10,*)INTG1
- WRITE(10,*)INTG2
+ DO 882 I=1,101
+ DO 883 J=1,101
+ WRITE(10,*)INTQ1(I,J),INTQ2(I,J),INTG1(I,J),INTG2(I,J)
+ 883 CONTINUE
+ 882 CONTINUE
CLOSE(10,status='keep')
ENDIF
OPEN(unit=1,file='TAu.dat',status='old')
DO 125 I=1,7
READ(1,*)
125 CONTINUE
DO 124 I=1,100
READ(1,*)TA(I,1),TA(I,2)
124 CONTINUE
CLOSE(1,status='keep')
RMAX=12.6105562
***********************************************************************
*** Initialise hbook
***********************************************************************
C--Open hbook file
CALL HLIMIT(NHBOOK)
CALL HROPEN(1,'test',FILENAME,'N',1024,ISTAT)
C--Book ntuples and histograms
CALL HBOOKN(10,'File information',NINFO,'test',NPRIME,INFO)
CALL HBOOK1(100,'ln(1/xp) parton',100,0.,10.,0.)
CALL HBOOK1(110,'ln(1/xp) hadron',100,0.,10.,0.)
CALL HBOOK1(101,'quarks ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(102,'gluons ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(120,'antiquarks ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(121,'gluon from gluon',100,0.,10.,0.)
CALL HBOOK1(122,'gluon from quark',100,0.,10.,0.)
CALL HBOOK1(123,'gluon from antiquark',100,0.,10.,0.)
CALL HBOOK1(103,'z',100,0.,1.,0.)
CALL HBOOK1(109,'x',41,0.,1.25,0.)
CALL HBOOK1(104,'E/t all',100,0.,5.,0.)
CALL HBOOK1(105,'mass before first splitting',100,0.,100.,0.)
CALL HBOOK1(106,'# gluons',51,-0.5,50.5,0.)
CALL HBOOK1(107,'parton energy',100,0.,100.,0.)
CALL HBOOK1(108,'virtuality ratio',100,0.,1.,0.)
CALL HBOOK1(115,'kt wrt jet axis',100,0.,10.,0.)
CALL HBOOK1(116,'kt wrt trigger',100,0.,10.,0.)
CALL HBOOK1(117,'theta trig',100,0.,REAL(PI),0.)
CALL HBOOK1(118,'theta wrt jet axis',100,0.,REAL(PI),0.)
CALL HBOOK1(119,'theta wrt trigger',100,0.,REAL(PI),0.)
CALL HBOOK1(130,'energy vs theta (jet)',100,0.,REAL(PI),0.)
CALL HBOOK1(131,'kt wrt trigger trig high',100,0.,10.,0.)
CALL HBOOK1(132,'kt wrt trigger both high',100,0.,10.,0.)
CALL HBOOK1(133,'theta wrt trigger trig high',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(134,'theta wrt trigger both high',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(135,'theta wrt trig both high 2',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(140,'Delta E',200,-100.,100.,0.)
CALL HBOOK1(141,'Delta p',200,-100.,100.,0.)
CALL HBOOK1(142,'Delta Q',210,-1000.,10000.,0.)
CALL HBOOK1(300,'scat. centre E before',100,0.,10.,0.)
CALL HBOOK1(301,'scatt centre E after',100,0.,10.,0.)
CALL HBOOK1(302,'scat. centre pt before',100,0.,10.,0.)
CALL HBOOK1(303,'scatt centre pt after',100,0.,10.,0.)
CALL HBOOK1(304,'scat. centre cos(theta) before',
& 100,-1.,1.,0.)
CALL HBOOK1(305,'scatt centre cos(theta) after',100,-1.,1.,0.)
CALL HBOOK1(306,'scat. centre theta before',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(307,'scatt centre theta after',100,0.,REAL(PI),0.)
CALL HBOOK1(320,'l',100,0.,REAL(2.*RAU),0.)
CALL HBOOK1(321,'energy hadron',100,0.,15.,0.)
CALL HBOOK1(322,'energy parton',100,0.,15.,0.)
CALL HBOOK1(330,'Delta E col',111,-0.05,1.05,0.)
CALL HBOOK1(331,'Delta E rad',111,-0.05,1.05,0.)
CALL HBOOK1(332,'Delta E col+rad',111,-0.05,1.05,0.)
CALL HBOOK1(333,'dN/domega',100,0.,REAL(PTMAX),0.)
CALL HBOOK1(400,'kt triggered wrt trigger',100,0.,10.,0.)
CALL HBOOK1(401,'kt triggered wrt jet 0.5',100,0.,10.,0.)
CALL HBOOK1(402,'kt triggered wrt jet 1',100,0.,10.,0.)
CALL HBOOK1(403,'kt triggered wrt jet 2',100,0.,10.,0.)
CALL HBOOK1(404,'kt triggered wrt jet 5',100,0.,10.,0.)
CALL HBOOK1(405,'kt triggered wrt jet 10',100,0.,10.,0.)
CALL HBOOK1(406,'mean kt above threshold',20,-0.25,9.75,0.)
CALL HBOOK2(407,'mean kt above threshold',
& 20,-0.25,9.75,100,0.,10.,0.)
CALL HBOOK1(444,'string inv. mass',100,0.,100.,0.)
CALL HBOOK2(200,'xi-theta',100,0.,10.,100,0.,REAL(PI),0.)
CALL HBOOK2(210,'E-DE/E',100,0.,100.,100,0.,1.,0.)
CALL HBOOK2(220,'xi-Nscat',100,0.,10.,11,-0.5,10.5,0.)
CALL HBOOK2(601,'1 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(602,'2 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(603,'3 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(604,'4 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(605,'5 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(611,'1 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(612,'2 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(613,'3 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(614,'4 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(615,'5 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(708,'thrust parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(703,'thrust major parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(704,'thrust minor parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(718,'thrust hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(713,'thrust major hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(714,'thrust minor hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(800,'pt - theta after',100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(801,'E - theta after',100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(802,'pt - theta after hadro',
& 100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(803,'E - theta after hadro',
& 100,0.,10.,100,-1.,1.,0.)
C--jkl
CALL HBOOK2(201,'prod. point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(202,'scattering point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(204,'spl. point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(207,'particle vertex',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(250,'prod. momentum',
&100,-1.5*REAL(PTMAX),1.5*REAL(PTMAX),
&100,-1.5*REAL(PTMAX),1.5*REAL(PTMAX),0.)
CALL HBOOK1(251,'prod. energy',
&100,0.,1.5*REAL(PTMAX),0.)
CALL HBOOK1(900,'delta t',100,0.,10.,0.)
CALL HBOOK1(901,'delta l',100,0.,10.,0.)
CALL HBOOK2(910,'medium temp.',200,-2.*REAL(RAU),2.*REAL(RAU),
& 200,-2.*REAL(RAU),2.*REAL(RAU),0.)
CALL HBOOK1(911,'medium density',100,0.,1.1*REAL(RAU),0.)
C--Call PYR once for initialization
R=PYR(0)
C--initialise medium and produce some plots
CALL MEDINIT
CALL MEDNEXTEVT
DX=2.*RAU/100.d0
DY=2.*RAU/100.d0
DO 75 I=1,200
DO 76 JJ=1,200
CALL HF2(910,REAL(-2.d0*RAU-DX/2.d0+I*DX),
&REAL(-2.d0*RAU-DY/2.d0+JJ*DY),
&REAL(GETTEMP(-2.d0*RAU+I*DX-DX/2.d0,
&-2.d0*RAU+JJ*DY-DY/2.d0,0.d0,0.9d0)))
76 CONTINUE
75 CONTINUE
DO 79 I=1,100
CALL HF1(911,REAL((I-0.5)*1.1d0*RAU/100.d0),
&REAL(GETNEFF(0.D0,0.D0,0.D0,I*1.1d0*RAU/100.d0)))
79 CONTINUE
C--read random number generator from file if desired
IF(READRAN)THEN
OPEN(unit=2,file=FILENAMEIN,access='sequential',
& form='unformatted',status='old')
CALL PYRSET(2,0)
CLOSE(2,status='keep')
WRITE(*,*) 'read random number generator status'
ENDIF
C--write random number generator state to file
OPEN(unit=2,file=FILENAME3,access='sequential',
& form='unformatted',status='unknown')
CALL PYRGET(2,0)
NDISC=0.d0
NNULL=0.d0
C--switch off pi0 decay
MDCY(PYCOMP(111),1)=0
C MSTJ(1)=2
C MSTJ(2)=3
C MSTJ(3)=0
C MSTJ(14)=1
C--parameters for cluster finding algorithm
MSTU(41)=2
MSTU(42)=2
MSTU(46)=6
MSTU(47)=1
DO 77 JJ=1,20
NKT1(JJ)=0
SUMKT1(JJ)=0.d0
77 CONTINUE
SUMOFWEIGHTS=0.d0
NSCAT=0.d0
NSPLIT=0.d0
DELTAECOLTOT=0.d0
DELTAERADTOT=0.d0
LSUM=0.d0
TSUMCOH=0.d0
TSUMINCOH=0.d0
DO 100 J=1,NSIM
DELTAECOL=0.d0
DELTAERAD=0.d0
DISCARD=.FALSE.
DO 91 I=1,5000
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
91 CONTINUE
CALL MEDNEXTEVT
C--pick a pt for the initiating parton
R=PYR(0)
ENI=(PTMIN**(1.-POWER)*(1.-R)
& +PTMAX**(1.-POWER)*R)**(1./(1.-POWER))
QMAXI=ENI
IF(WEIGHTED)THEN
EVWEIGHT=REAL(ENI**(WEIGHTEX-POWER))
ELSE
EVWEIGHT=1.
ENDIF
SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
CALL PICKVTX(X0,Y0)
LTIME=RAU
C--store standard quark or gluon in the event record
N=2
K(N,1)=1
K(N,2)=PID
K(N,3)=0
K(N,4)=0
K(N,5)=0
P(N,4)=ENI
C--find virtuality
IF(BRICK)THEN
P(N,5)=0.d0
ELSE
P(N,5)=GETMASS(0.d0,QMAXI,1.d0,1.d0,P(N,4),
& TYPE2,QMAXI,0.d0,.FALSE.)
ENDIF
CALL HF1(105,REAL(P(N,5)),EVWEIGHT)
IF(P(N,5).EQ.0.d0) NNULL=NNULL+EVWEIGHT
P(N,1)=SQRT(P(N,4)**2-P(N,5)**2)
P(N,2)=0.
P(N,3)=0.
CALL HF2(250,REAL(P(N,1)),REAL(P(N,2)),1.)
CALL HF1(251,REAL(P(N,4)),1.)
MV(N,1)=X0
MV(N,2)=Y0
MV(N,3)=0.
MV(N,4)=0.d0
IF(P(N,5).GT.0.d0)THEN
MV(N,5)=ENI*0.2/P(N,5)**2
ELSE
MV(N,5)=LTIME
ENDIF
CALL HF2(201,REAL(MV(N,1)),REAL(MV(N,2)),1.)
ZA(N)=1.d0
C--develop parton shower
CALL MAKECASCADE
C CALL MAKEBRANCH(2)
C WRITE(*,*)'makecascade done'
IF(DISCARD) THEN
NDISC=NDISC+EVWEIGHT
C CALL PYLIST(3)
IF(N.EQ.2) CALL HF1(135,REAL(P(2,5)),EVWEIGHT)
WRITE(*,*)'discard event',J
WRITE(*,*)'ltime=',LTIME
GOTO 102
ELSE
CALL HF1(125,REAL(P(2,5)),EVWEIGHT)
ENDIF
CALL HF1(330,REAL(DELTAECOL/ENI),EVWEIGHT)
CALL HF1(331,REAL(DELTAERAD/ENI),EVWEIGHT)
CALL HF1(332,REAL((DELTAECOL+DELTAERAD)/ENI),EVWEIGHT)
C-- copy and check the vertices of all particles (debugging)
DO 111 I=2,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)
CALL HF2(207,REAL(MV(I,1)),REAL(MV(I,2)),EVWEIGHT)
111 CONTINUE
IF(.NOT.ALLHAD)THEN
DO 86 I=1,N
IF(K(I,1).EQ.3) K(I,1)=22
86 CONTINUE
ENDIF
C IF(.NOT.HADRO) CALL SHOWANA(ENI)
DO 81 JJ=1,6
ECUT=(JJ-1)*1.d0
DO 82 I=1,N
IF((K(I,1).EQ.1).AND.(P(I,4).LT.ECUT)) K(I,1)=19
IF((K(I,1).EQ.3).AND.(P(I,4).LT.ECUT)) K(I,1)=20
82 CONTINUE
IF(NJETFR)THEN
CALL NJETANA(JJ,.TRUE.,ENI)
ELSE
CALL EVSHAPEANA(JJ,.TRUE.,ENI)
ENDIF
81 CONTINUE
DO 83 I=1,N
IF(K(I,1).EQ.19) K(I,1)=1
IF(K(I,1).EQ.20) K(I,1)=3
83 CONTINUE
IF(HADRO)THEN
CALL MAKESTRINGS
CALL PYEXEC
DO 80 I=1,N
IF(K(I,2).EQ.92) CALL HF1(444,REAL(P(I,5)),EVWEIGHT)
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3)).AND.
& (ABS(PYP(I,19)).GT.1.))
& K(I,1)=23
80 CONTINUE
C CALL SHOWANA(ENI)
DO 90 I=1,N
IF(K(I,1).LT.11) THEN
CALL HF2(802,REAL(PYP(I,10)),REAL(P(I,1)/PYP(I,8)),EVWEIGHT)
CALL HF2(803,REAL(P(I,4)),REAL(P(I,1)/PYP(I,8)),EVWEIGHT)
ENDIF
90 CONTINUE
DO 84 JJ=1,6
ECUT=(JJ-1)*1.d0
DO 85 I=1,N
IF((K(I,1).EQ.1).AND.(P(I,4).LT.ECUT)) K(I,1)=19
IF((K(I,1).EQ.3).AND.(P(I,4).LT.ECUT)) K(I,1)=20
85 CONTINUE
IF(NJETFR)THEN
CALL NJETANA(JJ,.FALSE.,ENI)
ELSE
CALL EVSHAPEANA(JJ,.FALSE.,ENI)
ENDIF
84 CONTINUE
DO 87 I=1,N
IF(K(I,1).EQ.19) K(I,1)=1
IF(K(I,1).EQ.20) K(I,1)=3
87 CONTINUE
ENDIF
CALL SHOWANA(ENI)
C--write message to log-file
102 IF(NSIM.GT.100)THEN
IF(MOD(J,NSIM/100).EQ.0)THEN
WRITE(*,*) 'event number ',J,' completed'
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
ELSE
WRITE(*,*) 'event number ',J,' completed'
CALL FLUSH
C CALL PYLIST(3)
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
C--next event
100 CONTINUE
***********************************************************************
*** Finish
***********************************************************************
DO 78 JJ=1,20
IF(NKT1(JJ).GT.0)
& CALL HF1(406,(JJ-1)/2.,REAL(SUMKT1(JJ)/NKT1(JJ)))
78 CONTINUE
WRITE(*,*)
WRITE(*,*)'mean number of scatterings:',
& NSCAT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean number of splittings:',
& NSPLIT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean collisional energy loss:',
& DELTAECOLTOT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean radiative energy loss:',
& DELTAERADTOT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean that incoherent:',-TSUMINCOH/LSUM,' GeV^2/fm'
WRITE(*,*)'mean that coherent:',-TSUMCOH/LSUM,' GeV^2/fm'
WRITE(*,*)
WRITE(*,*)'number of discarded events: ',NDISC
WRITE(*,*)'number of events without splitting: ',NNULL
C--Fill the run information ntuple
RUN(1)=SUMOFWEIGHTS-NDISC
CALL HFN(10,RUN)
C--Write histograms to file and close it
CALL HROUT(0,ICYCLE,'T')
CALL HREND('test')
CLOSE(1)
C--write parameters to dat-file
OPEN(unit=1,file=FILENAME2,status='unknown')
READ(1,*)
WRITE(1,'(A20,A)') 'version: ',VERSION
WRITE(1,'(A20,A)') 'filename: ',FILENAME
WRITE(1,'(A20,L10)')'readran: ',READRAN
IF(READRAN) WRITE(1,'(A20,A)') 'filename: ',FILENAMEIN
WRITE(1,'(A20,A)') 'pdf file: ',PDFFILE
WRITE(1,'(A20,A)') 'cross section file: ',XSECFILE
WRITE(1,'(A20,I10)') 'nsim: ',NSIM
WRITE(1,'(A20,I10)') 'nf: ',NF
WRITE(1,'(A20,F10.2)') 'Lambda(ps):',LPS
WRITE(1,'(A20,F10.2)') 'Lambda: ',LQCD
WRITE(1,'(A20,F10.2)') 'Q_0: ',Q0
WRITE(1,'(A20,F10.2)') 'ktmin: ',KTMIN
WRITE(1,'(A20,I10)') 'pid: ',PID
WRITE(1,'(A20,F10.2)') 'power: ',POWER
WRITE(1,'(A20,F10.2)') 'ptmin: ',PTMIN
WRITE(1,'(A20,F10.2)') 'ptmax: ',PTMAX
WRITE(1,'(A20,L10)') 'angord: ',ANGORD
WRITE(1,'(A20,L10)') 'constr: ',CONSTR
WRITE(1,'(A20,F10.2)') 'Emin: ',MINEN
WRITE(1,'(A20,F10.2)') 'f_med: ',FMED
WRITE(1,'(A20,F10.2)') 'temp: ',TEMP
WRITE(1,'(A20,F10.2)') 'mD: ',MD
WRITE(1,'(A20,F10.2)') 'ms: ',MS
WRITE(1,'(A20,F10.2)') 'nP: ',NP
WRITE(1,'(A20,F10.2)') 'Rau: ',RAU
WRITE(1,'(A20,L10)') 'varyl: ',VARYL
WRITE(1,'(A20,L10)') 'keeprecoil:',KEEPRECOIL
WRITE(1,'(A20,L10)') 'newmc: ',NEWMC
WRITE(1,'(A20,I10)') 'nintv: ',NINTV
WRITE(1,'(A20,F10.2)') 'factor: ',FACTOR
WRITE(1,'(A20,L10)') 'scatrecoil: ',SCATRECOIL
WRITE(1,'(A20,L10)') 'allhad: ',ALLHAD
WRITE(1,'(A20,L10)') 'njetfr: ',NJETFR
WRITE(1,'(A20,L10)') 'hadro: ',HADRO
WRITE(1,'(A20,L10)') 'brick: ',BRICK
WRITE(1,'(A50,L10)') 'exact split. int.: ',EXACT
WRITE(1,'(A50,L10)') 'veto algorithm: ',VETO
WRITE(1,'(A50,L10)') 'weighted events: ',WEIGHTED
WRITE(1,'(A20,F10.2)') 'weight exponent: ',WEIGHTEX
WRITE(1,*)
WRITE(1,*)
WRITE(1,*)'mean number of scatterings:',NSCAT/(NSIM-NDISC)
WRITE(1,*)'mean number of splittings:',NSPLIT/(NSIM-NDISC)
WRITE(1,*)'mean collisional energy loss:',
& DELTAECOLTOT/(NSIM-NDISC)
WRITE(1,*)'mean radiative energy loss:',
& DELTAERADTOT/(NSIM-NDISC)
WRITE(1,*)'mean that incoherent:',-TSUMINCOH/LSUM,' GeV^2/fm'
WRITE(1,*)'mean that coherent:',-TSUMCOH/LSUM,' GeV^2/fm'
WRITE(1,*)
WRITE(1,*)'number of discarded events: ',NDISC*NSIM/SUMOFWEIGHTS
WRITE(1,*)'number of events without splitting: ',
& NNULL*NSIM/SUMOFWEIGHTS
CLOSE(1,status='keep')
DO 200 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)
200 CONTINUE
IF(.NOT.DISCARD) CALL PYLIST(3)
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 MAKESTRINGS
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
INTEGER NOLD,I,J,LMAX,LMIN,LEND,LSTART,PARENT,LTMP
DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR
DATA MCUT/1.d8/
DATA EADDEND/10.d0/
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(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4))
& .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) RETURN
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-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
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 CALL PYLIST(2)
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))
& .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
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
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
END
***********************************************************************
*** subroutine makecascade
***********************************************************************
*** manages the parton shower, i.e. finds all partons that still
*** may evolve and calls makebranch for them
***********************************************************************
SUBROUTINE MAKECASCADE
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--finished with parton
COMMON/DONEP/DONE(4000)
LOGICAL DONE
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--local variables
INTEGER NOLD,I
LOGICAL CONT
CALL MAKEBRANCH(2)
C WRITE(*,*)'makebranch(2) done'
IF(BRICK) RETURN
IF(DISCARD) GOTO 12
10 NOLD=N
CONT=.FALSE.
DO 11 I=2,NOLD
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.
C WRITE(*,*)'call makebranch(',I,')'
CALL MAKEBRANCH(I)
C WRITE(*,*)'makebranch(',I,') done'
IF(DISCARD) GOTO 12
ENDIF
11 CONTINUE
IF(CONT) GOTO 10
12 END
***********************************************************************
*** subroutine makebranch
***********************************************************************
*** develops a single parton until it cannot split or scatter
*** any more
***********************************************************************
SUBROUTINE MAKEBRANCH(L)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER L,LINE,NLINE,NOLD,I,TYPI,LINEOLD
DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,GETNOSCAT,STARTTIME,TLEFT,
&PNOSCAT,TSUM,R,PYR,DELTAT,NEWMASS,GETMASS,
&QSUMOLD2,GETNEWMASS,GETDELTAL,X,GETTEMP,GETNEFF
CHARACTER TYP
LOGICAL RADIATION,RETRYSPLIT,GETDELTAT,NOSCAT
C WRITE(*,*)'*************************************************'
C WRITE(*,*)'start makebranch for line ',L
LINE=L
NSTART=0
NEND=0
STARTTIME=MV(LINE,4)
TSUM=0.d0
QSUM2=0.d0
QSUMOLD2=0.d0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
C 20 WRITE(*,*)'go in next iteration: L= ',LINE
C WRITE(*,*)'qsum^2= ',QSUM2
C WRITE(*,*)'Nend= ',NEND,' ; Nstart= ',NSTART
C DO 201 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 201 CONTINUE
C CALL PYLIST(3)
C IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
20 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(P(LINE,5).GT.MS)))THEN
FORMTIME=MIN(0.2*P(LINE,4)/P(LINE,5)**2,LTIME-STARTTIME)
RADIATION=.TRUE.
ELSE
FORMTIME=LTIME-STARTTIME
RADIATION=.FALSE.
ENDIF
TLEFT=FORMTIME-TSUM
IF(K(LINE,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
C WRITE(*,*)'formation time: ',FORMTIME
C WRITE(*,*)'remaining time: ',TLEFT
C WRITE(*,*)'starting time: ',STARTTIME
C WRITE(*,*)'tsum: ',TSUM
C--check if there is scattering during formation time
NOSCAT=.NOT.GETDELTAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT)
IF(.NOT.NOSCAT)CALL HF1(900,REAL(DELTAT),EVWEIGHT)
PNOSCAT=GETNOSCAT(P(LINE,4),P(LINE,5),STARTTIME+TSUM,TLEFT,
& TYP,PYP(LINE,8)/P(LINE,4))
C WRITE(*,*)'no scattering probability: ',PNOSCAT
C IF(PYR(0).LT.PNOSCAT)THEN
IF(NOSCAT)THEN
C--no scattering
C WRITE(*,*)'no scattering'
IF(RADIATION)THEN
C--if there is radiation associated with the parton then form it now
C WRITE(*,*)'there is radiation'
TSUMCOH=TSUMCOH+QSUM2
LSUM=LSUM+TSUM+TLEFT
MV(LINE,5)=STARTTIME+0.2*P(LINE,4)/P(LINE,5)**2
C--rotate such that momentum points in z-direction
NOLD=N
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)/P(LINE,4)
MV(N-1,2)=MV(LINE,2)+(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/P(LINE,4)
MV(N-1,3)=MV(LINE,3)+(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/P(LINE,4)
MV(N, 1)=MV(LINE,1)+(MV(N, 4)-MV(LINE,4))*P(LINE,1)/P(LINE,4)
MV(N, 2)=MV(LINE,2)+(MV(N, 4)-MV(LINE,4))*P(LINE,2)/P(LINE,4)
MV(N, 3)=MV(LINE,3)+(MV(N, 4)-MV(LINE,4))*P(LINE,3)/P(LINE,4)
CALL HF2(204,REAL(MV(N,1)),REAL(MV(N,2)),EVWEIGHT)
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
C WRITE(*,*)'there is no radiation'
C WRITE(*,*)'nothing to be done'
TSUMCOH=TSUMCOH+QSUM2
LSUM=LSUM+TSUM+TLEFT
NSTART=0
NEND=0
STARTTIME=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 WRITE(*,*)'do scattering'
C--find delta t for the scattering
C DELTAT=GETDELTAL(P(LINE,4),P(LINE,5),MV(LINE,4),TLEFT,TYP,
C & PYP(LINE,8)/P(LINE,4))
C CALL HF1(901,REAL(DELTAT),EVWEIGHT)
TSUM=TSUM+DELTAT
C WRITE(*,*)'delta t= ',DELTAT
C--find (preliminary) four-momentum transfer of scattering
QSUMOLD2=QSUM2
CALL GETXANDT(LINE,X,TYPI,DELTAT)
C WRITE(*,*)'get new t: ',ALLQS(NEND,1)
C WRITE(*,*)'get new x: ',X
IF(LINE.EQ.2) CALL HF1(109,REAL(X),EVWEIGHT)
ALLQS(NEND,6)=STARTTIME+TSUM
TSUMINCOH=TSUMINCOH+ALLQS(NEND,1)
IF(X.LT.1.d0)THEN
FORMTIME=0.2*X*P(LINE,4)/(-ALLQS(NEND,1))
C WRITE(*,*)'estimated formation time ',FORMTIME
IF (FORMTIME.GT.DELTAT) X=1.d0
ENDIF
C--do initial state splitting if there is one
25 IF(X.LT.1.d0) THEN
CALL MAKEINSPLIT(LINE,X,ALLQS(NEND,1),TYPI,STARTTIME)
LINEOLD=LINE
LINE=N
ENDIF
C--figure out new virtuality
NEWMASS=GETNEWMASS(LINE,QSUM2,QSUMOLD2)
C WRITE(*,*)'new mass: ',NEWMASS
IF(NEWMASS.EQ.0.d0) NEWMASS=MAX(0.d0,P(LINE,5))
NEWMASS=MAX(0.d0,P(LINE,5))
C--do kinematics
RETRYSPLIT=.FALSE.
C WRITE(*,*)'do kinematics',NSTART,NEND
IF(NEND.GT.0)
& CALL DOKINEMATICS(LINE,NSTART,NEND,NEWMASS,RETRYSPLIT)
IF(RETRYSPLIT) THEN
C WRITE(*,*)'retry splitting, new line:',LINEOLD
N=N-2
LINE=LINEOLD
K(LINE,1)=1
X=1.d0
GOTO 25
ENDIF
LINE=N
NSTART=0
NEND=0
C STARTTIME=STARTTIME+DELTAT
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
C TSUM=0.d0
ENDIF
21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(P(LINE,5).GT.MS))
& .OR.((STARTTIME.LT.LTIME).AND.
&GETTEMP(MV(LINE,1),MV(LINE,2),MV(LINE,3),STARTTIME).GE.
&0.1D0))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.(P(LINE,5).LE.MS)) K(LINE,1)=4
C WRITE(*,*)'makebranch: we are done, line ',LINE
C DO 202 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 202 CONTINUE
C CALL PYLIST(3)
C WRITE(*,*)'*************************************************'
END
***********************************************************************
*** subroutine makesplitting
***********************************************************************
*** performs splitting of parton on line l of the event record
***********************************************************************
SUBROUTINE MAKESPLITTING(L)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER L,COUNTER,COUNTER2,COUNTB,COUNTC
DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,BMAX,CMAX,
&PTS,MB,MC,GETMASS,PZ,EPS,QH,Z,DELTAT,R,PNOSCAT,GETNOSCAT,
&CMAX1,BET2
LOGICAL QUARK,QQBAR,IFQQBAR
DATA PI/3.141592653589793d0/
C WRITE(*,*)'start makesplitting, L=',L
COUNTER2=0
COUNTER=0
C--on-shell partons cannot split
C IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)) GOTO 31
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)) GOTO 31
C--quark or gluon?
IF(ABS(K(L,2)).EQ.1)THEN
QUARK=.TRUE.
QQBAR=.FALSE.
ELSE
QUARK=.FALSE.
ENDIF
C--if gluon decide on kind of splitting
IF(.NOT.QUARK)THEN
IF(NF.EQ.0)THEN
QQBAR=.FALSE.
ELSE
QQBAR=IFQQBAR(P(L,5),P(K(L,3),5),ZA(L),P(L,4),MV(L,5))
ENDIF
ENDIF
C--generate z value
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(*,*)L,': reject event: angular ordering
& conflict in medium'
CALL PYLIST(3)
DISCARD=.TRUE.
GOTO 31
ENDIF
EPS=0.5-0.5*SQRT(1-QH)
ELSE
EPS=0d0
ENDIF
32 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
C WRITE(*,*)'z=',Z
CALL HF1(103,REAL(Z),EVWEIGHT)
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--additional constraint if angular ordering is active
IF(ANGORD)THEN
BMAX=MIN(SQRT(Z*P(L,5)**2/(4.*(1.-Z))),BMAX1)
CMAX=MIN(SQRT((1.-Z)*P(L,5)**2/(4.*Z)),CMAX1)
ELSE
BMAX=BMAX1
CMAX=CMAX1
ENDIF
C--generate mass of quark or gluon (particle b) from Sudakov FF
30 IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,BMAX1,P(L,5),Z,Z*P(L,4),'QQ',
& BMAX,MV(L,5),.FALSE.)
ELSE
MB=GETMASS(0.d0,BMAX1,P(L,5),Z,Z*P(L,4),'GC',
& BMAX,MV(L,5),.FALSE.)
ENDIF
C WRITE(*,*)'mb=',MB
C--generate mass gluon (particle c) from Sudakov FF
34 IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,CMAX1,P(L,5),1.-Z,(1.-Z)*P(L,4),'GC',
& CMAX,MV(L,5),.FALSE.)
ELSE
MC=GETMASS(0.d0,CMAX1,P(L,5),1.-Z,(1.-Z)*P(L,4),'QQ',
& CMAX,MV(L,5),.FALSE.)
ENDIF
C WRITE(*,*)'mc=',MC
C--quark (parton b) momentum
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
IF((PTS.LT.0.d0).OR.((MB+MC).GT.P(L,5)))THEN
C WRITE(*,*)'reject mb and mc value'
COUNTER=COUNTER+1
C--discard events if no appropriate values can be found
IF(COUNTER.GT.5000)THEN
WRITE(*,*)'reject event in makesplitting'
WRITE(*,*)'l=',L
WRITE(*,*)'E=',P(L,4)
WRITE(*,*)'m=',P(L,5)
WRITE(*,*)'p=',P(L,3)
WRITE(*,*)'Qa=',P(K(L,3),5)
WRITE(*,*)'za=',ZA(L)
WRITE(*,*)'z=',Z
DISCARD=.TRUE.
GOTO 31
ELSE
GOTO 30
ENDIF
ENDIF
N=N+2
IF(N.GT.4990) THEN
WRITE(*,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
C--take care of first daughter (radiated gluon or antiquark)
K(N-1,1)=K(L,1)
IF(QQBAR)THEN
K(N-1,2)=-1
ELSE
K(N-1,2)=21
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
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
K(N,1)=K(L,1)
IF(QUARK)THEN
K(N,2)=K(L,2)
ELSEIF(QQBAR)THEN
K(N,2)=1
ELSE
K(N,2)=21
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
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
C MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2*(1./P(N-1,5)**2-1./CMAX1**2)
MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2/P(N-1,5)**2
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
C MV(N,5)=MV(L,5)+P(N,4)*0.2*(1./P(N,5)**2-1./BMAX1**2)
MV(N,5)=MV(L,5)+P(N,4)*0.2/P(N,5)**2
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.-Z
ZA(N)=Z
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
IF(BRICK)THEN
DELTAERAD=DELTAERAD+P(N-1,4)
DELTAERADTOT=DELTAERADTOT+P(N-1,4)
CALL HF1(333,REAL(P(N-1,4)),EVWEIGHT)
ELSE
IF(MV(L,5).LT.LTIME)THEN
R=PYR(0)
IF(R.LT.(FMED/(1.+FMED))) THEN
DELTAERAD=DELTAERAD+P(L,4)-P(N,4)
DELTAERADTOT=DELTAERADTOT+P(L,4)-P(N,4)
ENDIF
ENDIF
ENDIF
C 31 WRITE(*,*)'makesplitting: we are done, N=',N
C END
31 END
SUBROUTINE MAKEINSPLIT(L,X,T,TYPI,TIME)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--local variables
INTEGER L,TYPI,NOLD
DOUBLE PRECISION X,T,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
&PHIQ,PYP,PYR,R,TIME,MB2MAX
CHARACTER*2 TYP2,TYPC
DATA PI/3.141592653589793d0/
MV(L,5)=TIME
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 WRITE(*,*)'+++++++++++++++++++++++++++++++++++++++++++++++++++'
C CALL PYLIST(2)
C WRITE(*,*)'TYP2=',TYP2
C WRITE(*,*)'Mb2max=',MIN(SQRT(-T),X*P(L,4)),X,P(L,4),SQRT(-T)
MB2=GETMASS(QMIN,MIN(SQRT(-T),X*P(L,4)),1.d0,1.d0,P(L,4),TYP2,
& MIN(SQRT(-T),X*P(L,4)),TIME,.TRUE.)**2
C WRITE(*,*)'Mb^2=',MB2
MB2=P(L,5)**2-MB2
C WRITE(*,*)'Mb^2=',MB2
MC2=GETMASS(0.d0,MIN(SQRT(-T),(1.-X)*P(L,4)),1.d0,1.d0,
& (1.-X)*P(L,4),TYPC,MIN(SQRT(-T),(1.-X)*P(L,4)),
& TIME,.FALSE.)**2
C WRITE(*,*)'Mc^2=',MC2
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
C WRITE(*,*)'kt^2=',KT2
IF(KT2.LT.0.d0)THEN
MC2=0.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
C WRITE(*,*)'initial state splitting has to be rejected'
IF(KT2.LT.0.d0)THEN
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
RETURN
ENDIF
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
K(N-1,1)=K(L,1)
IF(TYP2.EQ.'QG')THEN
K(N-1,2)=-1
ELSE
K(N-1,2)=21
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)
IF(TYPI.NE.21)THEN
K(N,2)=K(L,2)
ELSEIF(TYP2.EQ.'QG')THEN
K(N,2)=1
ELSE
K(N,2)=21
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(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
C MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2*(1./P(N-1,5)**2-1./CMAX1**2)
MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2/P(N-1,5)**2
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
C MV(N,5)=MV(L,5)+P(N,4)*0.2*(1./P(N,5)**2-1./BMAX1**2)
MV(N,5)=MV(L,5)+P(N,4)*0.2/P(N,5)**2
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.d0
ZA(N)=1.d0
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
IF(BRICK)THEN
DELTAERAD=DELTAERAD+P(N-1,4)
DELTAERADTOT=DELTAERADTOT+P(N-1,4)
CALL HF1(333,REAL(P(N-1,4)),EVWEIGHT)
ELSE
IF(MV(L,5).LT.LTIME)THEN
R=PYR(0)
IF(R.LT.(FMED/(1.+FMED))) THEN
DELTAERAD=DELTAERAD+P(L,4)-P(N,4)
DELTAERADTOT=DELTAERADTOT+P(L,4)-P(N,4)
ENDIF
ENDIF
ENDIF
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)/P(L,4)
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/P(L,4)
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/P(L,4)
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/P(L,4)
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/P(L,4)
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/P(L,4)
C CALL PYLIST(2)
C WRITE(*,*)'+++++++++++++++++++++++++++++++++++++++++++++++++++'
END
DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER L
DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
&GETSUDAKOV,GETMASS
CHARACTER TYP1
CHARACTER*2 TYP
C WRITE(*,*)'---------------------------------------'
C WRITE(*,*)'get new mass for line ',L,' with Q^2=',Q2,' and Q_old^2=',QOLD2
IF(P(L,4).LT.QMIN)THEN
C WRITE(*,*)'not enough energy'
GETNEWMASS=0.d0
C WRITE(*,*)'---------------------------------------'
RETURN
ENDIF
IF (-Q2.LT.QMIN**2)THEN
C WRITE(*,*)'no phase space'
GETNEWMASS=0.d0
C WRITE(*,*)'---------------------------------------'
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
TYP='GC'
TYP1='G'
ELSE
TYP='QQ'
TYP1='Q'
ENDIF
IF(SQRT(-QOLD2).LE.QMIN)THEN
C WRITE(*,*)'first momentum transfer'
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),1.d0,1.d0,P(L,4),TYP,
& SQRT(-Q2),MV(L,4),.FALSE.)
RETURN
ENDIF
C IF(K(L,3).NE.0)THEN
C Z=ZA(L)
C QA=P(K(L,3),5)
C ELSE
Z=1.d0
QA=1.d0
C ENDIF
C WRITE(*,*)'z=',Z,' ; Qa=',QA
IF(P(L,5).GT.0.d0)THEN
C WRITE(*,*)'there is already radiation'
IF(-Q2.GT.-QOLD2)THEN
C WRITE(*,*)'increase phase space'
PNOSPLIT1=GETSUDAKOV(SQRT(-Q2),QA,SQRT(-QOLD2),Z,P(L,4),TYP,
& MV(L,4),.FALSE.)
C WRITE(*,*)'probability to keep radiation:',PNOSPLIT1
IF(PYR(0).LT.PNOSPLIT1)THEN
GETNEWMASS=P(L,5)
ELSE
GETNEWMASS=GETMASS(SQRT(-QOLD2),SQRT(-Q2),QA,Z,P(L,4),TYP,
& SQRT(-Q2),MV(L,4),.FALSE.)
ENDIF
ELSE
C WRITE(*,*)'decrease phase space'
PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,QMIN,Z,P(L,4),
& TYP,MV(L,4),.FALSE.)
C WRITE(*,*)'P_nosplit 1: ',PNOSPLIT1
PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,QMIN,Z,P(L,4),
& TYP,MV(L,4),.FALSE.)
C WRITE(*,*)'P_nosplit 2: ',PNOSPLIT2
C WRITE(*,*)'probability to keep radiation: ',(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
IF(PYR(0).LT.((1.-PNOSPLIT2)/(1.-PNOSPLIT1)))THEN
IF(P(L,5).LT.SQRT(-Q2))THEN
GETNEWMASS=P(L,5)
ELSE
GETNEWMASS=GETMASS(QMIN,SQRT(-Q2),QA,Z,P(L,4),TYP,
& SQRT(-Q2),MV(L,4),.FALSE.)
ENDIF
ELSE
GETNEWMASS=0.d0
ENDIF
ENDIF
ELSE
C WRITE(*,*)'there is no radiation'
IF(-Q2.GT.-QOLD2)THEN
C WRITE(*,*)'increase phase space'
PNOSPLIT1=GETSUDAKOV(SQRT(-Q2),QA,MAX(SQRT(-QOLD2),QMIN),
& Z,P(L,4),TYP,MV(L,4),.FALSE.)
IF(PYR(0).LT.PNOSPLIT1)THEN
GETNEWMASS=0.d0
ELSE
GETNEWMASS=GETMASS(MAX(SQRT(-QOLD2),QMIN),
& SQRT(-Q2),QA,Z,P(L,4),TYP,SQRT(-Q2),MV(L,4),.FALSE.)
ENDIF
ELSE
C WRITE(*,*)'decrease phase space'
GETNEWMASS=0.d0
ENDIF
ENDIF
GETNEWMASS=MIN(GETNEWMASS,P(L,4))
C WRITE(*,*)'---------------------------------------'
END
SUBROUTINE GETXANDT(LINE,X,TYPI,DT)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER LINE,TYPI
DOUBLE PRECISION GETSSCAT,GETXSECINT,UP,SIGMATOT,CCOL,LOW,PI,
&PNORAD,GETINSUDAFAST,X,PFCHANGE,PYR,R,FQMAX,FGMAX,XMAX,WEIGHT,
&GETPDF,TMAXNEW,SCATPRIMFUNC,GETPDFXINT,PQQ,PQG,PGG,PGQ,ALPHAS,
&DT,XSC,YSC,ZSC,TSC,GETMS,GETMD,GETNEFF
CHARACTER TYP1
CHARACTER*2 TYP2
DATA PI/3.141592653589793d0/
XSC=MV(LINE,1)+DT*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+DT*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+DT*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+DT
IF(GETNEFF(XSC,YSC,ZSC,TSC).LT.1.D-2)THEN
WRITE(*,*)'*** error: no medium at: ',XSC,YSC,ZSC,TSC,' ***'
END IF
UP=2.*GETMS(XSC,YSC,ZSC,TSC)*(P(LINE,4)-P(LINE,5))
LOW=MAX(Q0**2,P(LINE,5)**2)
NEND=NEND+1
IF(NSTART.EQ.0) NSTART=1
IF(K(LINE,2).EQ.21)THEN
TYP1='G'
TYP2='GC'
CCOL=3./2.
C--probability for no initial state radiation
IF((UP.LE.Q0**2).OR.(UP.LE.LOW))THEN
PNORAD=1.d0
ELSE
SIGMATOT=GETSSCAT(P(LINE,4),P(LINE,5),'G','C',
&GETMS(XSC,YSC,ZSC,TSC),GETMD(XSC,YSC,ZSC,TSC))
PNORAD = GETXSECINT(LOW,UP,'GB')/SIGMATOT
ENDIF
ELSE
TYP1='Q'
TYP2='QQ'
CCOL=2./3.
C--probability for no initial state radiation
IF(UP.LE.Q0**2)THEN
PNORAD=1.d0
ELSE
SIGMATOT=GETSSCAT(P(LINE,4),P(LINE,5),'Q','C',
&GETMS(XSC,YSC,ZSC,TSC),GETMD(XSC,YSC,ZSC,TSC))
PNORAD = GETXSECINT(LOW,UP,'QB')/SIGMATOT
ENDIF
ENDIF
C WRITE(*,*)'~~~GETXANDT for (l,E,m)',LINE,P(LINE,4),P(LINE,5)
C WRITE(*,*)'~~~P_norad=',PNORAD
C WRITE(*,*)'probability for no initial state radiation:',PNORAD
IF(PNORAD.GT.1.01d0) THEN
WRITE(*,*)'error: P_norad > 1',PNORAD
WRITE(*,*)'sigmatot',SIGMATOT
WRITE(*,*)'first, second term:',
& CCOL*(SCATPRIMFUNC(LOW,GETMD(XSC,YSC,ZSC,TSC))-
&SCATPRIMFUNC(P(LINE,5)**2,GETMD(XSC,YSC,ZSC,TSC))),
& GETXSECINT(LOW,UP,'GB')
WRITE(*,*)'mass,low,up,typ',P(LINE,5),LOW,UP,' ',TYP1
ENDIF
- IF(PYR(0).LT.PNORAD)THEN
+ IF((PYR(0).LT.PNORAD).OR.(P(LINE,4).LT.1.001*QMIN))THEN
C WRITE(*,*)'no radiation'
35 CALL GETQVEC(LINE,DT)
C WRITE(*,*)'t=',QSUM2
IF(-QSUM2.GT.LOW)THEN
IF(PYR(0).GT.GETINSUDAFAST(SQRT(LOW),SQRT(-QSUM2),TYP2))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
GOTO 35
ENDIF
ENDIF
X=1.d0
TYPI=K(LINE,2)
RETURN
ELSE
XMAX=1.-Q0**2/(4.*UP)
C WRITE(*,*)'xmax:',XMAX
IF(K(LINE,2).EQ.21)THEN
FQMAX=2.*LOG(UP/LOW)*ALPHAS(Q0**2/4.,LPS)*PQG(XMAX)/(2.*PI)
FGMAX=2.*LOG(UP/LOW)*ALPHAS(Q0**2/4.,LPS)*PGG(XMAX)/(2.*PI)
33 CALL GETQVEC(LINE,DT)
IF(ALLQS(NEND,1).EQ.0.d0)THEN
X=1.d0
RETURN
ENDIF
X=PYR(0)*(2.*XMAX-1.)+(1.-XMAX)
C WRITE(*,*)'x,t=',X,ALLQS(NEND,1)
WEIGHT=(2.*2.*GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'QG')/3.
& + 3.*GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'GG')/2.)
& / (2.*FQMAX/3.+3.*FGMAX/2.)
IF(WEIGHT.GT.1.d0)THEN
WRITE(*,*)'error: weight > 1',WEIGHT
WRITE(*,*)'fqmax,fgmax=',FQMAX,FGMAX
WRITE(*,*)'fq,fg=',GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'QG'),
& GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'GG')
WRITE(*,*)'low,up=',LOW,UP
WRITE(*,*)'x_max=',XMAX
WRITE(*,*)'x,sqrt(t),Q0/(2.sqrt(1-x))=',
& X,SQRT(-ALLQS(NEND,1)),Q0/(2.*SQRT(1.-X))
WRITE(*,*)'gluon'
ENDIF
C WRITE(*,*)'x, weight:',X,WEIGHT
IF(PYR(0).GT.WEIGHT) THEN
C WRITE(*,*)'get new values'
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
GOTO 33
ENDIF
PFCHANGE=GETSSCAT(P(LINE,4),P(LINE,5),'G','Q',
&GETMS(XSC,YSC,ZSC,TSC),GETMD(XSC,YSC,ZSC,TSC))
& /(SIGMATOT*(1.d0-PNORAD))
IF(PYR(0).LT.PFCHANGE)THEN
TYPI=INT(SIGN(2.d0,PYR(0)-0.5))
ELSE
TYPI=21
ENDIF
ELSE
FQMAX=LOG(UP/LOW)*ALPHAS(Q0**2/4.,LPS)*PQQ(XMAX)/(2.*PI)
FGMAX=LOG(UP/LOW)*ALPHAS(Q0**2/4.,LPS)*PQQ(XMAX)/(2.*PI)
34 CALL GETQVEC(LINE,DT)
IF(ALLQS(NEND,1).EQ.0.d0)THEN
X=1.d0
RETURN
ENDIF
X=PYR(0)*XMAX
C WRITE(*,*)'x,t=',X,ALLQS(NEND,1)
WEIGHT=(2.*GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'QQ')/3.
& + 3.*GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'GQ')/2.)
& / (2.*FQMAX/3.+3.*FGMAX/2.)
C IF(WEIGHT.GT.1.d0) WRITE(*,*)'error: weight > 1',WEIGHT
IF(WEIGHT.GT.1.d0)THEN
WRITE(*,*)'error: weight > 1',WEIGHT
WRITE(*,*)'fqmax,fgmax=',FQMAX,FGMAX
WRITE(*,*)'fq,fg=',GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'QQ'),
& GETPDF(X,SQRT(LOW),SQRT(-ALLQS(NEND,1)),'GQ')
WRITE(*,*)'low,up=',LOW,UP
WRITE(*,*)'x_max=',XMAX
WRITE(*,*)'x,sqrt(t),Q0/(2.sqrt(1-x))=',
& X,SQRT(-ALLQS(NEND,1)),Q0/(2.*SQRT(1.-X))
WRITE(*,*)'quark'
ENDIF
C WRITE(*,*)'weight:',WEIGHT
C WRITE(*,*)'x, weight:',X,WEIGHT
IF(PYR(0).GT.WEIGHT) 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
GOTO 34
ENDIF
PFCHANGE=GETSSCAT(P(LINE,4),P(LINE,5),'Q','G',
&GETMS(XSC,YSC,ZSC,TSC),GETMD(XSC,YSC,ZSC,TSC))
& /(SIGMATOT*(1.d0-PNORAD))
IF(PYR(0).LT.PFCHANGE)THEN
TYPI=21
ELSE
TYPI=K(LINE,2)
ENDIF
ENDIF
ENDIF
UP=2.*GETMS(XSC,YSC,ZSC,TSC)*(X*P(LINE,4)-P(LINE,5))
IF((-ALLQS(NEND,1).GT.UP).OR.(X*P(LINE,4).LT.Q0))THEN
C WRITE(*,*)'picked values kinemtaically not allowed:',ALLQS(NEND,1),UP1
ALLQS(NEND,1)=0.d0
NSTART=0
NEND=0
X=1.d0
ENDIF
END
SUBROUTINE GETQVEC(L,DT)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--local variables
INTEGER L
DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT
DOUBLE PRECISION R,PYR,PHI1,THETA1,
&NEWMOM(4),SHAT,T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,
&D3,ZETA3,PT2,PNORAD,GETINSUDAFAST,GETPDFXINT,GETMS
CHARACTER TYPS,TYPP
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA PI/3.141592653589793d0/
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
CALL HF2(202,REAL(XSC),REAL(YSC),EVWEIGHT)
CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
&K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5),
&GETMD(XSC,YSC,ZSC,TSC),GETTEMP(XSC,YSC,ZSC,TSC))
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'
K(1,1)=13
SCATCENTRES(NEND,1)=K(1,2)
SCATCENTRES(NEND,2)=P(1,1)
SCATCENTRES(NEND,3)=P(1,2)
SCATCENTRES(NEND,4)=P(1,3)
SCATCENTRES(NEND,5)=P(1,4)
SCATCENTRES(NEND,6)=P(1,5)
SCATCENTRES(NEND,7)=MV(1,1)
SCATCENTRES(NEND,8)=MV(1,2)
SCATCENTRES(NEND,9)=MV(1,3)
SCATCENTRES(NEND,10)=MV(1,4)
C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
203 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 CALL PYLIST(2)
C--pick a t from differential scattering cross section
SHAT=P(L,5)**2+P(1,5)**2+2.*P(L,4)*P(1,5)
C WRITE(*,*)'shat=',SHAT
MAXT=MIN(2.*GETMS(XSC,YSC,ZSC,TSC)*(P(L,4)-P(L,5)),
& 2.*P(1,5)*P(L,3)*(P(L,3)+P(L,4))/(P(L,3)+P(L,4)+P(1,5)))
MAXT=MIN(MAXT,P(L,4)**2)
C WRITE(*,*)'GETQVEC: tmax=',MAXT
T=-GETT(SHAT,MAX(P(L,5)**2,QMIN**2),MAXT,
&GETMD(XSC,YSC,ZSC,TSC))
C WRITE(*,*)'GETQVEC: t=',T
202 NEWMOM(4)=P(L,4)+T/(2.*GETMS(XSC,YSC,ZSC,TSC))
C WRITE(*,*)'GETQVEC: E=',NEWMOM(4)
NEWMOM(3)=(T-2.*P(L,5)**2+2.*P(L,4)*NEWMOM(4))/(2.*P(L,3))
C WRITE(*,*)'GETQVEC: p||=',NEWMOM(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
C WRITE(*,*)'GETQVEC: pt^2=',PT2
T=0.9*T
C WRITE(*,*)'GETQVEC: need new t=',T
GOTO 202
ENDIF
PT=SQRT(PT2)
C WRITE(*,*)'GETQVEC: pt^2=',NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
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 WRITE(*,*)'GETQVEC: q before boost=',P(1,1),P(1,2),P(1,3),P(1,5)
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))
C WRITE(*,*)'GETQVEC: q after boost=',P(1,1),P(1,2),P(1,3),P(1,5)
ALLQS(NEND,1)=T
ALLQS(NEND,2)=P(1,1)
ALLQS(NEND,3)=P(1,2)
ALLQS(NEND,4)=P(1,3)
ALLQS(NEND,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
C WRITE(*,*)'new t:',T
C WRITE(*,*)'Qsum^2:',QSUM2
END
***********************************************************************
*** subroutine makescattering
***********************************************************************
*** performs scattering of parton on line l of the event record
***********************************************************************
SUBROUTINE DOKINEMATICS(L,N1,N2,NEWM,RETRYSPLIT)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--local variables
INTEGER L,I,COUNTER,LINE,N1,N2,J
DOUBLE PRECISION PYR,PS,THETA1,PHI1,PI,BETA(3),THETA,PHI,PYP,PT2,
&PT,PHI2,SHAT,MAXT,GETT,D3,ZETA3,R,T,MINT,NEWMASS,GETMASS,
&ENEW,MAXMASS,NEWM,DELTAM,DM,TTOT,MMAX2,DMLEFT,M4MAX2,M4MAX,M4,
&EGUESS,GETTEMP,GETMS
CHARACTER*2 TYP
LOGICAL RETRYSPLIT
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA PI/3.141592653589793d0/
C WRITE(*,*)'---------------------------------------'
C WRITE(*,*)'DoKinematics for L=',L,' ,N1=',N1,' N2=',N2,' new m=',NEWM
C CALL PYLIST(2)
DELTAM=NEWM-P(L,5)
C WRITE(*,*)'Delta m: ',DELTAM
DMLEFT=DELTAM
TTOT=0.d0
DO 220 J=N1,N2
TTOT=TTOT+ALLQS(J,1)
220 CONTINUE
C WRITE(*,*)'t_tot: ',TTOT
LINE=L
DO 222 J=N1,N2
MV(L,5)=ALLQS(J,6)
COUNTER=0
C--projectile type
IF(K(LINE,2).EQ.21)THEN
TYP='GC'
ELSE
TYP='QQ'
ENDIF
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(TTOT.EQ.0.d0)THEN
DM=0.d0
ELSE
DM=DMLEFT*T/TTOT
ENDIF
C WRITE(*,*)'t: ',T
C WRITE(*,*)'t tot: ',TTOT
C WRITE(*,*)'delta m: ',DM
C DO 200 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 200 CONTINUE
C CALL PYLIST(3)
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(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)
C IF(L.GE.70)THEN
C DO 210 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 210 CONTINUE
C CALL PYLIST(3)
C ENDIF
ENEW=P(LINE,4)+T/(2.*P(1,5))
C WRITE(*,*)'E new=',ENEW
IF(ENEW.LT.P(LINE,5))THEN
C--jkl ??? consistent?
T=2.*GETMS(MV(1,1),MV(1,2),MV(1,3),MV(1,4))*
&(P(LINE,5)-P(LINE,4))
DM=0.d0
ENEW=P(LINE,5)
C WRITE(*,*)'E new=',ENEW
ENDIF
MMAX2=P(LINE,5)**2+(P(1,5)*(P(LINE,4)+P(1,5))*T+
& SQRT(P(1,5)**2*P(LINE,3)**2*T*(T-4.*P(1,5)**2)))/P(1,5)**2
C WRITE(*,*)'mmax2=',MMAX2
NEWMASS=MIN(P(LINE,5)+DM,ENEW,SQRT(MAX(MMAX2,0.d0)))
IF(NEWMASS.LT.QMIN) NEWMASS=0.d0
C WRITE(*,*)'new projectile mass=',NEWMASS
IF(P(LINE,5).LE.1.d-10)THEN
M4MAX2=-((2.*P(LINE,4)*P(1,5)-NEWMASS**2+T)
& *(2.*P(LINE,4)*T+P(1,5)*(-NEWMASS**2+T)))
& /(2.*P(LINE,4)*(NEWMASS**2-T))
ELSE
M4MAX2=(P(LINE,4)*P(1,5)*(P(LINE,5)**2-NEWMASS**2+T)
& +P(LINE,5)**2*(P(1,5)**2+T)
& + SQRT(P(1,5)**2*P(LINE,3)**2*(P(LINE,5)**4
& +(NEWMASS**2-T)**2
& -2.*P(LINE,5)**2*(NEWMASS**2+T))))/P(LINE,5)**2
ENDIF
M4MAX=MIN(SQRT(-T),SQRT(M4MAX2),P(LINE,4)+P(1,4)-NEWMASS)
C WRITE(*,*)'max m4=',M4MAX
EGUESS=MAX((P(LINE,4)+P(1,4)-NEWMASS+P(LINE,4)
& +P(1,4)-ENEW)/2.d0,M4MAX)
C WRITE(*,*)'energy=',EGUESS
IF(M4MAX.GT.QMIN)THEN
M4=GETMASS(0.d0,M4MAX,1.d0,1.d0,EGUESS,TYP,M4MAX,
& MV(LINE,4),.FALSE.)
ELSE
M4=0.d0
ENDIF
IF(M4.EQ.0.d0) M4=P(1,5)
M4=P(1,5)
C WRITE(*,*)'new scattering centre mass=',M4
N=N+2
IF(N.GT.4990)THEN
WRITE(*,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
C--calculate new momentum-vector
P(N,5)=NEWMASS
202 P(N,4)=P(LINE,4)+(P(1,5)**2-M4**2+T)/(2.*P(1,5))
P(N,3)=(T-P(LINE,5)**2
& -P(N,5)**2+2.*P(LINE,4)*P(N,4))/(2.*P(LINE,3))
IF(T.EQ.0.d0)THEN
PT2=0.d0
ELSE
PT2=P(N,4)**2-P(N,3)**2-P(N,5)**2
ENDIF
IF(DABS(PT2).LT.1e-10) PT2=0.d0
IF(PT2.LT.0.d0)THEN
C WRITE(*,*)'new mass kinematically not allowed'
C WRITE(*,*)'P(N,3)=',P(N,3)
C WRITE(*,*)'P(N,4)=',P(N,4)
C WRITE(*,*)'P(N,5)=',P(N,5)
C WRITE(*,*)'m4=',M4
C WRITE(*,*)'pt^2=',PT2
C WRITE(*,*)'t=',T
C WRITE(*,*)'tmax=',MIN(2.*P(1,5)*(P(LINE,4)-P(LINE,5)),
C & 2.*P(1,5)*P(LINE,3)*(P(LINE,3)+P(LINE,4))/(P(LINE,3)+P(LINE,4)+P(1,5)))
MAXT=MIN(2.*P(1,5)*(P(LINE,4)-P(LINE,5)),
& 2.*P(1,5)*P(LINE,3)*(P(LINE,3)+P(LINE,4))
& /(P(LINE,3)+P(LINE,4)+P(1,5)))
IF(-T.GT.MAXT) T=0.d0
IF(P(LINE,5).GE.0.d0) P(N,5)=P(LINE,5)
M4=P(1,5)
IF (P(LINE,5).LT.0.d0)THEN
RETRYSPLIT=.TRUE.
N=N-2
RETURN
ENDIF
GOTO 202
ENDIF
PT=SQRT(PT2)
PHI2=PYR(0)*2*PI
P(N,1)=PT*COS(PHI2)
P(N,2)=PT*SIN(PHI2)
ZA(N)=1.d0
C--outgoing projectile
K(N,1)=K(LINE,1)
K(N,2)=K(LINE,2)
K(N,3)=L
K(N,4)=0
K(N,5)=0
C--take care of incoming projectile
IF(K(LINE,1).EQ.1)THEN
K(LINE,1)=12
ELSE
K(LINE,1)=14
ENDIF
K(LINE,4)=N-1
K(LINE,5)=N
C--outgoing scattering centre
K(N-1,2)=K(1,2)
K(N-1,3)=0
K(N-1,4)=0
K(N-1,5)=0
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,5)=M4
P(N-1,4)=SQRT(P(N-1,1)**2+P(N-1,2)**2+P(N-1,3)**2+P(N-1,5)**2)
ZA(N-1)=1.d0
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))
IF(KEEPRECOIL)THEN
IF(SCATRECOIL.AND.(P(N-1,4).GT.1.5*3.*
&GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))))THEN
K(N-1,1)=2
ELSE
K(N-1,1)=3
ENDIF
ELSE
K(N-1,1)=11
ENDIF
IF(P(1,4).LT.10.d0) CALL HF1(301,REAL(P(N-1,4)),EVWEIGHT)
IF(PYP(1,10).LT.10.d0) CALL HF1(303,REAL(PYP(N-1,10)),EVWEIGHT)
CALL HF1(305,REAL(P(N-1,1)/PYP(N-1,8)),EVWEIGHT)
CALL HF1(307,REAL(ACOS(P(N-1,1)/PYP(N-1,8))),EVWEIGHT)
CALL HF2(800,REAL(PYP(N-1,10)),REAL(P(N-1,1)/PYP(N-1,8)),
& EVWEIGHT)
CALL HF2(801,REAL(P(N-1,4)),REAL(P(N-1,1)/PYP(N-1,8)),EVWEIGHT)
C--fill Delta E in histogram
CALL HF2(210,REAL(P(L,4)),REAL((P(LINE,4)-P(N,4))/P(LINE,4)),
& EVWEIGHT)
MV(N,4)=MV(L,5)
MV(N-1,4)=MV(L,5)
MV(N-1,5)=0.d0
IF(J.LT.N2)THEN
MV(N,5)=MV(N,4)
ELSE
MV(N,5)=0.d0
ENDIF
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)/P(L,4)
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/P(L,4)
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/P(L,4)
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/P(L,4)
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/P(L,4)
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/P(L,4)
NSCAT=NSCAT+EVWEIGHT
DELTAECOL=DELTAECOL+P(LINE,4)-P(N,4)
DELTAECOLTOT=DELTAECOLTOT+P(LINE,4)-P(N,4)
DMLEFT=DMLEFT-(NEWMASS-P(LINE,5))
TTOT=TTOT-ALLQS(J,1)
LINE=N
222 CONTINUE
C CALL PYLIST(2)
C WRITE(*,*)'---------------------------------------'
END
***********************************************************************
*** function getproba
***********************************************************************
*** returns value of P(Q_max,Q) for parton of type 'type',
*** virtuality 'qf', maximum virtuality 'qi' and energy 'ebb',
*** mother virtuality 'qaa' and energy fraction 'zaa' of
*** splitting parton (needed for angular ordering)
***********************************************************************
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
INTEGER COL,LINE
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
***********************************************************************
*** returns value of sudakov form factor for parton of type
*** 'type3', virtuality 'qb1', maximum virtuality 'qmax' and
*** energy 'eb1', mother virtuality 'qa1' and energy fraction
*** 'za1' of splitting parton (needed for angular ordering)
*** numerical integraltion of dQ'^2 integral, splitting integral
*** is done analytically, since alphas(Q'^2) is used
***********************************************************************
DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
& TYPE3,T2,INS)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
INTEGER NOK,NBAD
DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI,
&HFIRST,T2
CHARACTER*2 TYPE3
LOGICAL INS
DATA EPSI/1.d-4/
C DATA HFIRST/0.01d0/
C WRITE(*,*)'getsudakov: from',QB1,' to',QMAX1
IF(QB1.LT.Q0) WRITE(*,*) '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
GETSUDAKOV=1.d0
ELSE
QA=QA1
ZA2=ZA1
EB=EB1
TYP=TYPE3
T=T2
INSTATE=INS
HFIRST=0.01*(QMAX1-QB1)
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,NOK,NBAD,1)
C WRITE(*,*)'getsudakov: ystart=',YSTART
GETSUDAKOV=EXP(-YSTART)
ENDIF
END
DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB1,QMAX1,TYPE3)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
INTEGER NOK,NBAD
DOUBLE PRECISION QMAX1,QB1,ZA1,EA1,TMAX,YSTART,EPSI,
&HFIRST
CHARACTER*2 TYPE3
DATA EPSI/1.d-4/
C DATA HFIRST/0.01d0/
C WRITE(*,*)'getsudakov: from',QB1,' to',QMAX1
IF(QB1.LT.Q0) WRITE(*,*) '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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,NOK,NBAD,6)
C WRITE(*,*)'getinsudakov: ystart=',YSTART
GETINSUDAKOV=EXP(-YSTART)
ENDIF
C WRITE(*,*)'getinsudakov =',GETINSUDAKOV
END
***********************************************************************
*** function deriv
***********************************************************************
*** integrand (= splitting integral) in numerical integration of
*** Sudakov form factor; 't': integration variable, 'qa5':
*** mother virtuality, 'za5': energy fraction of splitting
*** parton, 'eb5': energy of splitting parton, 'type7': type of
*** splitting parton
***********************************************************************
DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION QLOW
C--local variables
INTEGER W4
DOUBLE PRECISION XVAL,GETSPLITI,GETSCATI,PI,ALPHAS,GETINSPLITI,
&GETINSUDAFAST,SCATPRIMFUNC,GETINSUDAKOV,GETPDF,PQQ,PQG,PGG,PGQ,
&GETMD,MDT,MEDDERIV
DATA PI/3.141592653589793d0/
IF(W4.GE.11.AND.W4.LE.14)THEN
MDT=GETMD(0.d0,0.d0,0.d0,0.d0)
ENDIF
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,T)/XVAL
ENDIF
C WRITE(*,*)'deriv=',DERIV
ELSEIF(W4.EQ.2)THEN
C--P(q->qg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD,LPS)*
& PQQ(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*
C & PQQ(XVAL)/(2.*PI)
ELSEIF(W4.EQ.3)THEN
C--P(g->gg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD,LPS)
& *PGG(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*PGG(XVAL)/(2.*PI)
C DERIV=0.d0
ELSEIF(W4.EQ.4)THEN
C--P(g->qq) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD,LPS)*
& PQG(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*PQG(XVAL)/(2.*PI)
C DERIV=0.d0
ELSEIF(W4.EQ.5)THEN
DERIV=EXP(-XVAL)/XVAL
ELSEIF(W4.EQ.6)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
C WRITE(*,*)'deriv=',DERIV
ELSEIF(W4.EQ.7)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PQQ(Z)/(2.*PI*XVAL)
C WRITE(*,*)'x,Q1,Q2,deriv=',Z,XVAL,XMAX,DERIV
C WRITE(*,*)'alphas,arg,sudakov=',ALPHAS((1.-Z)*XVAL**2,LPS),
C & (1.-Z)*XVAL**2,GETINSUDAFAST(XVAL,XMAX,'QQ')
ELSEIF(W4.EQ.8)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PGQ(Z)/(2.*PI*XVAL)
C WRITE(*,*)'x,Q1,Q2,deriv=',Z,XVAL,XMAX,DERIV
C WRITE(*,*)'alphas,sudakov,Pqq=',ALPHAS((1.-Z)*XVAL**2,LPS),
C & GETINSUDAFAST(XVAL,XMAX,'GC'),PQQ(Z)
ELSEIF(W4.EQ.9)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PQG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.10)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2,LPS)*
& *2.*PGG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.11)THEN
C WRITE(*,*)'deriv:',XVAL
DERIV=3.*GETINSPLITI(SQRT(XVAL),'GQ')*SCATPRIMFUNC(XVAL,MDT)
& /(2.*XVAL)
C WRITE(*,*)'deriv=',DERIV,SQRT(XVAL)
ELSEIF(W4.EQ.12)THEN
C WRITE(*,*)'deriv:',XVAL
DERIV=2.*GETINSPLITI(SQRT(XVAL),'QG')*SCATPRIMFUNC(XVAL,MDT)
& /(3.*XVAL)
C WRITE(*,*)'deriv=',DERIV,SQRT(XVAL)
ELSEIF(W4.EQ.13)THEN
DERIV=GETINSUDAFAST(QLOW,SQRT(XVAL),'GC')
& *3.*2.*PI*ALPHAS(XVAL+MDT**2,LQCD)**2/(2.*(XVAL+MDT**2)**2)
ELSEIF(W4.EQ.14)THEN
DERIV=GETINSUDAFAST(QLOW,SQRT(XVAL),'QQ')
& *2.*2.*PI*ALPHAS(XVAL+MDT**2,LQCD)**2/(3.*(XVAL+MDT**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
C WRITE(*,*)'x, deriv=',XVAL,DERIV
ELSE
DERIV=MEDDERIV(XVAL,W4-100)
ENDIF
C WRITE(*,*)'deriv=',DERIV
END
***********************************************************************
*** function getspliti
***********************************************************************
*** returns splitting integral for parton of type 'type1',
*** virtuality 'qb', energy 'eb', energy fraction 'zeta' and mother
*** virtuality 'qa'
***********************************************************************
DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1,T3)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
INTEGER I,J,TMAXLINE,TLINE,LTMAX,LT,QLMAX,ZLMAX,QLINE,ZLINE
DOUBLE PRECISION QA,QB,ZETA,EB,LOW,ALPHAS,PI,X1A(4),T3,
&X2A(4),YA(4,4),Y,DY,SPLITINTGG,SPLITINTQG,
&INTPQQ,INTPGGLOW,INTPGGHIGH,INTPQGLOW,INTPQGHIGH,ARG,
&GETMS,GETTEMP
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
IF(CONSTR)THEN
LOW=MAX(0.5-0.5*SQRT(1.-QMIN**2/QB**2)
& *SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)),
& MINEN*Q0/EB)
ELSE
LOW=MAX(0.5-0.5*SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)),
& MINEN*Q0/EB)
LOW=MIN(LOW,0.5)
ENDIF
ELSE
IF(CONSTR)THEN
LOW=MAX(0.5-0.5*SQRT(1.-QMIN**2/QB**2)
& *SQRT(1.-QB**2/EB**2),MINEN*Q0/EB)
ELSE
LOW=MAX(0.5-0.5*SQRT(1.-QB**2/EB**2),MINEN*Q0/EB)
LOW=MIN(LOW,0.5)
ENDIF
ENDIF
C WRITE(*,*)'getspliti: low',LOW
C WRITE(*,*)'getspliti: Qb=',QB,' ; Eb=',EB,' ; Qmin=',QMIN
C--if production time is during plasma lifetime use medium enhanced splitting
C function, otherwise use the vacuum function
IF(EXACT)THEN
IF(GETTEMP(0.d0,0.d0,0.d0,T3).GE.0.1d0)THEN
C--find values in array
QLMAX=INT((QB-Q0)*NPOINT/(QMAX-Q0))
QLINE=MAX(QLMAX-1,1)
QLINE=MIN(QLINE,NPOINT-3)
ZLMAX=INT((LOG(LOW)-LOG(ZMMIN))*NPOINT/(LOG(0.5)-LOG(ZMMIN)))
ZLINE=MAX(ZLMAX-1,1)
ZLINE=MIN(ZLINE,NPOINT-3)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 11 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 10 J=1,4
YA(I,J)=SPLITIGGM(QLINE-1+I,ZLINE-1+J)
10 CONTINUE
11 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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 13 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 12 J=1,4
YA(I,J)=SPLITIQGM(QLINE-1+I,ZLINE-1+J)
12 CONTINUE
13 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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 15 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 14 J=1,4
YA(I,J)=SPLITIQQM(QLINE-1+I,ZLINE-1+J)
14 CONTINUE
15 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ELSE
C--find values in array
QLMAX=INT((QB-Q0)*NPOINT/(QMAX-Q0))
QLINE=MAX(QLMAX-1,1)
QLINE=MIN(QLINE,NPOINT-3)
ZLMAX=INT((LOG(LOW)-LOG(ZMMIN))*NPOINT/(LOG(0.5)-LOG(ZMMIN)))
ZLINE=MAX(ZLMAX-1,1)
ZLINE=MIN(ZLINE,NPOINT-3)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 17 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 16 J=1,4
YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
16 CONTINUE
17 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 18 J=1,4
YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
18 CONTINUE
19 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 20 J=1,4
YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
20 CONTINUE
21 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ENDIF
ELSE
IF(GETTEMP(0.D0,0.D0,0.D0,T3).GE.0.1D0)THEN
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=(1.+FMED)*(INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB))
ELSE
SPLITINTGG=(1.+FMED)*(INTPGGLOW(0.5d0,QB)
& - INTPGGLOW(LOW,QB) + INTPGGHIGH(1.-LOW,QB)
& - INTPGGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=(1.+FMED)*NF*(INTPQGLOW(0.5d0,QB)
& - INTPQGLOW(LOW,QB) + INTPQGHIGH(1.-LOW,QB)
& - INTPQGHIGH(0.5d0,QB))
ELSE
SPLITINTQG=(1.+FMED)*NF*(INTPQGLOW(0.5d0,QB)
& -INTPQGLOW(LOW,QB)+INTPQGHIGH(1.-LOW,QB)
& -INTPQGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
GETSPLITI=(1.+FMED)*(INTPQQ(1.d0-LOW,QB) - INTPQQ(LOW,QB))
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ELSE
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB)
ELSE
SPLITINTGG=INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB)
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=NF*(INTPQGLOW(0.5d0,QB) - INTPQGLOW(LOW,QB)
& + INTPQGHIGH(1.-LOW,QB) - INTPQGHIGH(0.5d0,QB))
ELSE
SPLITINTQG=NF*(INTPQGLOW(0.5d0,QB) - INTPQGLOW(LOW,QB)
& + INTPQGHIGH(1.-LOW,QB) - INTPQGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
GETSPLITI=INTPQQ(1.d0-LOW,QB) - INTPQQ(LOW,QB)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ENDIF
ENDIF
C WRITE(*,*)'getspliti=',GETSPLITI
END
DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
C--local variables
DOUBLE PRECISION QB,EA,LOW,ALPHAS,PI,
&Y,SPLITINTGG,SPLITINTQG,UP,EI
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
C WRITE(*,*)'getinspliti for Q, type = ',QB,' ',TYPE1
UP = 1. - Q0**2/(4.*QB**2)
C WRITE(*,*)'getinspliti: up',UP
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
LOW=Q0**2/(4.*QB**2)
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=Q0**2/(4.*QB**2)
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))
C Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
C & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
C & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
C & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
C & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
C & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
C & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
C WRITE(*,*)'getinspliti=',GETINSPLITI
END
DOUBLE PRECISION FUNCTION GETPDF(X,Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER XBIN,QBIN1,QBIN2,I,XCLOSE,QLBIN,QRBIN,J
DOUBLE PRECISION X,Q1,Q2,GETINSUDAFAST,DELTAQ,SFAC1,
&SFAC2,DELTAX,QLOW,QHIGH,XA(4),YA(4),Y,DY,GETPDFEXACT
CHARACTER*2 TYP
IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q1.LT.Q0).OR.(Q2.LT.Q0))THEN
WRITE(*,*)'error in GETPDF: parameter out of bound',X,Q1,Q2
GETPDF=0.d0
RETURN
ENDIF
GETPDF=GETPDFEXACT(X,Q1,Q2,TYP)
RETURN
DELTAX=QINQ(2,101)-QINQ(1,101)
XCLOSE=INT(X/DELTAX+1)
XBIN=MAX(XCLOSE-1,1)
XBIN=MIN(XBIN,100-3)
QLBIN=INT((LOG(Q1**2)-LOG(QINQ(101,1)))*100.d0/
& (LOG(QINQ(101,100))-LOG(QINQ(101,1)))+1)
QRBIN=INT((LOG(Q2**2)-LOG(QINQ(101,1)))*100.d0/
& (LOG(QINQ(101,100))-LOG(QINQ(101,1)))+1)
IF(QINQ(101,QLBIN).GT.Q1**2) QLBIN=QLBIN-1
IF(QINQ(101,QRBIN).GT.Q2**2) QRBIN=QRBIN-1
IF(QINQ(101,QLBIN+1).LT.Q1**2) QLBIN=QLBIN+1
IF(QINQ(101,QRBIN+1).LT.Q2**2) QRBIN=QRBIN+1
IF(((QRBIN-QLBIN).LE.1).OR.(Q2**2.GT.QINQ(101,100)))THEN
GETPDF=GETPDFEXACT(X,Q1,Q2,TYP)
RETURN
ENDIF
DO 23 I=1,4
XA(I)=QINQ(XBIN-1+I,101)
IF(TYP.EQ.'QQ')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *QINQ(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 24 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'QQ')
& *QINQ(XBIN-1+I,J)
24 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GINQ(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 25 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'GC')
& *GINQ(XBIN-1+I,J)
25 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *QING(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 26 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'QQ')
& *QING(XBIN-1+I,J)
26 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GING(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 27 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'GC')
& *GING(XBIN-1+I,J)
27 CONTINUE
ELSE
WRITE(*,*)'error: pdf-type ',TYP,' does not exist'
GETPDF=0.d0
RETURN
ENDIF
23 CONTINUE
CALL POLINT(XA,YA,4,X,Y,DY)
GETPDF=Y
END
DOUBLE PRECISION FUNCTION GETPDFEXACT(X,Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,Q1,Q2,GETINSUDAFAST,DELTAQ,SFAC1,
&SFAC2,DELTAX,QLOW,QHIGH,YSTART,EPSI,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
IF(TYP.EQ.'QQ')THEN
Z=X
XMAX=Q2
C--f_q^q
QLOW=MAX(Q1,Q0/(2.*SQRT(1.-X)))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,7)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'GQ')THEN
Z=X
XMAX=Q2
C--f_q^g
QLOW=MAX(Q1,MAX(Q0/(2.*SQRT(1.-X)),Q0/(2.*SQRT(X))))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,8)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'QG')THEN
Z=X
XMAX=Q2
C--f_q^g
QLOW=MAX(Q1,Q0/(2.*SQRT(1.-X)))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,9)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'GG')THEN
Z=X
XMAX=Q2
C--f_q^q
QLOW=MAX(Q1,MAX(Q0/(2.*SQRT(1.-X)),Q0/(2.*SQRT(X))))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,10)
ENDIF
GETPDFEXACT=YSTART
ELSE
WRITE(*,*)'error: pdf-type ',TYP,' does not exist'
GETPDFEXACT=0.d0
ENDIF
END
DOUBLE PRECISION FUNCTION GETPDFXINT(Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--local variables
INTEGER I,J,Q1CLOSE,Q2CLOSE,Q1LINE,Q2LINE
DOUBLE PRECISION Q1,Q2,X1A(4),X2A(4),YA(4,4),Y,DY,
&GETPDFXINTEXACT
CHARACTER*2 TYP
Q1CLOSE=INT((LOG(Q1**2)-LOG(QINQX(1,101)))*99/
& (LOG(QINQX(100,101))-LOG(QINQX(1,101)))+1)
Q1LINE=MAX(Q1CLOSE-1,1)
Q1LINE=MIN(Q1LINE,100-3)
Q2CLOSE=INT((LOG(Q2**2)-LOG(QINQX(101,1)))*99/
& (LOG(QINQX(101,100))-LOG(QINQX(101,1)))+1)
Q2LINE=MAX(Q2CLOSE-1,1)
Q2LINE=MIN(Q2LINE,100-3)
IF(TYP.EQ.'QQ')THEN
DO 12 I=1,4
X1A(I)=QINQX(Q1LINE-1+I,101)
X2A(I)=QINQX(101,Q2LINE-1+I)
DO 11 J=1,4
YA(I,J)=QINQX(Q1LINE-1+I,Q2LINE-1+J)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
DO 14 I=1,4
X1A(I)=GINQX(Q1LINE-1+I,101)
X2A(I)=GINQX(101,Q2LINE-1+I)
DO 13 J=1,4
YA(I,J)=GINQX(Q1LINE-1+I,Q2LINE-1+J)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
DO 16 I=1,4
X1A(I)=QINGX(Q1LINE-1+I,101)
X2A(I)=QINGX(101,Q2LINE-1+I)
DO 15 J=1,4
YA(I,J)=QINGX(Q1LINE-1+I,Q2LINE-1+J)
15 CONTINUE
16 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
DO 18 I=1,4
X1A(I)=GINGX(Q1LINE-1+I,101)
X2A(I)=GINGX(101,Q2LINE-1+I)
DO 17 J=1,4
YA(I,J)=GINGX(Q1LINE-1+I,Q2LINE-1+J)
17 CONTINUE
18 CONTINUE
ELSE
WRITE(*,*)'error in GETPDFXINT: unknown integral type ',TYP
ENDIF
CALL POLINT2(X1A,X2A,YA,4,4,Q1**2,Q2**2,Y,DY)
GETPDFXINT=Y
C WRITE(*,*)'GETPDFXINT for',Q1,Q2,'interpolation/exact:',
C &Y/GETPDFXINT,TYP
END
DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q1,Q2,TYP)
IMPLICIT NONE
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,Q1,Q2,EPSI,YSTART,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
HFIRST=0.01d0
YSTART=0.d0
NOK=0
NBAD=0
XMAX=Q2
Z=0.d0
IF(TYP.EQ.'QQ')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,21)
ELSEIF(TYP.EQ.'QG')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,22)
ELSEIF(TYP.EQ.'GQ')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,23)
ELSEIF(TYP.EQ.'GG')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,24)
ENDIF
GETPDFXINTEXACT=YSTART
END
DOUBLE PRECISION FUNCTION GETXSECINT(Q2,TM,TYP2)
IMPLICIT NONE
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--local variables
INTEGER QLINE,QCLOSE,TLINE,TCLOSE,I,J
DOUBLE PRECISION Q2,TM,X1A(4),X2A(4),YA(4,4),Y,DY
CHARACTER*2 TYP2
QCLOSE=INT((LOG(Q2)-LOG(INTQ1(1,101)))*99/
& (LOG(INTQ1(100,101))-LOG(INTQ1(1,101)))+1)
QLINE=MAX(QCLOSE-1,1)
QLINE=MIN(QLINE,100-3)
TCLOSE=INT((LOG(TM)-LOG(INTQ1(101,1)))*99/
& (LOG(INTQ1(101,100))-LOG(INTQ1(101,1)))+1)
TLINE=MAX(TCLOSE-1,1)
TLINE=MIN(TLINE,100-3)
IF(TYP2.EQ.'QA')THEN
DO 12 I=1,4
X1A(I)=INTQ1(QLINE-1+I,101)
X2A(I)=INTQ1(101,TLINE-1+I)
DO 11 J=1,4
YA(I,J)=INTQ1(QLINE-1+I,TLINE-1+J)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP2.EQ.'QB')THEN
DO 18 I=1,4
X1A(I)=INTQ2(QLINE-1+I,101)
X2A(I)=INTQ2(101,TLINE-1+I)
DO 17 J=1,4
YA(I,J)=INTQ2(QLINE-1+I,TLINE-1+J)
17 CONTINUE
18 CONTINUE
ELSEIF(TYP2.EQ.'GA')THEN
DO 14 I=1,4
X1A(I)=INTG1(QLINE-1+I,101)
X2A(I)=INTG1(101,TLINE-1+I)
DO 13 J=1,4
YA(I,J)=INTG1(QLINE-1+I,TLINE-1+J)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP2.EQ.'GB')THEN
DO 16 I=1,4
X1A(I)=INTG2(QLINE-1+I,101)
X2A(I)=INTG2(101,TLINE-1+I)
DO 15 J=1,4
YA(I,J)=INTG2(QLINE-1+I,TLINE-1+J)
15 CONTINUE
16 CONTINUE
ELSE
WRITE(*,*)'error in GETXSECINT: unknown integral type ',TYP2
ENDIF
CALL POLINT2(X1A,X2A,YA,4,4,Q2,TM,Y,DY)
GETXSECINT=Y
END
DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Q1,Q2,GETINSUDARED
CHARACTER*2 TYP
IF(Q2.LE.Q1)THEN
GETINSUDAFAST=1.d0
ELSEIF(Q1.EQ.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.0.d0) WRITE(*,*)'ERROR: GETINSUDAFAST < 0:',
&GETINSUDAFAST,'for',Q1,Q2,TYP
END
DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
IMPLICIT NONE
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2),
&SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--local variables
INTEGER QCLOSE,QBIN,I
DOUBLE PRECISION Q,XA(4),YA(4),Y,DY
CHARACTER*2 TYP2
QCLOSE=INT((Q-SUDAQQ(1,1))*100/(SUDAQQ(100,1)-SUDAQQ(1,1))+1)+1
QBIN=MAX(QCLOSE-1,1)
QBIN=MIN(QBIN,100-3)
C WRITE(*,*)'getinsudared: Q,Qbin=',Q,QBIN
IF(TYP2.EQ.'QQ')THEN
DO 16 I=1,4
XA(I)=SUDAQQ(QBIN-1+I,1)
YA(I)=SUDAQQ(QBIN-1+I,2)
16 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'QG')THEN
DO 17 I=1,4
XA(I)=SUDAQG(QBIN-1+I,1)
YA(I)=SUDAQG(QBIN-1+I,2)
17 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'GG')THEN
DO 18 I=1,4
XA(I)=SUDAGG(QBIN-1+I,1)
YA(I)=SUDAGG(QBIN-1+I,2)
18 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'GC')THEN
DO 19 I=1,4
XA(I)=SUDAGC(QBIN-1+I,1)
YA(I)=SUDAGC(QBIN-1+I,2)
19 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSE
WRITE(*,*)'error in GETINSUDARED: unknown type ',TYP2
ENDIF
END
***********************************************************************
*** function getsscat
***********************************************************************
*** returns the integrated scattering cross section for a parton
*** of type 'type1' and energy 'en'
***********************************************************************
DOUBLE PRECISION FUNCTION GETSSCAT(EN,MP,TYPE1,TYPE2,MS1,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--variables for cross section integration
COMMON/XSECV/QLOW
DOUBLE PRECISION QLOW
C--local variables
INTEGER NOK,NBAD
DOUBLE PRECISION UP,EN,SCATPRIMFUNC,CCOL,T3,NTAU,MP,
&LOW,GETPDFXINT,GETXSECINT,MS1,MDEB
CHARACTER TYPE1,TYPE2
IF(TYPE1.EQ.'Q')THEN
CCOL=2./3.
ELSE
CCOL=3./2.
ENDIF
UP=2.*EN*MS1-2.*MS1*MP
LOW=MAX(Q0**2,MP**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))
ELSE
GETSSCAT=0.d0
ENDIF
C WRITE(*,*)'sigma=',GETSSCAT
LOW=MAX(Q0**2,MP**2)
IF(UP.GT.LOW)THEN
IF(TYPE1.EQ.'Q')THEN
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+GETPDFXINT(SQRT(LOW),SQRT(UP),'GQ')
& *3.*SCATPRIMFUNC(UP,MDEB)/2.
GETSSCAT=GETSSCAT-GETXSECINT(LOW,UP,'QA')
ENDIF
ELSE
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
&SCATPRIMFUNC(LOW,MDEB))
& - GETXSECINT(LOW,UP,'GB')
C WRITE(*,*)'get gluon cross section: first and second term:',
C &CCOL*(SCATPRIMFUNC(UP)-SCATPRIMFUNC(LOW)),
C &GETXSECINT(LOW,UP,'GB'),LOW,UP
ENDIF
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
- GETSSCAT=GETSSCAT+2.*GETPDFXINT(SQRT(LOW),SQRT(UP),'QG')
+ GETSSCAT=GETSSCAT+GETPDFXINT(SQRT(LOW),SQRT(UP),'QG')
& *2.*SCATPRIMFUNC(UP,MDEB)/3.
GETSSCAT=GETSSCAT-2.*GETXSECINT(LOW,UP,'GA')
ENDIF
C WRITE(*,*)'ystart,mp^2,up=',YSTART,LOW,UP
C WRITE(*,*)'sigma=',GETSSCAT
C WRITE(*,*)
ENDIF
ENDIF
END
***********************************************************************
*** function getnoscat
***********************************************************************
*** returns the probability for no scattering of a parton of
*** type 'type2', energy 'ep' and velocity 'beta' between times
*** 'ti' and 'ti'+'dti' (the finite plasma lifetime is taken
*** into account)
***********************************************************************
DOUBLE PRECISION FUNCTION GETNOSCAT(EP,MP1,TI,DTI,TYPE2,BETA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION EP,TI,DTI,GETSSCAT,BETA,MP1
CHARACTER TYPE2
C--no scattering if the parton is produced after the end of the QGP
C lifetime
IF((TI.GE.LTIME).OR.(TEMP.EQ.0.d0))THEN
GETNOSCAT=1.d0
GOTO 40
ENDIF
C--end of QGP lifetime may be reached during parton lifetime
IF((TI+DTI).GE.LTIME) DTI=LTIME-TI
C--get no-scattering probility
GETNOSCAT=EXP(-GETSSCAT(EP,MP1,TYPE2,'C',MS,MD)*NP*DTI*5.*BETA)
40 END
***********************************************************************
*** function getdeltal
***********************************************************************
*** generates a delta t after which a scattering of a parton of
*** type 'type3', energy 'e1' and velocity 'bet1' takes place,
*** starting time is 't1' and the maximum delta t is 'dlmax'
***********************************************************************
DOUBLE PRECISION FUNCTION GETDELTAL(E1,MAS1,T1,DLMAX,TYPE3,BET1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION E1,MAS1,T1,DLMAX,BET1,LAMBDA,GETSSCAT,R1,PYR
CHARACTER TYPE3
LAMBDA=1.d0/(NP*GETSSCAT(E1,MAS1,TYPE3,'C',MS,MD)*5.d0*BET1)
C--end of QGP lifetime may be reached during parton lifetime
IF((T1+DLMAX).GE.LTIME) DLMAX=LTIME-T1
R1=PYR(0)
GETDELTAL=-LAMBDA*LOG(1.+R1*(EXP(-DLMAX/LAMBDA)-1.))
END
DOUBLE PRECISION FUNCTION GETMOMOLD(TYPE4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER I,NINTV2
DOUBLE PRECISION X(1000),Y(1000),DLMIN,FACTOR2,
&A(1000),B(1000),INTTMP,INTE(1000),PYR,R1,R2,R3,AA,BB,X1,X2,
&CAND1,CAND2,CAND,YY,GETNOSCAT,GETSSCAT,BET1,DLMAX,Y1,Y2
CHARACTER TYPE4
DATA DLMIN/0.d0/
NINTV2=10
FACTOR2=1.5d0
DLMAX=10.*TEMP
DO 45 I=0,NINTV2
X(I+1)=I*(DLMAX-DLMIN)/(NINTV2*1.d0)+DLMIN
IF(TYPE4.EQ.'Q')THEN
Y(I+1)=1./(EXP(SQRT(X(I+1)**2+MS**2)/TEMP)+1)
ELSE
Y(I+1)=1./(EXP(SQRT(X(I+1)**2+MS**2)/TEMP)-1)
ENDIF
45 CONTINUE
C PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 46 I=1,NINTV2
A(I)=(Y(I+1)-Y(I))/(X(I+1)-X(I))
B(I)=Y(I)-A(I)*X(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(X(I+1)**2-X(I)**2)/2.+B(I)*(X(I+1)-X(I))
46 CONTINUE
49 R1=PYR(0)
DO 47 I=1,NINTV2
IF(R1.LT.INTE(I)/INTE(NINTV2))THEN
X1=X(I)
X2=X(I+1)
AA=A(I)
BB=B(I)
GOTO 48
ENDIF
47 CONTINUE
48 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+X1**2+R2*(X2**2-X1**2)
& +2.*BB*(X1+R2*(X2-X1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+X1**2+R2*(X2**2-X1**2)
& +2.*BB*(X1+R2*(X2-X1))/AA)
IF((CAND1.GT.X1).AND.(CAND1.LT.X2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
IF(TYPE4.EQ.'Q')THEN
YY=1./(EXP(SQRT(CAND**2+MS**2)/TEMP)+1)/(AA*CAND+BB)
ELSE
YY=1./(EXP(SQRT(CAND**2+MS**2)/TEMP)-1)/(AA*CAND+BB)
ENDIF
C IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
C IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R3=PYR(0)
IF(R3.GT.YY)THEN
GOTO 49
ELSE
GETMOMOLD=CAND
ENDIF
END
***********************************************************************
*** function getmass
***********************************************************************
*** picks a virtuality for a parton of type 'type' with energy
*** 'ep', maximum virtuality 'qbmax', mother virtuality 'qm'
*** and energy fraction 'zm' of splitting parton
*** returns 0.d0 for masses below cut-off Q0
***********************************************************************
DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,QM,ZM,EP,TYPE,
& MAX2,TIME,INS)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--technical variables for getmass
COMMON/VIOL/FACTOR,NINTV,NVIOLQ,NVSEVQ,NVIOLG,NVSEVG,NEWMC
INTEGER NINTV,NVIOLQ,NVIOLG,NVSEVQ,NVSEVG
DOUBLE PRECISION FACTOR
LOGICAL NEWMC
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
INTEGER I
DOUBLE PRECISION QBMAX,R1,R2,PYR,CAND,Y,GETSUDAKOV,AA,BB,
&CC,DD,EP,PI,GETPROBA,GETSPLITI,MAXY,MIN2,MAX2,A(101),
&B(101),QM,ZM,MIN3,MAX3,QHELP,ALPHAS,INTE(101),R3,PQ(101),
&Q(101),Q1,Q2,INTTMP,CAND1,CAND2,MASS,TIME,PQ1,PQ2,QBMIN,
&GETMASSVETO,GETMASSVETOIN
CHARACTER*2 TYPE
LOGICAL INS
IF(.NOT.NEWMC)THEN
DATA AA/5.d0/
DATA BB/0.1d0/
DATA CC/25.d0/
DATA DD/0.1d0/
ENDIF
IF(VETO)THEN
IF(INS)THEN
GETMASS=GETMASSVETOIN(QBMIN,QBMAX,QM,ZM,EP,TYPE,MAX2,TIME)
ELSE
GETMASS=GETMASSVETO(QBMIN,QBMAX,QM,ZM,EP,TYPE,MAX2,TIME)
ENDIF
RETURN
ENDIF
MIN3=MAX(QMIN,QBMIN)
MAX3=MIN(QBMAX,MAX2)
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.MIN3) THEN
GETMASS=0.d0
RETURN
ENDIF
C--probability to go to Q_0
IF(QBMIN.EQ.0.d0)THEN
R1=PYR(0)
IF(R1.LT.GETSUDAKOV(MAX3,QM,MIN3,ZM,EP,TYPE,TIME,INS))THEN
GETMASS=0.d0
RETURN
ENDIF
ENDIF
C--vacuum calculations
43 IF((TYPE.EQ.'QQ').OR.(TYPE.EQ.'GQ'))THEN
IF(NEWMC)THEN
C--generate value from P(t_max,t) for quark with importance sampling
DO 45 I=0,NINTV
Q(I+1)=I*(MAX3-MIN3)/(NINTV*1.d0)+MIN3
PQ(I+1)=FACTOR*GETPROBA(MAX3,Q(I+1),QM,ZM,EP,TYPE,TIME,INS)
45 CONTINUE
PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 46 I=1,NINTV
A(I)=(PQ(I+1)-PQ(I))/(Q(I+1)-Q(I))
B(I)=PQ(I)-A(I)*Q(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(Q(I+1)**2-Q(I)**2)/2.
& +B(I)*(Q(I+1)-Q(I))
46 CONTINUE
49 R1=PYR(0)
DO 47 I=1,NINTV
IF(R1.LT.INTE(I)/INTE(NINTV))THEN
Q1=Q(I)
Q2=Q(I+1)
AA=A(I)
BB=B(I)
GOTO 48
ENDIF
47 CONTINUE
48 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
IF((CAND1.GT.Q1).AND.(CAND1.LT.Q2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)/(AA*CAND+BB)
IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R3=PYR(0)
IF(R3.GT.Y)THEN
GOTO 49
ELSE
MASS=CAND
ENDIF
ELSE
C--generate value from P(t_max,t) for quark with importance sampling
C (f(x)=a/(x+b))
40 R1=PYR(0)
CAND=(MIN3+BB)**(1-R1)*(MAX3+BB)**R1-BB
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& *(CAND+BB)/AA
IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R2=PYR(0)
IF(R2.GT.Y)THEN
GOTO 40
ELSE
MASS=CAND
ENDIF
ENDIF
ELSE
IF(NEWMC)THEN
C--generate value from P(Q_max,Q) for gluon with importance sampling
DO 55 I=0,NINTV
Q(I+1)=I*(MAX3-MIN3)/(NINTV*1.d0)+MIN3
PQ(I+1)=FACTOR*GETPROBA(MAX3,Q(I+1),QM,ZM,EP,TYPE,
& TIME,INS)
55 CONTINUE
PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 56 I=1,NINTV
A(I)=(PQ(I+1)-PQ(I))/(Q(I+1)-Q(I))
B(I)=PQ(I)-A(I)*Q(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(Q(I+1)**2-Q(I)**2)/2.
& +B(I)*(Q(I+1)-Q(I))
56 CONTINUE
59 R1=PYR(0)
DO 57 I=1,NINTV
IF(R1.LT.INTE(I)/INTE(NINTV))THEN
Q1=Q(I)
Q2=Q(I+1)
AA=A(I)
BB=B(I)
GOTO 58
ENDIF
57 CONTINUE
58 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
IF((CAND1.GT.Q1).AND.(CAND1.LT.Q2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& /(AA*CAND+BB)
IF(Y.GT.1.d0) NVIOLG=NVIOLG+1
IF(Y.GT.1.01d0) NVSEVG=NVSEVG+1
R3=PYR(0)
IF(R3.GT.Y)THEN
GOTO 59
ELSE
MASS=CAND
ENDIF
ELSE
C--generate value from P(Q_max,Q) for gluon with importance sampling
C (f(x)=c/(x+d))
41 R1=PYR(0)
CAND=(MIN3+DD)**(1-R1)*(MAX3+DD)**R1-DD
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& *(CAND+DD)/CC
IF(Y.GT.1.d0) NVIOLG=NVIOLG+1
IF(Y.GT.1.01d0) NVSEVG=NVSEVG+1
R2=PYR(0)
IF(R2.GT.Y)THEN
GOTO 41
ELSE
MASS=CAND
ENDIF
ENDIF
ENDIF
44 GETMASS=MASS
END
DOUBLE PRECISION FUNCTION GETMASSVETO(QMIN2,QBMAX2,QM2,ZM2,EP2,
& TYPE,MAX22,TIME2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
DOUBLE PRECISION QBMAX2,QM2,ZM2,EP2,MAX22,TIME2,MAX3,RZERO,CAND,
&REQUAL,TEQUAL,R,R2,PYR,ALPH,ALPHAS,PI,TZERO,TMAX,PREF,LNA,LN4,
&GETSPLITI,QCAND,TRUEVAL,QMIN2
CHARACTER*2 TYPE
DATA PI/3.141592653589793d0/
ALPH=ALPHAS((KTMIN*LPS)**2,LPS)
LNA=LOG((4.*EP2**2-QMIN**2)/LPS**2)
LN4=LOG(4.d0)
IF(TYPE.EQ.'QQ')THEN
PREF=4.*ALPH/(3.*2.*PI)
ELSE
PREF=3.*ALPH/(2.*PI)
ENDIF
MAX3=MIN(QBMAX2,MAX22)
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.QMIN) THEN
GETMASSVETO=0.d0
RETURN
ENDIF
TZERO=LOG(QMIN**2/LPS**2)
TMAX=LOG(MAX3**2/LPS**2)
TEQUAL=LOG(QMIN*EP2/LPS**2)
21 IF(TMAX.GT.TEQUAL)THEN
RZERO=EXP(PREF*(LN4**2-(TEQUAL-TZERO+LN4)**2
& -(TEQUAL-LNA)**2+(TMAX-LNA)**2))
ELSE
RZERO=EXP(PREF*(LN4**2-(TMAX-TZERO+LN4)**2))
ENDIF
REQUAL=EXP(PREF*(-(TEQUAL-LNA)**2+(TMAX-LNA)**2))
IF(QMIN2.EQ.0.d0)THEN
R=PYR(0)
ELSE
R=PYR(0)*(1.d0-RZERO)+RZERO
ENDIF
IF(R.LE.RZERO)THEN
GETMASSVETO=0.d0
RETURN
ELSEIF(TMAX.GT.TEQUAL)THEN
IF(R.LT.REQUAL)THEN
CAND=SQRT((TEQUAL-TZERO+LN4)**2+(TEQUAL-LNA)**2-(TMAX-LNA)**2
& +LOG(R)/PREF)+TZERO-LN4
ELSE
CAND=-SQRT((TMAX-LNA)**2-LOG(R)/PREF)+LNA
ENDIF
ELSE
CAND=SQRT((TMAX-TZERO+LN4)**2+LOG(R)/PREF)+TZERO-LN4
ENDIF
QCAND=SQRT(LPS**2*EXP(CAND))
TRUEVAL=GETSPLITI(QM2,QCAND,ZM2,EP2,TYPE,TIME2)
R2=PYR(0)
IF(CAND.LT.TEQUAL)THEN
IF(R2.LT.TRUEVAL/(2.*PREF*(CAND-TZERO+LN4)))THEN
GETMASSVETO=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
ELSE
IF(R2.LT.TRUEVAL/(2.*PREF*(LNA-CAND)))THEN
GETMASSVETO=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
ENDIF
END
DOUBLE PRECISION FUNCTION GETMASSVETOIN(QMIN2,QBMAX2,QM2,ZM2,EP2,
& TYPE,MAX22,TIME2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
DOUBLE PRECISION QBMAX2,QM2,ZM2,EP2,MAX22,TIME2,MAX3,RZERO,CAND,
&REQUAL,TEQUAL,R,R2,PYR,ALPH,ALPHAS,PI,TZERO,TMAX,PREF,LNA,LN4,
&GETINSPLITI,QCAND,TRUEVAL,QMIN2
CHARACTER*2 TYPE
DATA PI/3.141592653589793d0/
ALPH=ALPHAS((KTMIN*LPS)**2,LPS)
LNA=LOG((4.*EP2**2-QMIN**2)/LPS**2)
LN4=LOG(4.d0)
IF((TYPE.EQ.'QQ').OR.((TYPE.EQ.'GQ')))THEN
PREF=4.*ALPH/(3.*2.*PI)
ELSE
PREF=3.*ALPH/(2.*PI)
ENDIF
MAX3=MIN(QBMAX2,MAX22)
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.QMIN) THEN
GETMASSVETOIN=0.d0
RETURN
ENDIF
TZERO=LOG(QMIN**2/LPS**2)
TMAX=LOG(MAX3**2/LPS**2)
21 RZERO=EXP(PREF*(LN4**2-(TMAX-TZERO+LN4)**2))
IF(QMIN2.EQ.0.d0)THEN
R=PYR(0)
ELSE
R=PYR(0)*(1.d0-RZERO)+RZERO
ENDIF
IF(R.LE.RZERO)THEN
GETMASSVETOIN=0.d0
RETURN
ELSE
CAND=SQRT((TMAX-TZERO+LN4)**2+LOG(R)/PREF)+TZERO-LN4
ENDIF
QCAND=SQRT(LPS**2*EXP(CAND))
TRUEVAL=GETINSPLITI(QCAND,TYPE)
R2=PYR(0)
IF(R2.LT.TRUEVAL/(2.*PREF*(CAND-TZERO+LN4)))THEN
GETMASSVETOIN=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
END
***********************************************************************
*** function generatez
***********************************************************************
*** picks a value from the splitting function for a splitting of
*** type 'type' with virtuality 'ti' and energy 'ea' of the
*** splitting parton and additional contraint 'epsi' due to
*** angular ordering
***********************************************************************
DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
CHARACTER*2 TYPE
C WRITE(*,*)'generatez: ti=',TI
C WRITE(*,*)'generatez: ea=',EA
C WRITE(*,*)'generatez: epsi=',EPSI
C WRITE(*,*)'generatez: type=',TYPE
IF(TI.EQ.0.d0)THEN
EPS=EPSI
ELSE
IF(CONSTR)THEN
EPS=MAX(0.5-0.5*SQRT(1.-QMIN**2/TI)
& *SQRT(1-TI/EA**2),MINEN*Q0/EA,EPSI)
C EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
C & *SQRT(1-TI/EA**2),MINEN*Q0/EA,EPSI)
ELSE
EPS=MAX(0.5-0.5*SQRT(1.-TI/EA**2),MINEN*Q0/EA,EPSI)
ENDIF
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
C WRITE(*,*)'generatez: generatez=',GENERATEZ
61 END
***********************************************************************
*** function ifqqbar
***********************************************************************
*** decide whether a gluon with virtuality 'virt' and energy
*** 'ea' should split in two gluons or a qqbar pair
***********************************************************************
LOGICAL FUNCTION IFQQBAR(VIRTB,VIRTA,ZAA,EB,TIM)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION VIRTB,VIRTA,ZAA,EB,INTG,INTQ,R,PYR,
&GETSPLITI,TIM
C WRITE(*,*)'ifqqbar: virt=',VIRT
C WRITE(*,*)'ifqqbar: ea=',EA
C--calculate integral of g->gg splitting fnc
INTG=GETSPLITI(VIRTA,VIRTB,ZAA,EB,'GG',TIM)
C--calculate integral of g->q qbar splitting fnc
INTQ=GETSPLITI(VIRTA,VIRTB,ZAA,EB,'QG',TIM)
C--decide which process to use according to probility
R=PYR(0)
IF(R.LT.(INTQ/(INTQ+INTG)))THEN
IFQQBAR=.TRUE.
ELSE
IFQQBAR=.FALSE.
ENDIF
C WRITE(*,*)'ifqqbar: ifqqbar=',IFQQBAR
END
***********************************************************************
*** subroutine showana
***********************************************************************
*** analysis of the shower
***********************************************************************
SUBROUTINE SHOWANA(PMAX)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/MEANKT/NKT1(20),SUMKT1(20)
INTEGER NKT1
DOUBLE PRECISION SUMKT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER I,NGLUON,MAXLINE,NSCAT,J,PL,NKT2(20),II
DOUBLE PRECISION PMAX,XP,PYP,THETA,PHI,ENMAX,PTOT(4),DP,DE,
&DQ,XI,TRIGMIN,TRIGMAX,ASSMIN,THETA2,PHI2,SUMKT2(20)
DATA TRIGMIN/2.5d0/
DATA TRIGMAX/4.d0/
DATA ASSMIN/1.d0/
DO 76 I=1,20
NKT2(I)=0
SUMKT2(I)=0.d0
76 CONTINUE
C--off we go
NGLUON=0
PTOT(1)=0.d0
PTOT(2)=0.d0
PTOT(3)=0.d0
PTOT(4)=0.d0
ENMAX=0.d0
MAXLINE=0
C--rotate event such that initiating parton points in z-direction
THETA=PYP(2,13)
PHI=PYP(2,15)
CALL PYROBO(2,N,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(2,N,-THETA,0d0,0d0,0d0,0d0)
DO 70 I=2,N
CC--lifetimes of decayed partons
C IF(P(I,5).NE.0d0) CALL HF1(104,REAL(P(I,4)/P(I,5)**2*0.2),1.)
CC--virtuality ratio mass(daughter)/mass(mother)
C IF((P(I,5).NE.0d0).AND.(I.NE.2))
C & CALL HF1(108,REAL(P(I,5)/P(K(I,3),5)),1.)
C--analysis of final state partons
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/PMAX
XI=LOG(1/XP)
C--xi
C IF(PYP(I,6).NE.0) CALL HF1(100,REAL(XI),1.)
C--energy
CALL HF1(321,REAL(P(I,4)),EVWEIGHT)
C--theta wrt jet axis
CALL HF1(118,REAL(PYP(I,13)),EVWEIGHT)
C--theta weighted with energy
CALL HF1(120,REAL(PYP(I,13)),REAL(P(I,4)))
C--2D-histogram xi - theta
CALL HF2(200,REAL(LOG(1/XP)),REAL(PYP(I,13)),EVWEIGHT)
C--kt wrt jet axis
IF(I.GT.2) CALL HF1(115,REAL(PYP(I,10)),EVWEIGHT)
C--kt above threshold
IF((I.GT.2).AND.(P(I,4).GT.0.5))
& CALL HF1(401,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.1.))
& CALL HF1(402,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.2.))
& CALL HF1(403,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.5.))
& CALL HF1(404,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.10.))
& CALL HF1(405,REAL(PYP(I,10)),EVWEIGHT)
C--mean kt above threshold
DO 77 II=1,20
IF((I.GT.2).AND.(P(I,4).GT.(II-1)/2.))THEN
NKT1(II)=NKT1(II)+1
SUMKT1(II)=SUMKT1(II)+PYP(I,10)
NKT2(II)=NKT2(II)+1
SUMKT2(II)=SUMKT2(II)+PYP(I,10)
ENDIF
77 CONTINUE
C--xi of quarks
IF(K(I,2).EQ.1)THEN
CALL HF1(101,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of antiquarks
ELSEIF(K(I,2).EQ.-1)THEN
CALL HF1(120,REAL(LOG(1/XP)),EVWEIGHT)
ELSE
C--xi of gluons
CALL HF1(102,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons from gluon splitting
IF(K(K(I,3),2).EQ.21) CALL HF1(121,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons radiated by quarks
IF(K(K(I,3),2).EQ.1) CALL HF1(122,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons radiated by antiquarks
IF(K(K(I,3),2).EQ.-1) CALL HF1(123,REAL(LOG(1/XP)),EVWEIGHT)
NGLUON=NGLUON+1
ENDIF
C--find leading parton
IF(P(I,4).GT.ENMAX)THEN
ENMAX=P(I,4)
MAXLINE=I
ENDIF
C--determine number of scatterings experienced by parton
NSCAT=0
PL=K(I,3)
DO 73 J=1,N
IF(K(PL,1).EQ.12) NSCAT=NSCAT+1
IF(K(PL,3).EQ.0)THEN
GOTO 74
ELSE
PL=K(PL,3)
ENDIF
73 CONTINUE
C--2D-histogramm xi - number of scatterings
74 CALL HF2(220,REAL(XI),REAL(NSCAT),EVWEIGHT)
C--PHENIX-like correlation in theta and kt
IF((P(I,4).GT.TRIGMIN).AND.(P(I,4).LT.TRIGMAX))THEN
DO 75 J=1,N
IF((K(J,1).LT.11).AND.(P(J,4).GT.ASSMIN)
& .AND.(P(J,4).LT.P(I,4)))THEN
THETA2=PYP(I,13)
PHI2=PYP(I,15)
CALL PYROBO(J,J,THETA2,0d0,0d0,0d0,0d0)
CALL PYROBO(J,J,0d0,PHI2,0d0,0d0,0d0)
CALL HF1(135,REAL(PYP(J,13)),EVWEIGHT)
CALL HF1(400,REAL(PYP(J,10)),EVWEIGHT)
CALL PYROBO(J,J,0d0,-PHI2,0d0,0d0,0d0)
CALL PYROBO(J,J,-THETA2,0d0,0d0,0d0,0d0)
ENDIF
75 CONTINUE
ENDIF
ENDIF
70 CONTINUE
DO 78 II=1,20
IF(NKT2(II).GT.0) CALL HF2(407,(II-1)/2.,
& REAL(SUMKT2(II)/NKT2(II)),EVWEIGHT)
78 CONTINUE
C--theta of leading parton
CALL HF1(117,REAL(PYP(MAXLINE,13)),EVWEIGHT)
C--rotate back
CALL PYROBO(2,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(2,N,0d0,PHI,0d0,0d0,0d0)
C--number of final state gluons in the jet
CALL HF1(106,REAL(NGLUON),EVWEIGHT)
C--rotate such the leading particle points in z-direction
THETA=PYP(MAXLINE,13)
PHI=PYP(MAXLINE,15)
CALL PYROBO(2,N,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(2,N,-THETA,0d0,0d0,0d0,0d0)
DO 71 I=2,N
IF((K(I,1).LT.11).AND.(I.NE.MAXLINE))THEN
IF(I.GT.2) THEN
C--kt wrt leading parton
CALL HF1(116,REAL(PYP(I,10)),EVWEIGHT)
C--theta wrt leading parton
CALL HF1(119,REAL(PYP(I,13)),EVWEIGHT)
IF(P(MAXLINE,4).GT.PMAX/10.d0) THEN
C--kt and theta wrt to leading parton for leading parton above E_jet/10
CALL HF1(131,REAL(PYP(I,10)),EVWEIGHT)
CALL HF1(133,REAL(PYP(I,13)),EVWEIGHT)
IF(P(I,4).GT.PMAX/20.d0)THEN
C--kt and theta wrt to leading parton for leading parton above E_jet/10 and
C associated above E_jet/20
CALL HF1(132,REAL(PYP(I,10)),EVWEIGHT)
CALL HF1(134,REAL(PYP(I,13)),EVWEIGHT)
ENDIF
ENDIF
ENDIF
ENDIF
71 CONTINUE
C--rotate back
CALL PYROBO(2,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(2,N,0d0,PHI,0d0,0d0,0d0)
C--calculate total 4-momentum of jet (including recoil)
DO 72 I=2,N
IF(K(I,1).LT.11)THEN
PTOT(1)=PTOT(1)+P(I,1)
PTOT(2)=PTOT(2)+P(I,2)
PTOT(3)=PTOT(3)+P(I,3)
PTOT(4)=PTOT(4)+P(I,4)
ENDIF
72 CONTINUE
C--total jet energy gain (or loss)
DE=PTOT(4)-P(2,4)
C--total jet 3-momentum gain (or loss)
DP=SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)-P(2,1)
C--total jet virtuality gain (or loss)
DQ=PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2 - P(2,5)**2
CALL HF1(140,REAL(DE),EVWEIGHT)
CALL HF1(141,REAL(DP),EVWEIGHT)
CALL HF1(142,REAL(DQ),EVWEIGHT)
END
SUBROUTINE NJETANA(NJ,PARTON,E)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
- INTEGER NJ,I,NJET,NHIS
+ INTEGER NJ,I,NJET,NHIS,NPART
DOUBLE PRECISION E,PYP,XI,XP,LOGYCUT
LOGICAL PARTON
+ NPART=0
+ DO 666 I=1,N
+ IF(K(I,1).EQ.1) NPART=NPART+1
+ 666 CONTINUE
+ IF(NPART.EQ.0) RETURN
+
IF(PARTON)THEN
NHIS=0
ELSE
NHIS=10
ENDIF
IF(NJ.EQ.1)THEN
DO 78 I=1,N
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/E
XI=LOG(1/XP)
IF(PARTON)THEN
CALL HF1(100,REAL(XI),EVWEIGHT)
ELSE
IF(PYP(I,6).NE.0) CALL HF1(110,REAL(XI),EVWEIGHT)
ENDIF
ENDIF
78 CONTINUE
ENDIF
DO 76 I=0,29
LOGYCUT=-6.+I*0.2
PARU(45)=10.**LOGYCUT
IF(I.EQ.0)THEN
MSTU(48)=0
ELSE
MSTU(48)=1
ENDIF
NJET=0
CALL PYCLUS(NJET)
IF(NJET.EQ.1)THEN
CALL HF2(600+NHIS+1,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.2)THEN
CALL HF2(600+NHIS+2,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.3)THEN
CALL HF2(600+NHIS+3,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.4)THEN
CALL HF2(600+NHIS+4,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.GE.5)THEN
CALL HF2(600+NHIS+5,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ENDIF
76 CONTINUE
END
SUBROUTINE EVSHAPEANA(NJ,PARTON,E)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--local variables
- INTEGER NJ,I,NHIS
+ INTEGER NJ,I,NHIS,NPART
DOUBLE PRECISION E,PYP,XI,XP,SPHE,APLA,THRU,OBLA,MH,ML,
&TAXIS(3),SUM1,SUM2,BT,VECT(3)
LOGICAL PARTON
+ NPART=0
+ DO 666 I=1,N
+ IF(K(I,1).EQ.1) NPART=NPART+1
+ 666 CONTINUE
+ IF(NPART.EQ.0) RETURN
+
IF(PARTON)THEN
NHIS=0
ELSE
NHIS=10
ENDIF
IF(NJ.EQ.1)THEN
DO 78 I=1,N
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/E
XI=LOG(1/XP)
IF(PARTON)THEN
CALL HF1(100,REAL(XI),EVWEIGHT)
CALL HF1(322,REAL(PYP(I,10)),EVWEIGHT)
ELSE
IF(PYP(I,6).NE.0) CALL HF1(110,REAL(XI),EVWEIGHT)
IF((PYP(I,6).NE.0).OR.(K(I,2).EQ.111))
& CALL HF1(321,REAL(PYP(I,10)),EVWEIGHT)
ENDIF
ENDIF
78 CONTINUE
ENDIF
CALL PYTHRU(THRU,OBLA)
CALL HF2(700+NHIS+8,REAL(P(N+1,4)),REAL(NJ-1),EVWEIGHT)
CALL HF2(700+NHIS+3,REAL(P(N+2,4)),REAL(NJ-1),EVWEIGHT)
CALL HF2(700+NHIS+4,REAL(P(N+3,4)),REAL(NJ-1),EVWEIGHT)
END
***********************************************************************
*** function scatprimfunc
***********************************************************************
*** evaluates the primitive function in the scattering integral
***********************************************************************
DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
DATA PI/3.141592653589793d0/
IF(BRICK)THEN
SCATPRIMFUNC= - 2.*PI*ALPHAS(0.d0,LQCD)**2/(T+MDEB**2)
ELSE
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
ENDIF
C WRITE(*,*)'scatprimfunction:',SCATPRIMFUNC
END
C DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,S)
C IMPLICIT NONE
CC--Parameter common block
C COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
C &LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
C INTEGER NF
C DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
C &LTIME,LPS
C LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
CC--local variables
C DOUBLE PRECISION T,PI,S,EI
C DATA PI/3.141592653589793d0/
C
C SCATPRIMFUNC=16.*PI**3*(-2.*EI(-LOG(T/LQCD**2))*S**2/LQCD**2
C & - 2.*S**2/(T*LOG(T/LQCD**2)) + 2.*S/LOG(T/LQCD**2)
C & + LQCD**2*EI(LOG(T/LQCD**2)) - T/LOG(T/LQCD**2))
C & /(S**2*(11.-2.*NF/3.)**2)
C END
DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q
INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
END
DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q
INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
END
DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q,EI
C INTPQGHIGH=6.*(-2.*LPS**6*(Q**4*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))
C & /LPS**4
C & - 2.*Q**2*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/LPS**2
C & + EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/LPS**2)/Q**6
C & - 2.*LPS**4*(EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))
C & - Q**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/LPS**2)/Q**4
C & - LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2)/((33.-2.*NF)*2.)
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
***********************************************************************
*** generates a t value for projectile mass 'mp', mass 'ms' of the
*** scattering centre and projectile energy 'ep' from the
*** differential scattering cross section
***********************************************************************
DOUBLE PRECISION FUNCTION GETT(S,TMIN,MAXT,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION S,TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
&MDEB
DATA PI/3.141592653589793d0/
C TMAX=MIN(MAXT,4.*MDEB**2)
TMAX=MAXT
IF(TMIN.GT.TMAX) THEN
GETT=0.d0
RETURN
ENDIF
MAXI=ALPHAS(MDEB**2,LQCD)**2*2.*S**2/(MDEB**4)
20 R1=PYR(0)*(TMAX-TMIN)+TMIN
Y=ALPHAS(R1+MDEB**2,LQCD)**2*(S**2+(S-R1)**2)/(R1+MDEB**2)**2
IF(Y.GT.MAXI) WRITE(*,*) 'maximum violated in gett',Y
R2=PYR(0)*MAXI
IF(R2.LT.Y)THEN
GETT=R1
ELSE
GOTO 20
ENDIF
END
***********************************************************************
*** function ei
***********************************************************************
*** evaluates the exponential integral
***********************************************************************
DOUBLE PRECISION FUNCTION EI(X)
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C--local variables
INTEGER K,LINE,LMAX
DOUBLE PRECISION X,R,GA,XA(4),YA(4),Y,DY
IF(X.GE.0.d0)THEN
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
25 EI=EI+R
EI=DEXP(X)/X*EI
ENDIF
ELSE
LMAX=INT(-X*NVAL/VALMAX)
LINE=MAX(LMAX-1,1)
LINE=MIN(LINE,97)
DO 26 K=1,4
XA(K)=EIX(1,LINE-1+K)
YA(K)=EIX(2,LINE-1+K)
26 CONTINUE
CALL POLINT(XA,YA,4,-X,Y,DY)
EI=Y
ENDIF
END
DOUBLE PRECISION FUNCTION PQQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
END
DOUBLE PRECISION FUNCTION PGQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
END
DOUBLE PRECISION FUNCTION PGG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
END
DOUBLE PRECISION FUNCTION PQG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQG=0.5*(Z**2 + (1.-Z)**2)
END
***********************************************************************
*** function alphas
***********************************************************************
*** evaluates the coupling alpha_s at scale 't'
***********************************************************************
DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION T,L0,PI,LAMBDA
DATA PI/3.141592653589793d0/
IF(BRICK)THEN
ALPHAS=0.3
ELSE
ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
ENDIF
END
***********************************************************************
*** subroutine splitfncint
***********************************************************************
*** integrates the splitting functions in vacuum and in medium
***********************************************************************
SUBROUTINE SPLITFNCINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--local variables
INTEGER NSTEP,I,J,NOK,NBAD
DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
&LNZMMAX,ZM,ZM2,Q
DATA ZMMAX/0.5/
DATA NSTEP/99/
DATA EPSI/1.d-5/
QMAX=EMAX
ZMMIN=QMIN/EMAX
LNZMMIN=LOG(ZMMIN)
LNZMMAX=LOG(ZMMAX)
NPOINT=NSTEP
DO 100 I=0,NSTEP
Q=I*(QMAX-QMIN)/NSTEP+QMIN
QVAL(I+1)=Q
QQUAD=Q**2
DO 110 J=0,NSTEP
ZM=EXP(J*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
ZMVAL(J+1)=ZM
IF(Q.LE.QMIN)THEN
SPLITIQQV(I+1,J+1)=0.d0
SPLITIQQM(I+1,J+1)=0.d0
SPLITIGGV(I+1,J+1)=0.d0
SPLITIGGM(I+1,J+1)=0.d0
SPLITIQGV(I+1,J+1)=0.d0
SPLITIQGM(I+1,J+1)=0.d0
ELSE
C ZM2=0.5-0.5*SQRT((1.-QMIN**2/Q**2)*(1.-Q**2/EMAX**2))
ZM2=0.5-0.5*SQRT(1.-4.*(KTMIN*LPS)**2/Q**2)
ZM=MAX(ZM,ZM2)
IF(ZM.EQ.0.5)THEN
SPLITIQQV(I+1,J+1)=0.d0
SPLITIQQM(I+1,J+1)=0.d0
SPLITIGGV(I+1,J+1)=0.d0
SPLITIGGM(I+1,J+1)=0.d0
SPLITIQGV(I+1,J+1)=0.d0
SPLITIQGM(I+1,J+1)=0.d0
ELSE
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
C WRITE(*,*)'q=',Q
C WRITE(*,*)'qmin=',QMIN
C WRITE(*,*)'zm=',ZM
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,2)
SPLITIQQV(I+1,J+1)=YSTART
C WRITE(*,*)'splitiqqv=',YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,2)
SPLITIQQM(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,3)
SPLITIGGV(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,3)
SPLITIGGM(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,4)
SPLITIQGV(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,4)
SPLITIQGM(I+1,J+1)=YSTART
ENDIF
ENDIF
110 CONTINUE
100 CONTINUE
END
SUBROUTINE PDFINT(QMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
INTEGER I,J,NOK,NBAD
DOUBLE PRECISION DELTAQ,QMAX,Q1,Q2,GETPDFXINTEXACT,
&GETPDFXINT,YSTART,HFIRST,EPSI,X,Q2LEFT,Q2MAX,DELTAQ2,
&Q2RIGHT,Q2LOW,GETMS
DATA EPSI/1.d-4/
C--jkl must use max MS
Q2MAX=2.*QMAX*GETMS(0.d0,0.d0,0.d0,0.d0)
Q2MAX=2.*QMAX*MS
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
C WRITE(*,*)'PDFINT for',Q2MAX
DO 13 I=1,100
X = (I-1)*1.d0/99.d0
QINQ(I,101)=X
GINQ(I,101)=X
QING(I,101)=X
GING(I,101)=X
DO 14 J=1,100
Q2LEFT = EXP((J-1)*DELTAQ2/100.d0 + LOG(Q0**2))
Q2RIGHT = EXP(J*DELTAQ2/100.d0 + LOG(Q0**2))
C WRITE(*,*)I,J,X,Q2LEFT,Q2RIGHT
IF(I.EQ.1)THEN
QINQ(101,J)=Q2LEFT
GINQ(101,J)=Q2LEFT
QING(101,J)=Q2LEFT
GING(101,J)=Q2LEFT
ENDIF
Z=X
XMAX=SQRT(Q2RIGHT)
C--f_q^q
Q2LOW=MAX(Q2LEFT,Q0**2/(4.*(1.-X)))
IF((Q2LOW.GE.Q2RIGHT*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,7)
ENDIF
QINQ(I,J)=YSTART
C--f_g^q
Q2LOW=MAX(Q2LEFT,MAX(Q0**2/(4.*(1.-X)),Q0**2/(4.*(X))))
IF((Q2LOW.GE.Q2RIGHT*(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*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,8)
ENDIF
GINQ(I,J)=YSTART
C--f_q^g
Q2LOW=MAX(Q2LEFT,Q0**2/(4.*(1.-X)))
IF((Q2LOW.GE.Q2RIGHT*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,9)
ENDIF
QING(I,J)=YSTART
C--f_g^g
Q2LOW=MAX(Q2LEFT,MAX(Q0**2/(4.*(1.-X)),Q0**2/(4.*(X))))
IF((Q2LOW.GE.Q2RIGHT*(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*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,10)
ENDIF
GING(I,J)=YSTART
14 CONTINUE
13 CONTINUE
DELTAQ=LOG(QMAX**2)-LOG(Q0**2)
DO 11 I=1,100
Q1 = EXP((I-1)*DELTAQ/99.d0 + LOG(Q0**2))
QINQX(I,101)=Q1
GINQX(I,101)=Q1
QINGX(I,101)=Q1
GINGX(I,101)=Q1
DO 12 J=1,100
Q2 = EXP((J-1)*DELTAQ/99.d0 + LOG(Q0**2))
IF(I.EQ.1)THEN
QINQX(101,J)=Q2
GINQX(101,J)=Q2
QINGX(101,J)=Q2
GINGX(101,J)=Q2
ENDIF
IF(Q2.LE.Q1)THEN
QINQX(I,J)=0.d0
GINQX(I,J)=0.d0
QINGX(I,J)=0.d0
GINGX(I,J)=0.d0
ELSE
QINQX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'QQ')
GINQX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'GQ')
QINGX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'QG')
GINGX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'GG')
ENDIF
12 CONTINUE
11 CONTINUE
END
SUBROUTINE XSECINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW
DOUBLE PRECISION QLOW
C--local variables
INTEGER I,J,NOK,NBAD
DOUBLE PRECISION EMAX,TMAX,Q2,TMAXMAX,Q2MAX,DELTAQ2,DELTATMAX,
&YSTART,HFIRST,EPSI,GETMS
DATA EPSI/1.d-4/
C--jkl ??? must use maximum MS
TMAXMAX=2.*EMAX*GETMS(0.d0,0.d0,0.d0,0.d0)
TMAXMAX=2.*EMAX*MS
Q2MAX=EMAX**2
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
DELTATMAX=LOG(TMAXMAX)-LOG(Q0**2*(1.d0+1.d-6))
DO 11 I=1,100
Q2 = EXP((I-1)*DELTAQ2/99.d0 + LOG(Q0**2))
INTQ1(I,101)=Q2
INTQ2(I,101)=Q2
INTG1(I,101)=Q2
INTG2(I,101)=Q2
DO 12 J=1,100
TMAX = EXP((J-1)*DELTATMAX/99.d0 + LOG(Q0**2*(1.d0+1.d-6)))
IF(I.EQ.1)THEN
INTQ1(101,J)=TMAX
INTQ2(101,J)=TMAX
INTG1(101,J)=TMAX
INTG2(101,J)=TMAX
ENDIF
C WRITE(*,*)'Q^2,tmax:',Q2,TMAX
IF(TMAX.LT.Q2)THEN
INTQ1(I,J)=0.d0
INTQ2(I,J)=0.d0
INTG1(I,J)=0.d0
INTG2(I,J)=0.d0
ELSE
C--first quark integral
QLOW=SQRT(Q2)
HFIRST=0.01*(TMAX-Q2)
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,11)
INTQ1(I,J)=YSTART
C--second quark integral
QLOW=SQRT(Q2)
HFIRST=0.01*(TMAX-Q2)
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,14)
INTQ2(I,J)=YSTART
C--first gluon integral
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,12)
INTG1(I,J)=YSTART
C--second gluon integral
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,13)
INTG2(I,J)=YSTART
ENDIF
12 CONTINUE
11 CONTINUE
END
SUBROUTINE INSUDAINT(QMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2),
&SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--local variables
INTEGER I
DOUBLE PRECISION QMAX,Q,GETINSUDAKOV
DO 22 I=1,101
Q=(I-1)*(1.5*QMAX-Q0)/100.+Q0
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
***********************************************************************
*** subroutine expint
***********************************************************************
*** integrates the exponential integral for negative arguments
***********************************************************************
SUBROUTINE EIXINT
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C-local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,EPSI,HFIRST,YSTART
DATA EPSI/1.d-5/
NVAL=100
VALMAX=25.
DO 10 I=1,100
X=I*25./100.
EIX(1,I)=X
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,NOK,NBAD,5)
EIX(2,I)=-YSTART
10 CONTINUE
END
***********************************************************************
*** subroutine polint2
***********************************************************************
*** 2d plynom interpolation
***********************************************************************
SUBROUTINE POLINT2(X1A,X2A,YA,M,N,X1,X2,Y,DY)
IMPLICIT NONE
INTEGER M,N,NMAX,MMAX,J,K
DOUBLE PRECISION X1A,X2A,YA,X1,X2,Y,DY,YNTMP,YMTMP
PARAMETER (NMAX=20,MMAX=20)
DIMENSION X1A(M),X2A(N),YA(M,N),YNTMP(NMAX),YMTMP(MMAX)
DO 12 J=1,M
DO 11 K=1,N
YNTMP(K)=YA(J,K)
11 CONTINUE
CALL POLINT(X2A,YNTMP,N,X2,YMTMP(J),DY)
12 CONTINUE
CALL POLINT(X1A,YMTMP,M,X1,Y,DY)
RETURN
END
***********************************************************************
*** subroutine polint
***********************************************************************
*** 1d plynom interpolation
***********************************************************************
SUBROUTINE POLINT(XA,YA,N,X,Y,DY)
IMPLICIT NONE
INTEGER N,NMAX,NS,I,M
DOUBLE PRECISION XA,YA,X,Y,DY,C,D,DIF,DIFT,HO,HP,W,DEN
PARAMETER (NMAX=10)
DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
NS=1
DIF=ABS(X-XA(1))
DO 11 I=1,N
DIFT=ABS(X-XA(I))
IF(DIFT.LT.DIF)THEN
NS=I
DIF=DIFT
ENDIF
C(I)=YA(I)
D(I)=YA(I)
11 CONTINUE
Y=YA(NS)
NS=NS-1
DO 13 M=1,N-1
DO 12 I=1,N-M
HO=XA(I)-X
HP=XA(I+M)-X
W=C(I+1)-D(I)
DEN=HO-HP
C IF(DEN.EQ.0d0)PAUSE
IF(DEN.EQ.0d0)THEN
WRITE(*,*)'error in polint: den==0'
RETURN
ENDIF
DEN=W/DEN
D(I)=HP*DEN
C(I)=HO*DEN
12 CONTINUE
IF(2*NS.LT.N-M)THEN
DY=C(NS+1)
ELSE
DY=D(NS)
NS=NS-1
ENDIF
Y=Y+DY
13 CONTINUE
14 RETURN
END
***********************************************************************
*** subroutine odeint
***********************************************************************
*** numerical solution of ODE using quality controlled
*** Runge-Kutta with adaptive step size
***********************************************************************
SUBROUTINE ODEINT(YSTART,X1,X2,EPS,H1,HMIN,NOK,NBAD,W1)
IMPLICIT NONE
INTEGER NOK,NBAD,NSTP,MAXSTP,W1
DOUBLE PRECISION YSTART,X1,X2,EPS,H1,HMIN,X,H,Y,YSCAL,T4,
&HDID,HNEXT,TWO,ZERO,TINY,DYDX,DERIV,QA2,ZA2,EB2
PARAMETER (MAXSTP=100000,TWO=2.,ZERO=0.,TINY=1.E-30)
CHARACTER*2 TYPE4
X=X1
H=SIGN(H1,X2-X1)
Y=YSTART
DO 20 NSTP=1,MAXSTP
DYDX=DERIV(X,W1)
YSCAL=ABS(Y)+ABS(H*DYDX)+TINY
IF((X+H-X2)*(X+H-X1).GT.ZERO) H=X2-X
CALL RKQC(Y,DYDX,X,H,EPS,YSCAL,HDID,HNEXT,W1)
IF(HDID.EQ.H)THEN
NOK=NOK+1
ELSE
NBAD=NBAD+1
ENDIF
IF((X-X2)*(X2-X1).GE.ZERO)THEN
YSTART=Y
RETURN
ENDIF
C IF(ABS(HNEXT).LT.HMIN) PAUSE 'Stepsize smaller than minimum'
IF(ABS(HNEXT).LT.HMIN) THEN
WRITE(*,*) 'Stepsize smaller than minimum'
RETURN
ENDIF
H=HNEXT
20 CONTINUE
C PAUSE 'Too many steps'
WRITE(*,*) 'Too many steps'
RETURN
END
***********************************************************************
*** subroutine rkqc
***********************************************************************
*** quality controlled Runge-Kutta routine
***********************************************************************
SUBROUTINE RKQC(Y,DYDX,X,HTRY,EPS,YSCAL,HDID,HNEXT,W2)
IMPLICIT NONE
INTEGER W2
DOUBLE PRECISION Y,DYDX,X,HTRY,EPS,YSCAL,HDID,HNEXT,T5,
&XSAV,YSAV,DYSAV,H,HH,ERRMAX,YTEMP,PGROW,PSHRINK,FCOR,ONE,
&SAFETY,ERRCON,RK4,DERIV,QA3,ZA3,EB3
CHARACTER*2 TYPE5
PARAMETER (PGROW=-0.2,PSHRINK=-0.25,FCOR=1d0/15d0,ONE=1.,
& SAFETY=0.9,ERRCON=6.E-4)
XSAV=X
YSAV=Y
DYSAV=DYDX
H=HTRY
10 HH=0.5*H
YTEMP=RK4(YSAV,DYSAV,XSAV,HH,W2)
X=XSAV+HH
DYDX=DERIV(X,W2)
Y=RK4(YTEMP,DYDX,X,HH,W2)
X=XSAV+H
IF(X.EQ.XSAV)THEN
WRITE(*,*)'RKQC: type=',W2
C PAUSE 'Stepsize not significant in RKQC'
WRITE(*,*) 'Stepsize not significant in RKQC'
RETURN
ENDIF
YTEMP=RK4(YSAV,DYSAV,XSAV,H,W2)
ERRMAX=0.
YTEMP=Y-YTEMP
ERRMAX=MAX(ERRMAX,ABS(YTEMP/YSCAL))
ERRMAX=ERRMAX/EPS
IF(ERRMAX.GT.ONE)THEN
H=SAFETY*H*(ERRMAX**PSHRINK)
GOTO 10
ELSE
HDID=H
IF(ERRMAX.GT.ERRCON)THEN
HNEXT=SAFETY*H*(ERRMAX**PGROW)
ELSE
HNEXT=4.*H
ENDIF
ENDIF
Y=Y+YTEMP*FCOR
RETURN
END
***********************************************************************
*** subroutine rk4
***********************************************************************
*** 4th order Runge-Kutta step
***********************************************************************
DOUBLE PRECISION FUNCTION RK4(Y,DYDX,X,H,W3)
IMPLICIT NONE
INTEGER W3
DOUBLE PRECISION Y,DYDX,X,H,HH,H6,XH,YT,DYT,DYM,YOUT,
&DERIV,QA4,ZA4,EB4,T6
CHARACTER*2 TYPE6
HH=H*0.5
H6=H/6
XH=X+HH
YT=Y+HH*DYDX
DYT=DERIV(XH,W3)
YT=Y+HH*DYT
DYM=DERIV(XH,W3)
YT=Y+H*DYM
DYM=DYT+DYM
DYT=DERIV(X+H,W3)
YOUT=Y+H6*(DYDX+DYT+2.*DYM)
RK4=YOUT
END
C> returns if there is a scattering for parton in line 'LINE'
C> within 'DTMAX'
C> if yes 'DELTAT' is set to the time of the scattering
C>
C> \param LINE line of parton in the event record
C> \param DTMAX upper limit when scattering can happen
C> \param DELTAT time of scattering (if none, undefined)
LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX,DELTAT)
IMPLICIT NONE
C line of parton to scatter
INTEGER LINE
C start and max. time for scattering
DOUBLE PRECISION TSTART,DTMAX
C scattering time (if any)
DOUBLE PRECISION DELTAT
C pythia common block
INTEGER NMAX
PARAMETER (NMAX=5000)
COMMON/PYJETS/N,NPAD,K(NMAX,5),P(NMAX,5),V(NMAX,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
DOUBLE PRECISION R,PYR,F,FOLD,DF,DT,EN,M,BETA,PYP,
&GETSSCAT,GETNEFF,LAMBDA,GETMD,GETMS,GETTEMP
INTEGER I,NSTEP,TYPE
DATA NSTEP/25/
C potential scattering position
DOUBLE PRECISION XSC,YSC,ZSC,TSC
CHARACTER TYPE2
GETDELTAT=.FALSE.
DT=DTMAX/NSTEP
R=-LOG(PYR(0))
EN=P(LINE,4)
M=P(LINE,5)
BETA=PYP(LINE,8)/P(LINE,4)
TYPE=K(LINE,2)
IF(TYPE.EQ.21)THEN
TYPE2='G'
ELSE
TYPE2='Q'
ENDIF
DELTAT=0.D0
FOLD=0.d0
F=0.d0
DO 100 I=1,NSTEP
C potential position of scattering
XSC=MV(LINE,1)+(TSTART+DT*(I-1))*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(TSTART+DT*(I-1))*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(TSTART+DT*(I-1))*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+(TSTART+DT*(I-1))
IF(GETNEFF(XSC,YSC,ZSC,TSC).LE.1d-2)GOTO 105
C DF=GETSSCAT(EN,TYPE,M,GETMD(XSC,YSC,ZSC,TSC),
C &GETMS(XSC,YSC,ZSC,TSC))*
C &GETNEFF(XSC,YSC,ZSC,TSC)*DT*5.d0*BETA
DF=GETSSCAT(EN,M,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC)
&,GETMD(XSC,YSC,ZSC,TSC))*
&GETNEFF(XSC,YSC,ZSC,TSC)*
&DT*5.d0*BETA
F=F+DF
IF(F>R) GOTO 104
C IF((F-FOLD).LE.1.D-12) GOTO 105
FOLD=F
100 CONTINUE
GOTO 105
104 DELTAT=(I-1)*DT
C now refine DELTAT within the bin assuming constant medium properties
C LAMBDA=1.d0/(GETNEFF(XSC,YSC,ZSC,TSC)*GETSSCAT(EN,TYPE,M,
C &GETMD(XSC,YSC,ZSC,TSC),GETMS(XSC,YSC,ZSC,TSC))*5.d0*BETA)
LAMBDA=1.d0/(GETNEFF(XSC,YSC,ZSC,TSC)*
&GETSSCAT(EN,M,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
&GETMD(XSC,YSC,ZSC,TSC))*5.d0*BETA)
R=PYR(0)
DELTAT=DELTAT-LAMBDA*LOG(1+R*(EXP(-DT/LAMBDA)-1))
C potential position of scattering
XSC=MV(LINE,1)+(TSTART+DELTAT)*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(TSTART+DELTAT)*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(TSTART+DELTAT)*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+(TSTART+DELTAT)
IF(GETNEFF(XSC,YSC,ZSC,TSC).GE.1d-2) GETDELTAT=.TRUE.
105 CONTINUE
END
Index: jewel/jewel-3.1.1.f
===================================================================
--- jewel/jewel-3.1.1.f (revision 7)
+++ jewel/jewel-3.1.1.f (revision 8)
@@ -1,5920 +1,5980 @@
PROGRAM MEDIUM_CASCADE
IMPLICIT NONE
INTEGER PYCOMP
C--Common block of Pythia
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2)
&,SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--technical variables for getmass
COMMON/VIOL/FACTOR,NINTV,NVIOLQ,NVSEVQ,NVIOLG,NVSEVG,NEWMC
INTEGER NINTV,NVIOLQ,NVIOLG,NVSEVQ,NVSEVG
DOUBLE PRECISION FACTOR
LOGICAL NEWMC
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--nuclear thickness function
COMMON /THICKFNC/ RMAX,TA(100,2)
DOUBLE PRECISION RMAX,TA
C--mean kt
COMMON/MEANKT/NKT1(20),SUMKT1(20)
INTEGER NKT1
DOUBLE PRECISION SUMKT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--Variables for ntuples
C--Note that you have to use REAL for PAW and HBOOK
CHARACTER*8 INFO(NINFO)
REAL RUN(NINFO)
INTEGER ISTAT,ICYCLE
DATA INFO/'n'/
C--Variables local to this program
INTEGER J,NSIM,I,NOLD,PID,JJ,NSKIPV,NSKIPM,NSKIP2,
&NJET
DOUBLE PRECISION PYR,ENI,QMAXI,PI,R,GETMASS,TMP,Q,GETPROBA,
&PNOSCAT,GETNOSCAT,DELTAT,PYP,D3,ZETA3,X0,Y0,L,X1,X2,Y1,
&Y2,Z,ZVAL,PHI,RAU,X,Y,POWER,PTMIN,PTMAX,ECUT,WEIGHTEX,
&SUMOFWEIGHTS,NDISC,NNULL,GETPDFXINT,GETINSUDAFAST,GETINSUDAKOV,
&GETINSUDARED,GETNEFF,GETTEMP,DX,DY
CHARACTER TYPE1
CHARACTER*2 TYPE2
CHARACTER*80 VERSION,FILENAME,FILENAME2,FILENAME3,FILENAMEIN,
&PDFFILE,XSECFILE
LOGICAL READRAN,CONT,VARYL,ALLHAD,NJETFR,HADRO,PDFEXIST,
&XSECEXIST,WEIGHTED
DATA PI/3.141592653589793d0/
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA VERSION/'JEWEL 3.1.1'/
C--just testing
LOGICAL SCAT,GETDELTAT
DOUBLE PRECISION GETDELTAL,TMAXI
***********************************************************************
*** Read input for simulation from job-file
***********************************************************************
C--Number of simulated events
READ(*,*) NSIM
C--Filename for hb-file
READ(*,'(a)') FILENAME
C--Filename for dat-file
READ(*,'(a)') FILENAME2
C--Output file for random number generator status
READ(*,'(a)') FILENAME3
C--Read random number generator status from file?
READ(*,*) READRAN
C--Input file for random number generator status
READ(*,'(a)') FILENAMEIN
C--Input file for pdf's
READ(*,'(a)') PDFFILE
C PDFFILE='pdfs.100.dat'
C--Input file for cross section integrals
READ(*,'(a)') XSECFILE
C XSECFILE='xsecs.100.dat'
C--number of light flavours
READ(*,*) NF
C--Lambda for parton shower
READ(*,*) LPS
C--Lambda
READ(*,*) LQCD
C--Q_0
READ(*,*) Q0
C--minimum kt in splitting and gluon radiation
READ(*,*) KTMIN
C--initiating parton ID
READ(*,*) PID
C--power of pt-spectrum
READ(*,*) POWER
C--minimum pt
READ(*,*) PTMIN
C--maximum pt
READ(*,*) PTMAX
C--angular ordering?
READ(*,*) ANGORD
C--constrained evolution?
READ(*,*) CONSTR
C--minimum energy for daughters
READ(*,*) MINEN
C--fmed
READ(*,*) FMED
C--temperature
READ(*,*) TEMP
C--nuclear radius
READ(*,*) RAU
C--vary path length?
READ(*,*) VARYL
C--keep recoiling scattering centre in shower?
READ(*,*) KEEPRECOIL
C--use new MC routine?
READ(*,*) NEWMC
C--number of intervals
READ(*,*) NINTV
C--factor
READ(*,*) FACTOR
C--scattering of recoiling scattering centre?
READ(*,*) SCATRECOIL
C--hadronise all particles inlcuding recoiling scattering centres?
READ(*,*) ALLHAD
C--look at n-jet fraction?
READ(*,*) NJETFR
C--hadronise?
READ(*,*) HADRO
C--brick problem?
READ(*,*) BRICK
C--exact solution of splitting integral?
READ(*,*) EXACT
C--veto algorithm?
READ(*,*) VETO
C--weighted events?
READ(*,*) WEIGHTED
C--weight exponent
READ(*,*) WEIGHTEX
IF(BRICK) THEN
HADRO=.FALSE.
SCATRECOIL=.FALSE.
VARYL=.FALSE.
ENDIF
QMIN=SQRT(Q0**2+4.*(KTMIN*LPS)**2)
MD=3.*TEMP
MS=MD/SQRT(2.)
NP=(2.*12.*NF*D3/3.+3.*16.*ZETA3/2.)*TEMP**3/PI**2
C NP=NP*3.d0
C MD=1.
C MS=0.7
C NP=5.11
IF(NF.EQ.0) PID=21
IF(PID.EQ.21)THEN
TYPE1='G'
TYPE2='GC'
ELSE
TYPE1='Q'
TYPE2='QQ'
ENDIF
IF(EXACT) CALL SPLITFNCINT(PTMAX)
CALL EIXINT
CALL INSUDAINT(PTMAX)
INQUIRE(file=PDFFILE,exist=PDFEXIST)
IF(PDFEXIST)THEN
OPEN(unit=10,file=PDFFILE,status='old')
- READ(10,*)QINQ
- READ(10,*)GINQ
- READ(10,*)QING
- READ(10,*)GING
- READ(10,*)QINQX
- READ(10,*)GINQX
- READ(10,*)QINGX
- READ(10,*)GINGX
+ DO 870 I=1,101
+ DO 871 J=1,101
+ READ(10,*)QINQ(I,J),GINQ(I,J),QING(I,J),GING(I,J)
+ 871 CONTINUE
+ 870 CONTINUE
+ DO 872 I=1,101
+ DO 873 J=1,101
+ READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 873 CONTINUE
+ 872 CONTINUE
CLOSE(10,status='keep')
ELSE
CALL PDFINT(PTMAX)
OPEN(unit=10,file=PDFFILE,status='new')
- WRITE(10,*)QINQ
- WRITE(10,*)GINQ
- WRITE(10,*)QING
- WRITE(10,*)GING
- WRITE(10,*)QINQX
- WRITE(10,*)GINQX
- WRITE(10,*)QINGX
- WRITE(10,*)GINGX
+ DO 874 I=1,101
+ DO 875 J=1,101
+ WRITE(10,*)QINQ(I,J),GINQ(I,J),QING(I,J),GING(I,J)
+ 875 CONTINUE
+ 874 CONTINUE
+ DO 876 I=1,101
+ DO 877 J=1,101
+ WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
+ 877 CONTINUE
+ 876 CONTINUE
CLOSE(10,status='keep')
ENDIF
INQUIRE(file=XSECFILE,exist=XSECEXIST)
IF(XSECEXIST)THEN
OPEN(unit=10,file=XSECFILE,status='old')
- READ(10,*)INTQ1
- READ(10,*)INTQ2
- READ(10,*)INTG1
- READ(10,*)INTG2
+ DO 880 I=1,101
+ DO 881 J=1,101
+ READ(10,*)INTQ1(I,J),INTQ2(I,J),INTG1(I,J),INTG2(I,J)
+ 881 CONTINUE
+ 880 CONTINUE
CLOSE(10,status='keep')
ELSE
CALL XSECINT(PTMAX)
OPEN(unit=10,file=XSECFILE,status='new')
- WRITE(10,*)INTQ1
- WRITE(10,*)INTQ2
- WRITE(10,*)INTG1
- WRITE(10,*)INTG2
+ DO 882 I=1,101
+ DO 883 J=1,101
+ WRITE(10,*)INTQ1(I,J),INTQ2(I,J),INTG1(I,J),INTG2(I,J)
+ 883 CONTINUE
+ 882 CONTINUE
CLOSE(10,status='keep')
ENDIF
OPEN(unit=1,file='TAu.dat',status='old')
DO 125 I=1,7
READ(1,*)
125 CONTINUE
DO 124 I=1,100
READ(1,*)TA(I,1),TA(I,2)
124 CONTINUE
CLOSE(1,status='keep')
RMAX=12.6105562
***********************************************************************
*** Initialise hbook
***********************************************************************
C--Open hbook file
CALL HLIMIT(NHBOOK)
CALL HROPEN(1,'test',FILENAME,'N',1024,ISTAT)
C--Book ntuples and histograms
CALL HBOOKN(10,'File information',NINFO,'test',NPRIME,INFO)
CALL HBOOK1(100,'ln(1/xp) parton',100,0.,10.,0.)
CALL HBOOK1(110,'ln(1/xp) hadron',100,0.,10.,0.)
CALL HBOOK1(101,'quarks ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(102,'gluons ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(120,'antiquarks ln(1/xp)',100,0.,10.,0.)
CALL HBOOK1(121,'gluon from gluon',100,0.,10.,0.)
CALL HBOOK1(122,'gluon from quark',100,0.,10.,0.)
CALL HBOOK1(123,'gluon from antiquark',100,0.,10.,0.)
CALL HBOOK1(103,'z',100,0.,1.,0.)
CALL HBOOK1(109,'x',41,0.,1.25,0.)
CALL HBOOK1(104,'E/t all',100,0.,5.,0.)
CALL HBOOK1(105,'mass before first splitting',100,0.,100.,0.)
CALL HBOOK1(106,'# gluons',51,-0.5,50.5,0.)
CALL HBOOK1(107,'parton energy',100,0.,100.,0.)
CALL HBOOK1(108,'virtuality ratio',100,0.,1.,0.)
CALL HBOOK1(115,'kt wrt jet axis',100,0.,10.,0.)
CALL HBOOK1(116,'kt wrt trigger',100,0.,10.,0.)
CALL HBOOK1(117,'theta trig',100,0.,REAL(PI),0.)
CALL HBOOK1(118,'theta wrt jet axis',100,0.,REAL(PI),0.)
CALL HBOOK1(119,'theta wrt trigger',100,0.,REAL(PI),0.)
CALL HBOOK1(130,'energy vs theta (jet)',100,0.,REAL(PI),0.)
CALL HBOOK1(131,'kt wrt trigger trig high',100,0.,10.,0.)
CALL HBOOK1(132,'kt wrt trigger both high',100,0.,10.,0.)
CALL HBOOK1(133,'theta wrt trigger trig high',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(134,'theta wrt trigger both high',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(135,'theta wrt trig both high 2',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(140,'Delta E',200,-100.,100.,0.)
CALL HBOOK1(141,'Delta p',200,-100.,100.,0.)
CALL HBOOK1(142,'Delta Q',210,-1000.,10000.,0.)
CALL HBOOK1(300,'scat. centre E before',100,0.,10.,0.)
CALL HBOOK1(301,'scatt centre E after',100,0.,10.,0.)
CALL HBOOK1(302,'scat. centre pt before',100,0.,10.,0.)
CALL HBOOK1(303,'scatt centre pt after',100,0.,10.,0.)
CALL HBOOK1(304,'scat. centre cos(theta) before',
& 100,-1.,1.,0.)
CALL HBOOK1(305,'scatt centre cos(theta) after',100,-1.,1.,0.)
CALL HBOOK1(306,'scat. centre theta before',
& 100,0.,REAL(PI),0.)
CALL HBOOK1(307,'scatt centre theta after',100,0.,REAL(PI),0.)
CALL HBOOK1(320,'l',100,0.,REAL(2.*RAU),0.)
CALL HBOOK1(321,'energy hadron',100,0.,15.,0.)
CALL HBOOK1(322,'energy parton',100,0.,15.,0.)
CALL HBOOK1(330,'Delta E col',111,-0.05,1.05,0.)
CALL HBOOK1(331,'Delta E rad',111,-0.05,1.05,0.)
CALL HBOOK1(332,'Delta E col+rad',111,-0.05,1.05,0.)
CALL HBOOK1(333,'dN/domega',100,0.,REAL(PTMAX),0.)
CALL HBOOK1(400,'kt triggered wrt trigger',100,0.,10.,0.)
CALL HBOOK1(401,'kt triggered wrt jet 0.5',100,0.,10.,0.)
CALL HBOOK1(402,'kt triggered wrt jet 1',100,0.,10.,0.)
CALL HBOOK1(403,'kt triggered wrt jet 2',100,0.,10.,0.)
CALL HBOOK1(404,'kt triggered wrt jet 5',100,0.,10.,0.)
CALL HBOOK1(405,'kt triggered wrt jet 10',100,0.,10.,0.)
CALL HBOOK1(406,'mean kt above threshold',20,-0.25,9.75,0.)
CALL HBOOK2(407,'mean kt above threshold',
& 20,-0.25,9.75,100,0.,10.,0.)
CALL HBOOK1(444,'string inv. mass',100,0.,100.,0.)
CALL HBOOK2(200,'xi-theta',100,0.,10.,100,0.,REAL(PI),0.)
CALL HBOOK2(210,'E-DE/E',100,0.,100.,100,0.,1.,0.)
CALL HBOOK2(220,'xi-Nscat',100,0.,10.,11,-0.5,10.5,0.)
CALL HBOOK2(601,'1 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(602,'2 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(603,'3 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(604,'4 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(605,'5 jet frac parton',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(611,'1 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(612,'2 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(613,'3 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(614,'4 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(615,'5 jet frac hadron',
& 30,-6.1,-0.1,6,-0.5,5.5,0.)
CALL HBOOK2(708,'thrust parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(703,'thrust major parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(704,'thrust minor parton',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(718,'thrust hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(713,'thrust major hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(714,'thrust minor hadron',100,0.,1.,6,-0.5,5.5,0.)
CALL HBOOK2(800,'pt - theta after',100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(801,'E - theta after',100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(802,'pt - theta after hadro',
& 100,0.,10.,100,-1.,1.,0.)
CALL HBOOK2(803,'E - theta after hadro',
& 100,0.,10.,100,-1.,1.,0.)
C--jkl
CALL HBOOK2(201,'prod. point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(202,'scattering point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(204,'spl. point',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(207,'particle vertex',
&100,-20.,20.,100,-20.,20.,0.)
CALL HBOOK2(250,'prod. momentum',
&100,-1.5*REAL(PTMAX),1.5*REAL(PTMAX),
&100,-1.5*REAL(PTMAX),1.5*REAL(PTMAX),0.)
CALL HBOOK1(251,'prod. energy',
&100,0.,1.5*REAL(PTMAX),0.)
CALL HBOOK1(900,'delta t',100,0.,10.,0.)
CALL HBOOK1(901,'delta l',100,0.,10.,0.)
CALL HBOOK2(910,'medium temp.',200,-2.*REAL(RAU),2.*REAL(RAU),
& 200,-2.*REAL(RAU),2.*REAL(RAU),0.)
CALL HBOOK1(911,'medium density',100,0.,1.1*REAL(RAU),0.)
CALL HBOOK1(920,'pnoscat dt',100,0.,1.,0.)
CALL HBOOK1(921,'pnoscat',100,0.,1.,0.)
CALL HBOOK1(922,'diff pnoscat',100,-1.,1.,0.)
CALL HBOOK1(930,'deltat',100,0.,10.,0.)
CALL HBOOK1(931,'deltal',100,0.,10.,0.)
C--Call PYR once for initialization
R=PYR(0)
C--initialise medium and produce some plots
CALL MEDINIT
CALL MEDNEXTEVT
DX=2.*RAU/100.d0
DY=2.*RAU/100.d0
DO 75 I=1,200
DO 76 JJ=1,200
CALL HF2(910,REAL(-2.d0*RAU-DX/2.d0+I*DX),
&REAL(-2.d0*RAU-DY/2.d0+JJ*DY),
&REAL(GETTEMP(-2.d0*RAU+I*DX-DX/2.d0,
&-2.d0*RAU+JJ*DY-DY/2.d0,0.d0,0.9d0)))
76 CONTINUE
75 CONTINUE
DO 79 I=1,100
CALL HF1(911,REAL((I-0.5)*1.1d0*RAU/100.d0),
&REAL(GETNEFF(0.D0,0.D0,0.D0,I*1.1d0*RAU/100.d0)))
79 CONTINUE
C--read random number generator from file if desired
IF(READRAN)THEN
OPEN(unit=2,file=FILENAMEIN,access='sequential',
& form='unformatted',status='old')
CALL PYRSET(2,0)
CLOSE(2,status='keep')
WRITE(*,*) 'read random number generator status'
ENDIF
C--write random number generator state to file
OPEN(unit=2,file=FILENAME3,access='sequential',
& form='unformatted',status='unknown')
CALL PYRGET(2,0)
NDISC=0.d0
NNULL=0.d0
C--switch off pi0 decay
MDCY(PYCOMP(111),1)=0
C MSTJ(1)=2
C MSTJ(2)=3
C MSTJ(3)=0
C MSTJ(14)=1
C--parameters for cluster finding algorithm
MSTU(41)=2
MSTU(42)=2
MSTU(46)=6
MSTU(47)=1
DO 77 JJ=1,20
NKT1(JJ)=0
SUMKT1(JJ)=0.d0
77 CONTINUE
SUMOFWEIGHTS=0.d0
NSCAT=0.d0
NSPLIT=0.d0
DELTAECOLTOT=0.d0
DELTAERADTOT=0.d0
LSUM=0.d0
TSUMCOH=0.d0
TSUMINCOH=0.d0
DO 100 J=1,NSIM
DELTAECOL=0.d0
DELTAERAD=0.d0
DISCARD=.FALSE.
DO 91 I=1,5000
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
91 CONTINUE
CALL MEDNEXTEVT
C--pick a pt for the initiating parton
R=PYR(0)
ENI=(PTMIN**(1.-POWER)*(1.-R)
& +PTMAX**(1.-POWER)*R)**(1./(1.-POWER))
QMAXI=ENI
IF(WEIGHTED)THEN
EVWEIGHT=REAL(ENI**(WEIGHTEX-POWER))
ELSE
EVWEIGHT=1.
ENDIF
SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT
CALL PICKVTX(X0,Y0)
LTIME=RAU
C--just some testing
IF(.FALSE.)THEN
DO 1328 I=1,100000
K(1,2)=21
P(1,1)=0.D0
P(1,2)=0.D0
P(1,3)=10.D0
P(1,4)=10.D0
P(1,5)=0.D0
TMAXI=0.5d0
SCAT=GETDELTAT(1,0.D0,TMAXI,.FALSE.,.TRUE.,DX,DY)
DY=GETDELTAL(P(1,4),P(1,5),0.d0,TMAXI,'G',PYP(1,8)/P(1,4))
IF(SCAT)CALL HF1(930,REAL(DX),1.)
CALL HF1(931,REAL(DY),1.)
1328 CONTINUE
ENDIF
C--store standard quark or gluon in the event record
N=2
K(N,1)=1
K(N,2)=PID
K(N,3)=0
K(N,4)=0
K(N,5)=0
P(N,4)=ENI
C--find virtuality
IF(BRICK)THEN
P(N,5)=0.d0
ELSE
P(N,5)=GETMASS(0.d0,QMAXI,1.d0,1.d0,P(N,4),
& TYPE2,QMAXI,0.d0,.FALSE.)
ENDIF
CALL HF1(105,REAL(P(N,5)),EVWEIGHT)
IF(P(N,5).EQ.0.d0) NNULL=NNULL+EVWEIGHT
P(N,1)=SQRT(P(N,4)**2-P(N,5)**2)
P(N,2)=0.
P(N,3)=0.
CALL HF2(250,REAL(P(N,1)),REAL(P(N,2)),1.)
CALL HF1(251,REAL(P(N,4)),1.)
MV(N,1)=X0
MV(N,2)=Y0
MV(N,3)=0.
MV(N,4)=0.d0
IF(P(N,5).GT.0.d0)THEN
MV(N,5)=ENI*0.2/P(N,5)**2
ELSE
MV(N,5)=LTIME
ENDIF
CALL HF2(201,REAL(MV(N,1)),REAL(MV(N,2)),1.)
ZA(N)=1.d0
C--develop parton shower
CALL MAKECASCADE
C CALL MAKEBRANCH(2)
C WRITE(*,*)'makecascade done'
IF(DISCARD) THEN
NDISC=NDISC+EVWEIGHT
C CALL PYLIST(3)
IF(N.EQ.2) CALL HF1(135,REAL(P(2,5)),EVWEIGHT)
WRITE(*,*)'discard event',J
WRITE(*,*)'ltime=',LTIME
GOTO 102
ELSE
CALL HF1(125,REAL(P(2,5)),EVWEIGHT)
ENDIF
CALL HF1(330,REAL(DELTAECOL/ENI),EVWEIGHT)
CALL HF1(331,REAL(DELTAERAD/ENI),EVWEIGHT)
CALL HF1(332,REAL((DELTAECOL+DELTAERAD)/ENI),EVWEIGHT)
C-- copy and check the vertices of all particles (debugging)
DO 111 I=2,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)
CALL HF2(207,REAL(MV(I,1)),REAL(MV(I,2)),EVWEIGHT)
111 CONTINUE
IF(.NOT.ALLHAD)THEN
DO 86 I=1,N
IF(K(I,1).EQ.3) K(I,1)=22
86 CONTINUE
ENDIF
C IF(.NOT.HADRO) CALL SHOWANA(ENI)
DO 81 JJ=1,6
ECUT=(JJ-1)*1.d0
DO 82 I=1,N
IF((K(I,1).EQ.1).AND.(P(I,4).LT.ECUT)) K(I,1)=19
IF((K(I,1).EQ.3).AND.(P(I,4).LT.ECUT)) K(I,1)=20
82 CONTINUE
IF(NJETFR)THEN
CALL NJETANA(JJ,.TRUE.,ENI)
ELSE
CALL EVSHAPEANA(JJ,.TRUE.,ENI)
ENDIF
81 CONTINUE
DO 83 I=1,N
IF(K(I,1).EQ.19) K(I,1)=1
IF(K(I,1).EQ.20) K(I,1)=3
83 CONTINUE
IF(HADRO)THEN
CALL MAKESTRINGS
CALL PYEXEC
DO 80 I=1,N
IF(K(I,2).EQ.92) CALL HF1(444,REAL(P(I,5)),EVWEIGHT)
IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3)).AND.
& (ABS(PYP(I,19)).GT.1.))
& K(I,1)=23
80 CONTINUE
C CALL SHOWANA(ENI)
DO 90 I=1,N
IF(K(I,1).LT.11) THEN
CALL HF2(802,REAL(PYP(I,10)),REAL(P(I,1)/PYP(I,8)),EVWEIGHT)
CALL HF2(803,REAL(P(I,4)),REAL(P(I,1)/PYP(I,8)),EVWEIGHT)
ENDIF
90 CONTINUE
DO 84 JJ=1,6
ECUT=(JJ-1)*1.d0
DO 85 I=1,N
IF((K(I,1).EQ.1).AND.(P(I,4).LT.ECUT)) K(I,1)=19
IF((K(I,1).EQ.3).AND.(P(I,4).LT.ECUT)) K(I,1)=20
85 CONTINUE
IF(NJETFR)THEN
CALL NJETANA(JJ,.FALSE.,ENI)
ELSE
CALL EVSHAPEANA(JJ,.FALSE.,ENI)
ENDIF
84 CONTINUE
DO 87 I=1,N
IF(K(I,1).EQ.19) K(I,1)=1
IF(K(I,1).EQ.20) K(I,1)=3
87 CONTINUE
ENDIF
CALL SHOWANA(ENI)
C--write message to log-file
102 IF(NSIM.GT.100)THEN
IF(MOD(J,NSIM/100).EQ.0)THEN
WRITE(*,*) 'event number ',J,' completed'
C--write random number generator state to file
CALL PYRGET(2,-1)
CALL FLUSH
ENDIF
ELSE
WRITE(*,*) 'event number ',J,' completed'
CALL FLUSH
C CALL PYLIST(3)
C--write random number generator state to file
CALL PYRGET(2,-1)
ENDIF
C--next event
100 CONTINUE
***********************************************************************
*** Finish
***********************************************************************
DO 78 JJ=1,20
IF(NKT1(JJ).GT.0)
& CALL HF1(406,(JJ-1)/2.,REAL(SUMKT1(JJ)/NKT1(JJ)))
78 CONTINUE
WRITE(*,*)
WRITE(*,*)'mean number of scatterings:',
& NSCAT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean number of splittings:',
& NSPLIT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean collisional energy loss:',
& DELTAECOLTOT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean radiative energy loss:',
& DELTAERADTOT/(SUMOFWEIGHTS-NDISC)
WRITE(*,*)'mean that incoherent:',-TSUMINCOH/LSUM,' GeV^2/fm'
WRITE(*,*)'mean that coherent:',-TSUMCOH/LSUM,' GeV^2/fm'
WRITE(*,*)
WRITE(*,*)'number of discarded events: ',NDISC
WRITE(*,*)'number of events without splitting: ',NNULL
C--Fill the run information ntuple
RUN(1)=SUMOFWEIGHTS-NDISC
CALL HFN(10,RUN)
C--Write histograms to file and close it
CALL HROUT(0,ICYCLE,'T')
CALL HREND('test')
CLOSE(1)
C--write parameters to dat-file
OPEN(unit=1,file=FILENAME2,status='unknown')
READ(1,*)
WRITE(1,'(A20,A)') 'version: ',VERSION
WRITE(1,'(A20,A)') 'filename: ',FILENAME
WRITE(1,'(A20,L10)')'readran: ',READRAN
IF(READRAN) WRITE(1,'(A20,A)') 'filename: ',FILENAMEIN
WRITE(1,'(A20,A)') 'pdf file: ',PDFFILE
WRITE(1,'(A20,A)') 'cross section file: ',XSECFILE
WRITE(1,'(A20,I10)') 'nsim: ',NSIM
WRITE(1,'(A20,I10)') 'nf: ',NF
WRITE(1,'(A20,F10.2)') 'Lambda(ps):',LPS
WRITE(1,'(A20,F10.2)') 'Lambda: ',LQCD
WRITE(1,'(A20,F10.2)') 'Q_0: ',Q0
WRITE(1,'(A20,F10.2)') 'ktmin: ',KTMIN
WRITE(1,'(A20,I10)') 'pid: ',PID
WRITE(1,'(A20,F10.2)') 'power: ',POWER
WRITE(1,'(A20,F10.2)') 'ptmin: ',PTMIN
WRITE(1,'(A20,F10.2)') 'ptmax: ',PTMAX
WRITE(1,'(A20,L10)') 'angord: ',ANGORD
WRITE(1,'(A20,L10)') 'constr: ',CONSTR
WRITE(1,'(A20,F10.2)') 'Emin: ',MINEN
WRITE(1,'(A20,F10.2)') 'f_med: ',FMED
WRITE(1,'(A20,F10.2)') 'temp: ',TEMP
WRITE(1,'(A20,F10.2)') 'mD: ',MD
WRITE(1,'(A20,F10.2)') 'ms: ',MS
WRITE(1,'(A20,F10.2)') 'nP: ',NP
WRITE(1,'(A20,F10.2)') 'Rau: ',RAU
WRITE(1,'(A20,L10)') 'varyl: ',VARYL
WRITE(1,'(A20,L10)') 'keeprecoil:',KEEPRECOIL
WRITE(1,'(A20,L10)') 'newmc: ',NEWMC
WRITE(1,'(A20,I10)') 'nintv: ',NINTV
WRITE(1,'(A20,F10.2)') 'factor: ',FACTOR
WRITE(1,'(A20,L10)') 'scatrecoil: ',SCATRECOIL
WRITE(1,'(A20,L10)') 'allhad: ',ALLHAD
WRITE(1,'(A20,L10)') 'njetfr: ',NJETFR
WRITE(1,'(A20,L10)') 'hadro: ',HADRO
WRITE(1,'(A20,L10)') 'brick: ',BRICK
WRITE(1,'(A50,L10)') 'exact split. int.: ',EXACT
WRITE(1,'(A50,L10)') 'veto algorithm: ',VETO
WRITE(1,'(A50,L10)') 'weighted events: ',WEIGHTED
WRITE(1,'(A20,F10.2)') 'weight exponent: ',WEIGHTEX
WRITE(1,*)
WRITE(1,*)
WRITE(1,*)'mean number of scatterings:',NSCAT/(NSIM-NDISC)
WRITE(1,*)'mean number of splittings:',NSPLIT/(NSIM-NDISC)
WRITE(1,*)'mean collisional energy loss:',
& DELTAECOLTOT/(NSIM-NDISC)
WRITE(1,*)'mean radiative energy loss:',
& DELTAERADTOT/(NSIM-NDISC)
WRITE(1,*)'mean that incoherent:',-TSUMINCOH/LSUM,' GeV^2/fm'
WRITE(1,*)'mean that coherent:',-TSUMCOH/LSUM,' GeV^2/fm'
WRITE(1,*)
WRITE(1,*)'number of discarded events: ',NDISC*NSIM/SUMOFWEIGHTS
WRITE(1,*)'number of events without splitting: ',
& NNULL*NSIM/SUMOFWEIGHTS
CLOSE(1,status='keep')
DO 200 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)
200 CONTINUE
IF(.NOT.DISCARD) CALL PYLIST(3)
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 MAKESTRINGS
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--local variables
INTEGER NOLD,I,J,LMAX,LMIN,LEND,LSTART,PARENT,LTMP
DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR
DATA MCUT/1.d8/
DATA EADDEND/10.d0/
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(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4))
& .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) RETURN
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-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
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 CALL PYLIST(2)
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))
& .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
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
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
END
***********************************************************************
*** subroutine makecascade
***********************************************************************
*** manages the parton shower, i.e. finds all partons that still
*** may evolve and calls makebranch for them
***********************************************************************
SUBROUTINE MAKECASCADE
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--finished with parton
COMMON/DONEP/DONE(4000)
LOGICAL DONE
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--local variables
INTEGER NOLD,I
LOGICAL CONT
CALL MAKEBRANCH(2)
C WRITE(*,*)'makebranch(2) done'
IF(BRICK) RETURN
IF(DISCARD) GOTO 12
10 NOLD=N
CONT=.FALSE.
DO 11 I=2,NOLD
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.
C WRITE(*,*)'call makebranch(',I,')'
CALL MAKEBRANCH(I)
C WRITE(*,*)'makebranch(',I,') done'
IF(DISCARD) GOTO 12
ENDIF
11 CONTINUE
IF(CONT) GOTO 10
12 END
***********************************************************************
*** subroutine makebranch
***********************************************************************
*** develops a single parton until it cannot split or scatter
*** any more
***********************************************************************
SUBROUTINE MAKEBRANCH(L)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER L,LINE,NLINE,NOLD,I,TYPI,LINEOLD
DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,GETNOSCAT,STARTTIME,TLEFT,
&PNOSCAT,PNOSCAT2,TSUM,R,PYR,DELTAT,NEWMASS,GETMASS,Q,
&QSUMOLD2,GETNEWMASS,GETDELTAL,X,GETTEMP,GETNEFF,DT,XSC,YSC,ZSC
LOGICAL OVERQ2
CHARACTER TYP
LOGICAL RADIATION,RETRYSPLIT,GETDELTAT,NOSCAT
C WRITE(*,*)'*************************************************'
C WRITE(*,*)'start makebranch for line ',L
LINE=L
NSTART=0
NEND=0
STARTTIME=MV(LINE,4)
TSUM=0.d0
QSUM2=0.d0
QSUMOLD2=0.d0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
C 20 WRITE(*,*)'go in next iteration: L= ',LINE
C WRITE(*,*)'qsum^2= ',QSUM2
C WRITE(*,*)'Nend= ',NEND,' ; Nstart= ',NSTART
C DO 201 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 201 CONTINUE
C CALL PYLIST(3)
C IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
20 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(P(LINE,5).GT.MS)))THEN
C--jkl ??? why use mass instead of virtuality for formtime?
FORMTIME=MIN(0.2*P(LINE,4)/P(LINE,5)**2,LTIME-STARTTIME)
RADIATION=.TRUE.
ELSE
FORMTIME=LTIME-STARTTIME
RADIATION=.FALSE.
ENDIF
TLEFT=FORMTIME-TSUM
IF(K(LINE,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
C WRITE(*,*)'formation time: ',FORMTIME
C WRITE(*,*)'remaining time: ',TLEFT
C WRITE(*,*)'starting time: ',STARTTIME
C WRITE(*,*)'tsum: ',TSUM
XSC=MV(LINE,1)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,3)/P(LINE,4)
IF(TLEFT.LE.1.d-10.OR.
&GETTEMP(XSC,YSC,ZSC,STARTTIME+TSUM).LE.0.1D0)THEN
C--no scattering
C WRITE(*,*)'no scattering'
IF(RADIATION)THEN
C--if there is radiation associated with the parton then form it now
C WRITE(*,*)'there is radiation'
TSUMCOH=TSUMCOH+QSUM2
LSUM=LSUM+TSUM+TLEFT
MV(LINE,5)=STARTTIME+0.2*P(LINE,4)/P(LINE,5)**2
C--rotate such that momentum points in z-direction
NOLD=N
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)/P(LINE,4)
MV(N-1,2)=MV(LINE,2)+(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/P(LINE,4)
MV(N-1,3)=MV(LINE,3)+(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/P(LINE,4)
MV(N, 1)=MV(LINE,1)+(MV(N, 4)-MV(LINE,4))*P(LINE,1)/P(LINE,4)
MV(N, 2)=MV(LINE,2)+(MV(N, 4)-MV(LINE,4))*P(LINE,2)/P(LINE,4)
MV(N, 3)=MV(LINE,3)+(MV(N, 4)-MV(LINE,4))*P(LINE,3)/P(LINE,4)
CALL HF2(204,REAL(MV(N,1)),REAL(MV(N,2)),EVWEIGHT)
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
C WRITE(*,*)'there is no radiation'
C WRITE(*,*)'nothing to be done'
TSUMCOH=TSUMCOH+QSUM2
LSUM=LSUM+TSUM+TLEFT
NSTART=0
NEND=0
STARTTIME=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 WRITE(*,*)'do scattering'
C--find delta t for the scattering
DELTAT=TLEFT
OVERQ2=.FALSE.
C WRITE(*,*)'call DOINSTATESCAT for',
C & LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,OVERQ2
CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT,OVERQ2)
C WRITE(*,*)'done'
TSUM=TSUM+DELTAT
C WRITE(*,*)'x,Q,delta t,t_eff= ',X,Q,DELTAT,QSUM2
C WRITE(*,*)'Nstart, Nend= ',NSTART,NEND
C WRITE(*,*)'overQ^2= ',OVERQ2
IF(LINE.EQ.2) CALL HF1(109,REAL(X),EVWEIGHT)
C--do initial state splitting if there is one
NOLD=N
25 IF(X.LT.1.d0) THEN
C WRITE(*,*)'CALL MAKEINSPLIT',LINE,X,QSUM2,Q,TYPI,STARTTIME
CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME)
C WRITE(*,*)'done'
LINEOLD=LINE
LINE=N
NEWMASS=MAX(0.d0,P(LINE,5))
ELSE
NEWMASS=P(LINE,5)
IF(NEND.GT.0)THEN
C WRITE(*,*)'call DOFISTATESCAT for',
C & LINE,STARTTIME+TSUM,DELTAT,NEWMASS,OVERQ2
CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,DELTAT,NEWMASS,OVERQ2)
C WRITE(*,*)'done'
TSUM=TSUM+DELTAT
C WRITE(*,*)'Nstart, Nend= ',NSTART,NEND
ENDIF
ENDIF
C WRITE(*,*)'new mass, old mass= ',NEWMASS,P(LINE,5)
C--do kinematics
RETRYSPLIT=.FALSE.
IF((NEND.GT.0).AND.(-QSUM2.GT.P(LINE,5)**2)) THEN
CALL DOKINEMATICS(LINE,NSTART,NEND,NEWMASS,RETRYSPLIT)
IF(RETRYSPLIT) THEN
C WRITE(*,*)'retry splitting, new line:',LINEOLD
N=NOLD
LINE=LINEOLD
X=1.d0
K(LINE,1)=1
GOTO 25
ELSE
LINE=N
ENDIF
ENDIF
IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE.
ENDIF
21 XSC=MV(LINE,1)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(STARTTIME+TSUM-MV(LINE,4))*P(LINE,3)/P(LINE,4)
IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0))
& .OR.((K(LINE,1).EQ.2).AND.(P(LINE,5).GT.MS))
& .OR.((STARTTIME.LT.LTIME).AND.
&GETTEMP(XSC,YSC,ZSC,STARTTIME+TSUM).GE.
&0.1D0))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.(P(LINE,5).LE.MS)) K(LINE,1)=4
C WRITE(*,*)'makebranch: we are done, line ',LINE
C DO 202 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 202 CONTINUE
C CALL PYLIST(3)
C WRITE(*,*)'*************************************************'
END
***********************************************************************
*** subroutine makesplitting
***********************************************************************
*** performs splitting of parton on line l of the event record
***********************************************************************
SUBROUTINE MAKESPLITTING(L)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER L,COUNTER,COUNTER2,COUNTB,COUNTC
DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,BMAX,CMAX,
&PTS,MB,MC,GETMASS,PZ,EPS,QH,Z,DELTAT,R,PNOSCAT,GETNOSCAT,
&CMAX1,BET2
LOGICAL QUARK,QQBAR,IFQQBAR
DATA PI/3.141592653589793d0/
C WRITE(*,*)'start makesplitting, L=',L
COUNTER2=0
COUNTER=0
C--on-shell partons cannot split
C IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12)) GOTO 31
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)) GOTO 31
C--quark or gluon?
IF(ABS(K(L,2)).EQ.1)THEN
QUARK=.TRUE.
QQBAR=.FALSE.
ELSE
QUARK=.FALSE.
ENDIF
C--if gluon decide on kind of splitting
IF(.NOT.QUARK)THEN
IF(NF.EQ.0)THEN
QQBAR=.FALSE.
ELSE
QQBAR=IFQQBAR(P(L,5),P(K(L,3),5),ZA(L),P(L,4),MV(L,5))
ENDIF
ENDIF
C--generate z value
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(*,*)L,': reject event: angular ordering
& conflict in medium'
CALL PYLIST(3)
DISCARD=.TRUE.
GOTO 31
ENDIF
EPS=0.5-0.5*SQRT(1-QH)
ELSE
EPS=0d0
ENDIF
32 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
C WRITE(*,*)'z=',Z
CALL HF1(103,REAL(Z),EVWEIGHT)
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--additional constraint if angular ordering is active
IF(ANGORD)THEN
BMAX=MIN(SQRT(Z*P(L,5)**2/(4.*(1.-Z))),BMAX1)
CMAX=MIN(SQRT((1.-Z)*P(L,5)**2/(4.*Z)),CMAX1)
ELSE
BMAX=BMAX1
CMAX=CMAX1
ENDIF
C--generate mass of quark or gluon (particle b) from Sudakov FF
30 IF(QUARK.OR.QQBAR)THEN
MB=GETMASS(0.d0,BMAX1,P(L,5),Z,Z*P(L,4),'QQ',
& BMAX,MV(L,5),.FALSE.)
ELSE
MB=GETMASS(0.d0,BMAX1,P(L,5),Z,Z*P(L,4),'GC',
& BMAX,MV(L,5),.FALSE.)
ENDIF
C WRITE(*,*)'mb=',MB
C--generate mass gluon (particle c) from Sudakov FF
34 IF(QUARK.OR.(.NOT.QQBAR))THEN
MC=GETMASS(0.d0,CMAX1,P(L,5),1.-Z,(1.-Z)*P(L,4),'GC',
& CMAX,MV(L,5),.FALSE.)
ELSE
MC=GETMASS(0.d0,CMAX1,P(L,5),1.-Z,(1.-Z)*P(L,4),'QQ',
& CMAX,MV(L,5),.FALSE.)
ENDIF
C WRITE(*,*)'mc=',MC
C--quark (parton b) momentum
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
IF((PTS.LT.0.d0).OR.((MB+MC).GT.P(L,5)))THEN
C WRITE(*,*)'reject mb and mc value'
COUNTER=COUNTER+1
C--discard events if no appropriate values can be found
IF(COUNTER.GT.5000)THEN
WRITE(*,*)'reject event in makesplitting'
WRITE(*,*)'l=',L
WRITE(*,*)'E=',P(L,4)
WRITE(*,*)'m=',P(L,5)
WRITE(*,*)'p=',P(L,3)
WRITE(*,*)'Qa=',P(K(L,3),5)
WRITE(*,*)'za=',ZA(L)
WRITE(*,*)'z=',Z
DISCARD=.TRUE.
GOTO 31
ELSE
GOTO 30
ENDIF
ENDIF
N=N+2
IF(N.GT.4990) THEN
WRITE(*,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
C--take care of first daughter (radiated gluon or antiquark)
K(N-1,1)=K(L,1)
IF(QQBAR)THEN
K(N-1,2)=-1
ELSE
K(N-1,2)=21
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
C--take care of second daughter (final quark or gluon or quark from
C gluon splitting)
K(N,1)=K(L,1)
IF(QUARK)THEN
K(N,2)=K(L,2)
ELSEIF(QQBAR)THEN
K(N,2)=1
ELSE
K(N,2)=21
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
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
C MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2*(1./P(N-1,5)**2-1./CMAX1**2)
MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2/P(N-1,5)**2
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
C MV(N,5)=MV(L,5)+P(N,4)*0.2*(1./P(N,5)**2-1./BMAX1**2)
MV(N,5)=MV(L,5)+P(N,4)*0.2/P(N,5)**2
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.-Z
ZA(N)=Z
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
IF(BRICK)THEN
DELTAERAD=DELTAERAD+P(N-1,4)
DELTAERADTOT=DELTAERADTOT+P(N-1,4)
CALL HF1(333,REAL(P(N-1,4)),EVWEIGHT)
ELSE
IF(MV(L,5).LT.LTIME)THEN
R=PYR(0)
IF(R.LT.(FMED/(1.+FMED))) THEN
DELTAERAD=DELTAERAD+P(L,4)-P(N,4)
DELTAERADTOT=DELTAERADTOT+P(L,4)-P(N,4)
ENDIF
ENDIF
ENDIF
C 31 WRITE(*,*)'makesplitting: we are done, N=',N
C END
31 END
SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--local variables
INTEGER L,TYPI,NOLD
DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI,
&PHIQ,PYP,PYR,R,TIME,MB2MAX,TSUM
CHARACTER*2 TYP2,TYPC
DATA PI/3.141592653589793d0/
MV(L,5)=TIME
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 WRITE(*,*)'+++++++++++++++++++++++++++++++++++++++++++++++++++'
C CALL PYLIST(2)
C WRITE(*,*)'TYP2=',TYP2
MB2=VIRT**2
C WRITE(*,*)'Mb^2=',MB2
MB2=P(L,5)**2-MB2
C WRITE(*,*)'Mb^2=',MB2
MC2=GETMASS(0.d0,MIN(SQRT(-TSUM),(1.-X)*P(L,4)),1.d0,1.d0,
& (1.-X)*P(L,4),TYPC,MIN(SQRT(-TSUM),(1.-X)*P(L,4)),
& TIME,.FALSE.)**2
C WRITE(*,*)'Mc^2=',MC2
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
C WRITE(*,*)'kt^2=',KT2
IF(KT2.LT.0.d0)THEN
MC2=0.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
C WRITE(*,*)'initial state splitting has to be rejected'
IF(KT2.LT.0.d0)THEN
CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0)
RETURN
ENDIF
ENDIF
N=N+2
C--take care of first daughter (radiated gluon or antiquark)
K(N-1,1)=K(L,1)
IF(TYP2.EQ.'QG')THEN
K(N-1,2)=-1
ELSE
K(N-1,2)=21
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)
IF(TYPI.NE.21)THEN
K(N,2)=K(L,2)
ELSEIF(TYP2.EQ.'QG')THEN
K(N,2)=1
ELSE
K(N,2)=21
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(N-1,4)=MV(L,5)
IF(P(N-1,5).GT.0.d0)THEN
C MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2*(1./P(N-1,5)**2-1./CMAX1**2)
MV(N-1,5)=MV(L,5)+P(N-1,4)*0.2/P(N-1,5)**2
ELSE
MV(N-1,5)=0.d0
ENDIF
MV(N,4)=MV(L,5)
IF(P(N,5).GT.0.d0)THEN
C MV(N,5)=MV(L,5)+P(N,4)*0.2*(1./P(N,5)**2-1./BMAX1**2)
MV(N,5)=MV(L,5)+P(N,4)*0.2/P(N,5)**2
ELSE
MV(N,5)=0.d0
ENDIF
ZA(N-1)=1.d0
ZA(N)=1.d0
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
IF(BRICK)THEN
DELTAERAD=DELTAERAD+P(N-1,4)
DELTAERADTOT=DELTAERADTOT+P(N-1,4)
CALL HF1(333,REAL(P(N-1,4)),EVWEIGHT)
ELSE
IF(MV(L,5).LT.LTIME)THEN
R=PYR(0)
IF(R.LT.(FMED/(1.+FMED))) THEN
DELTAERAD=DELTAERAD+P(L,4)-P(N,4)
DELTAERADTOT=DELTAERADTOT+P(L,4)-P(N,4)
ENDIF
ENDIF
ENDIF
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)/P(L,4)
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/P(L,4)
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/P(L,4)
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/P(L,4)
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/P(L,4)
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/P(L,4)
C CALL PYLIST(2)
C WRITE(*,*)'+++++++++++++++++++++++++++++++++++++++++++++++++++'
END
SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--local variables
INTEGER L,I,TYPI
DOUBLE PRECISION X,DELTAT,DELTAL,GETDELTAL,PYP,PYR,R,PNORAD,
&GETPNORAD1,TAU,PNOSCAT,GETNOSCAT,WEIGHT,LOW,FMAX,GETPDF,
&SIGMATOT,GETSSCAT,GETINSUDAFAST,PFCHANGE,PI,TNOW,TLEFT,XMAX,
&PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS,
&GENERATEZ,TMAX,DELTATFIRST,TMAXNEW,DT,PNOSCAT2
LOGICAL FCHANGE,NORAD,OVERQ2,FIRST,NOSCAT,GETDELTAT
CHARACTER TYP
CHARACTER*2 TYP2
DATA PI/3.141592653589793d0/
C WRITE(*,*)'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
C WRITE(*,*)'start DOINSTATESCAT for',L,X,TYPI,Q,DELTAT
+C WRITE(*,*)'p(L)=',P(L,1),P(L,2),P(L,3),P(L,4),P(L,5)
PNORAD=GETPNORAD1(L)
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,5),'G','C',MS,MD)
- IF(SIGMATOT.EQ.0.d0)THEN
- PFCHANGE=-1.d0
+ SIGMATOT=GETSSCAT(P(L,4),P(L,5),MAX(Q0,P(L,5)),'G','C',MS,MD)
+ IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
+ PFCHANGE=0.d0
ELSE
- PFCHANGE=GETSSCAT(P(L,4),P(L,5),'G','Q',MS,MD)/
- &(SIGMATOT*(1.-PNORAD))
+ PFCHANGE=GETSSCAT(P(L,4),P(L,5),MAX(Q0,P(L,5)),'G','Q',MS,MD)
+ & /SIGMATOT
ENDIF
+ SIGMATOT=GETSSCAT(P(L,4),P(L,5),0.d0,'G','C',MS,MD)
ELSE
TYP='Q'
TYP2='QQ'
- SIGMATOT=GETSSCAT(P(L,4),P(L,5),'Q','C',MS,MD)
- IF(SIGMATOT.EQ.0.d0)THEN
- PFCHANGE=-1.d0
+ SIGMATOT=GETSSCAT(P(L,4),P(L,5),MAX(Q0,P(L,5)),'Q','C',MS,MD)
+ IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN
+ PFCHANGE=0.d0
ELSE
- PFCHANGE=GETSSCAT(P(L,4),P(L,5),'Q','G',MS,MD)/
- &(SIGMATOT*(1.-PNORAD))
+ PFCHANGE=GETSSCAT(P(L,4),P(L,5),MAX(Q0,P(L,5)),'Q','G',MS,MD)
+ & /SIGMATOT
ENDIF
+ SIGMATOT=GETSSCAT(P(L,4),P(L,5),0.d0,'Q','C',MS,MD)
ENDIF
+ IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN
+ WRITE(*,*)'error: flavour change probability=',PFCHANGE,'for ',TYP
+ ENDIF
IF(PYR(0).LT.PFCHANGE)THEN
FCHANGE=.TRUE.
ELSE
FCHANGE=.FALSE.
ENDIF
C WRITE(*,*)'type :',TYP
C WRITE(*,*)'flavour change probability:',PFCHANGE,FCHANGE
C--decide whether there will be radiation
- IF(PYR(0).LT.PNORAD)THEN
+ IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*QMIN))THEN
NORAD=.TRUE.
ELSE
NORAD=.FALSE.
ENDIF
C WRITE(*,*)'P_norad :',PNORAD,NORAD
LOW=MAX(Q0**2,P(L,5)**2)
TMAX=2.*MS*(P(L,4)-P(L,5))
XMAX=1.-Q0**2/(4.*TMAX)
C WRITE(*,*)'xmax :',XMAX
C WRITE(*,*)'tmax :',TMAX
C WRITE(*,*)'low :',LOW
C--pick a x value from splitting function
C 112 WRITE(*,*)
C IF(TYP.EQ.'G')THEN
112 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
C--estimate formation time
TAU=0.2*X*P(L,4)/MAX(Q0**2,P(L,5)**2)
IF(SIGMATOT.EQ.0.d0) GOTO 116
C WRITE(*,*)'x,tau =',X,TAU
TLEFT=MIN(DELTAT,TAU)
TNOW=TSTART
TSUM=0.d0
NSTART=0
NEND=0
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
OVERQ2=.FALSE.
Q=0.d0
QOLD=0.d0
FIRST=.TRUE.
C WRITE(*,*)'new attempt: qsum^2, overQ^2=',QSUM2,OVERQ2
C--find number, position and momentum transfers of scatterings
DO 111 I=1,1000
C WRITE(*,*)'tleft=',TLEFT
IF(FIRST)THEN
- PNOSCAT=0.d0
NOSCAT=.FALSE.
DELTATFIRST=TLEFT
NOSCAT=.NOT.GETDELTAT(L,TNOW,TLEFT,.TRUE.,.TRUE.,
&DELTAL,PNOSCAT2)
C-- if no chance to scatter, stop
IF(PNOSCAT2.GE.(1.d0-1.D-10))THEN
WRITE(*,*)'DOINSTATESCAT: cannot scatter here',TNOW,TLEFT
GOTO 116
ENDIF
ELSE
-C PNOSCAT=1.d0
+C NOSCAT=.TRUE.
NOSCAT=.NOT.GETDELTAT(L,TNOW,TLEFT,.FALSE.,.TRUE.,
&DELTAL,PNOSCAT2)
- CALL HF1(920,REAL(PNOSCAT2),EVWEIGHT)
- PNOSCAT=GETNOSCAT(P(L,4),P(L,5),TNOW,TLEFT,TYP,PYP(L,8)/P(L,4))
- CALL HF1(921,REAL(PNOSCAT),EVWEIGHT)
- CALL HF1(922,REAL(PNOSCAT2-PNOSCAT),EVWEIGHT)
- IF(TYP.EQ.'G'.AND.K(L,2).NE.21)WRITE(*,*),TYP,K(L,2)
ENDIF
IF(.NOT.NOSCAT)THEN
C--add a momentum transfer
NEND=NEND+1
IF(NSTART.EQ.0) NSTART=1
C WRITE(*,*)'Delta l =',DELTAL
TNOW=TNOW+DELTAL
TSUM=TSUM+DELTAL
ALLQS(NEND,6)=TNOW
Q2OLD=QSUM2
C--get new momentum transfer
CALL GETQVEC(L,NEND,TNOW-MV(L,4))
C WRITE(*,*)'t=',ALLQS(NEND,1),QSUM2
C--update OVERQ2
IF((-QSUM2.GT.MAX(Q0**2,P(L,5)**2))
& .OR.(-ALLQS(NEND,1).GT.MAX(Q0**2,P(L,5)**2))) OVERQ2=.TRUE.
C WRITE(*,*)'overQ2',OVERQ2
C--get new virtuality
QOLD=Q
IF(OVERQ2.OR.(-QSUM2.GT.MAX(P(L,5)**2,Q0**2)))THEN
Q=GETNEWMASS(L,QSUM2,Q2OLD,.TRUE.,X)
ELSE
Q=P(L,5)
ENDIF
C WRITE(*,*)'Q=',Q
C--update formation time
IF(Q.GT.P(L,5))THEN
TAU=0.2*P(L,4)/Q**2
ENDIF
C WRITE(*,*)'tau=',TAU
IF(FIRST.AND.(TAU.LT.TSUM)) THEN
TLEFT=0.d0
GOTO 114
ENDIF
C--do consistency check
IF(TAU.LT.TSUM)THEN
C--reject last momentum transfer
C WRITE(*,*)'last momentum transfer not consistent'
C QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2)
C QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3)
C QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4)
C QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5)
C QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2
C NEND=NEND-1
C IF(NEND.EQ.0) NSTART=0
Q=QOLD
IF(Q.EQ.0.d0)THEN
TAU=0.2*P(L,4)/Q0**2
ELSE
TAU=0.2*P(L,4)/Q**2
ENDIF
TLEFT=TLEFT-DELTAL
ELSE
TLEFT=TAU-TSUM
ENDIF
FIRST=.FALSE.
ELSE
C--no more scatterings
C WRITE(*,*)'no more scattering'
GOTO 114
ENDIF
111 CONTINUE
C--do reweighting
C WRITE(*,*)'start reweighting, qsum^2, low=',QSUM2,LOW
114 IF((-QSUM2.LT.LOW).AND.(.NOT.NORAD))THEN
WEIGHT=0.d0
C WRITE(*,*)'summed qvec too small'
ELSEIF(-QSUM2.GT.P(L,4)**2)THEN
C WRITE(*,*)'combined t too large '
WEIGHT=0.d0
ELSEIF(NORAD)THEN
WEIGHT=GETINSUDAFAST(SQRT(LOW),SQRT(-QSUM2),TYP2)
Q=0.d0
X=1.d0
ELSE
IF(TYP.EQ.'G')THEN
FMAX=2.*LOG(P(L,4)**2/LOW)*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,SQRT(LOW),SQRT(-QSUM2),'QG')/(PQG(X)*FMAX)
C WRITE(*,*)'x,sqrt(low),sqrt(qsum^2),getpdf:',X,SQRT(LOW),
C & SQRT(-QSUM2),GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'QG'),'qg'
ELSE
WEIGHT=GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'GG')/(PGG(X)*FMAX)
C WRITE(*,*)'x,sqrt(low),sqrt(qsum^2),getpdf:',X,SQRT(LOW),
C & SQRT(-QSUM2),GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'GG'),'gg'
ENDIF
ENDIF
ELSE
FMAX=LOG(P(L,4)**2/LOW)*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,SQRT(LOW),SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX)
C WRITE(*,*)'x,sqrt(low),sqrt(qsum^2),getpdf:',X,SQRT(LOW),
C & SQRT(-QSUM2),GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'GQ'),'gq'
ELSE
WEIGHT=GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX)
C WRITE(*,*)'x,sqrt(low),sqrt(qsum^2),getpdf:',X,SQRT(LOW),
C & SQRT(-QSUM2),GETPDF(X,SQRT(LOW),SQRT(-QSUM2),'QQ'),'qq'
ENDIF
ENDIF
ENDIF
ENDIF
C WRITE(*,*)'weight=',WEIGHT
115 IF(PYR(0).GT.WEIGHT) GOTO 112
C--check if t consistent with new energy
C--CHANGE FOR MULTIPLE MOMENTUM TRANSFERS
TMAXNEW=2.*MS*(X*P(L,4)-P(L,5))
IF(-QSUM2.GT.TMAXNEW)THEN
C WRITE(*,*)'reject t value, not consistent with new upper bound'
QSUMVEC(1)=0.d0
QSUMVEC(2)=0.d0
QSUMVEC(3)=0.d0
QSUMVEC(4)=0.d0
QSUM2=0.d0
NSTART=0
NEND=0
OVERQ2=.FALSE.
X=1.d0
TYPI=K(L,2)
ENDIF
C--check if new energy is large enough
IF((Q.EQ.0.d0).AND.(.NOT.NORAD))THEN
C WRITE(*,*)'Q=0 and radiation'
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
OVERQ2=.FALSE.
ENDIF
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
116 DELTAT=TSUM+TLEFT
-
C--check for scattering ???
NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTATFIRST,.FALSE.,.TRUE.,
&DT,PNOSCAT2)
+C WRITE(*,*)'Pnoscat=',PNOSCAT
IF(NOSCAT)THEN
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
OVERQ2=.FALSE.
DELTAT=DELTATFIRST
C WRITE(*,*)'no scattering in delta t=',DELTATFIRST
ENDIF
C WRITE(*,*)'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
END
SUBROUTINE DOFISTATESCAT(L,TNOW,DELTAT,NEWMASS,OVERQ2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--local variables
INTEGER L,I,NENDORIG,NSTARTORIG
DOUBLE PRECISION TNOW,DELTAT,STARTT,TAU,NEWMASS,TLEFT,DELTAL,
&GETDELTAL,NEWMOLD,PNOSCAT,GETNOSCAT,Q2OLD,GETNEWMASS,PYR,PYP,
&TSUM,GETMASS,QSUM2ORIG,QSUMVECORIG(4),MAXMASS,DT,PNOSCAT2
LOGICAL OVERQ2,OVERORIG,NOSCAT,GETDELTAT
CHARACTER TYP
C WRITE(*,*)'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
C WRITE(*,*)'start DOFISTATESCAT for',L,TNOW,DELTAT
-C IF(-QSUM2.GT.P(L,4)**2) WRITE(*,*) 'DOFISTATESCAT has a problem:',
-C &-QSUM2,P(L,4)**2
+C WRITE(*,*)'Q^2_sum',QSUM2
+ IF(-QSUM2.GT.P(L,4)**2)
+ & WRITE(*,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2
NSTARTORIG=NSTART
NENDORIG=NEND
QSUM2ORIG=QSUM2
QSUMVECORIG(1)=QSUMVEC(1)
QSUMVECORIG(2)=QSUMVEC(2)
QSUMVECORIG(3)=QSUMVEC(3)
QSUMVECORIG(4)=QSUMVEC(4)
OVERORIG=OVERQ2
STARTT=TNOW-DELTAT
IF(K(L,2).EQ.21)THEN
TYP='G'
ELSE
TYP='Q'
ENDIF
C--probability for gluon radiation with given momentum transfers
IF(-QSUM2.GT.MAX(P(L,5)**2,QMIN**2))THEN
MAXMASS=SQRT(0.2*P(L,4)/DELTAT)
C WRITE(*,*)'max mass=',MAXMASS
IF(MAXMASS.LT.QMIN)THEN
NEWMASS=P(L,5)
ELSE
NEWMASS=GETMASS(0.d0,SQRT(-QSUM2),1.d0,1.d0,P(L,4),TYP,
& MAXMASS,MV(L,4),.FALSE.)
C NEWMASS=GETNEWMASS(L,QSUM2,0.d0,.FALSE.,1.d0)
ENDIF
ELSE
NEWMASS=P(L,5)
ENDIF
C WRITE(*,*)'first try: mass=',NEWMASS,OVERQ2
IF(NEWMASS.EQ.0.d0)THEN
TAU=0.2*P(L,4)/Q0**2
ELSE
TAU=0.2*P(L,4)/NEWMASS**2
ENDIF
C WRITE(*,*)'tau=',TAU
C--check if formation time is consistent with time interval
IF(TAU.LT.DELTAT*(1.d0-1d-10)) THEN
C WRITE(*,*)'mass inconsistent, try it again',NEWMASS,TAU,DELTAT
224 NEWMASS=GETMASS(MAX(P(L,5),QMIN),SQRT(-QSUM2),1.d0,1.d0,
& P(L,4),TYP,P(L,4),MV(L,4),.FALSE.)
C WRITE(*,*)'mass inconsistent, try it again',NEWMASS,TAU,DELTAT
TAU=0.2*P(L,4)/NEWMASS**2
IF(TAU.LT.DELTAT) GOTO 224
ENDIF
C--add the momentum transfers during formation time
TLEFT=TAU-DELTAT
TSUM=0.d0
DO 223 I=1,10000
C WRITE(*,*)'remaining formation time',TLEFT
NOSCAT=.NOT.GETDELTAT(L,TNOW,TLEFT,.FALSE.,.TRUE.,DT,PNOSCAT2)
- CALL HF1(920,REAL(PNOSCAT2),EVWEIGHT)
- PNOSCAT=GETNOSCAT(P(L,4),P(L,5),TNOW,TLEFT,TYP,PYP(L,8)/P(L,4))
- CALL HF1(921,REAL(PNOSCAT),EVWEIGHT)
- CALL HF1(922,REAL(PNOSCAT2-PNOSCAT),EVWEIGHT)
IF(.NOT.NOSCAT)THEN
C--do scattering
C WRITE(*,*)'do scattering'
NEND=NEND+1
IF(NSTART.EQ.0) NSTART=1
DELTAL=GETDELTAL(P(L,4),P(L,5),TNOW,TLEFT,TYP,PYP(L,8)/P(L,4))
DELTAL=DT
C WRITE(*,*)'Delta l =',DELTAL
TSUM=TSUM+DELTAL
ALLQS(NEND,6)=TNOW+TSUM
Q2OLD=QSUM2
C--get new momentum transfer
CALL GETQVEC(L,NEND,TNOW+DT-MV(L,4))
C WRITE(*,*)'t =',ALLQS(NEND,1)
C WRITE(*,*)'t_eff =',QSUM2
C--figure out new virtuality
IF(-QSUM2.GT.P(L,4)**2)THEN
C WRITE(*,*)'combined momentum transfer too large',NEND
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
NEND=NEND-1
IF(NEND.EQ.0) NSTART=0
ELSE
NEWMOLD=NEWMASS
IF(OVERQ2.OR.(-QSUM2.GT.MAX(P(L,5)**2,Q0**2)))THEN
+C WRITE(*,*)'DOFISTATESCAT call GETNEWMASS for',QSUM2,Q2OLD
NEWMASS=GETNEWMASS(L,QSUM2,Q2OLD,.FALSE.,1.d0)
OVERQ2=.TRUE.
C WRITE(*,*)'new mass =',NEWMASS
ELSE
NEWMASS=P(L,5)
C WRITE(*,*)'keep old mass'
ENDIF
ENDIF
C--check if last momentum transfer consistent
IF(NEWMASS.GT.0.d0)THEN
TAU=0.2*P(L,4)/NEWMASS**2
ELSE
TAU=0.2*P(L,4)/Q0**2
ENDIF
C WRITE(*,*)'estimated formation time: ',TAU
IF(TAU.LT.TSUM+DELTAT)THEN
C WRITE(*,*)'new mass not consistent'
NEWMASS=NEWMOLD
C WRITE(*,*)'new mass :',NEWMASS
IF(NEWMASS.EQ.0.d0)THEN
TAU=0.2*P(L,4)/Q0**2
ELSE
TAU=0.2*P(L,4)/NEWMASS**2
ENDIF
TLEFT=TLEFT-DELTAL
ELSE
TLEFT=TAU-DELTAT-TSUM
ENDIF
ELSE
C--no more scattering
IF(NEWMASS.GT.P(L,5))THEN
DELTAT=TSUM+TLEFT
NSTART=NSTARTORIG
NEND=NENDORIG
QSUM2=QSUM2ORIG
QSUMVEC(1)=QSUMVECORIG(1)
QSUMVEC(2)=QSUMVECORIG(2)
QSUMVEC(3)=QSUMVECORIG(3)
QSUMVEC(4)=QSUMVECORIG(4)
OVERQ2=OVERORIG
ELSE
DELTAT=0.d0
ENDIF
C WRITE(*,*)'no more scattering'
C WRITE(*,*)'deltat, new mass, t_eff:',DELTAT,NEWMASS,QSUM2
GOTO 225
ENDIF
223 CONTINUE
225 CONTINUE
C WRITE(*,*)'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
END
DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,IN,X)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER L
DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA,
&GETSUDAKOV,GETMASS,PKEEP,X
LOGICAL IN
CHARACTER TYP1
CHARACTER*2 TYP
C WRITE(*,*)'---------------------------------------'
C WRITE(*,*)'get new mass for line ',L,' with Q^2=',Q2,
C & ' and Q_old^2=',QOLD2
IF(P(L,4).LT.QMIN)THEN
C WRITE(*,*)'not enough energy'
GETNEWMASS=0.d0
C WRITE(*,*)'---------------------------------------'
RETURN
ENDIF
IF (-Q2.LT.QMIN**2)THEN
C WRITE(*,*)'no phase space'
GETNEWMASS=0.d0
C WRITE(*,*)'---------------------------------------'
RETURN
ENDIF
IF(K(L,2).EQ.21)THEN
TYP='GC'
TYP1='G'
ELSE
TYP='QQ'
TYP1='Q'
ENDIF
IF(SQRT(-QOLD2).LE.QMIN)THEN
C WRITE(*,*)'first momentum transfer'
IF(IN)THEN
GETNEWMASS=GETMASS(MAX(P(L,5),QMIN),SQRT(-Q2),1.d0,1.d0,
& X*P(L,4),TYP,X*P(L,4),MV(L,4),IN)
ELSE
GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),1.d0,1.d0,P(L,4),TYP,
& SQRT(-Q2),MV(L,4),IN)
ENDIF
RETURN
GETNEWMASS=MIN(GETNEWMASS,X*P(L,4))
ENDIF
Z=1.d0
QA=1.d0
C WRITE(*,*)'z=',Z,' ; Qa=',QA
IF(P(L,5).GT.0.d0)THEN
C WRITE(*,*)'there is already radiation'
IF(-Q2.GT.-QOLD2)THEN
C WRITE(*,*)'increase phase space'
C WRITE(*,*)'1 get sudakov for',
C &SQRT(-Q2),QA,SQRT(-QOLD2),Z,X*P(L,4),TYP,MV(L,4),IN
PNOSPLIT1=GETSUDAKOV(SQRT(-Q2),QA,SQRT(-QOLD2),Z,X*P(L,4),TYP,
& MV(L,4),IN)
C WRITE(*,*)'probability to keep radiation:',PNOSPLIT1
IF(PYR(0).LT.PNOSPLIT1)THEN
GETNEWMASS=P(L,5)
ELSE
GETNEWMASS=GETMASS(SQRT(-QOLD2),SQRT(-Q2),QA,Z,X*P(L,4),TYP,
& SQRT(-Q2),MV(L,4),IN)
ENDIF
ELSE
C WRITE(*,*)'decrease phase space'
C WRITE(*,*)'2 get sudakov for',
C &SQRT(-QOLD2),QA,QMIN,Z,X*P(L,4),TYP,MV(L,4),IN
PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,QMIN,Z,X*P(L,4),
& TYP,MV(L,4),IN)
C WRITE(*,*)'P_nosplit 1: ',PNOSPLIT1
C WRITE(*,*)'3 get sudakov for',
C &SQRT(-Q2),QA,QMIN,Z,X*P(L,4),TYP,MV(L,4),IN
PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,QMIN,Z,X*P(L,4),
& TYP,MV(L,4),IN)
C WRITE(*,*)'P_nosplit 2: ',PNOSPLIT2
IF(IN)THEN
PKEEP=1.d0
ELSE
PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1)
ENDIF
C WRITE(*,*)'probability to keep radiation: ',PKEEP
IF(PYR(0).LT.PKEEP)THEN
IF(P(L,5).LT.SQRT(-Q2))THEN
GETNEWMASS=P(L,5)
ELSE
GETNEWMASS=GETMASS(QMIN,SQRT(-Q2),QA,Z,X*P(L,4),TYP,
& SQRT(-Q2),MV(L,4),IN)
ENDIF
ELSE
GETNEWMASS=0.d0
ENDIF
ENDIF
ELSE
C WRITE(*,*)'there is no radiation'
IF(-Q2.GT.-QOLD2)THEN
C WRITE(*,*)'increase phase space'
C WRITE(*,*)'4 get sudakov for',
C &SQRT(-Q2),QA,MAX(SQRT(-QOLD2),QMIN),Z,X*P(L,4),TYP,MV(L,4),IN
PNOSPLIT1=GETSUDAKOV(SQRT(-Q2),QA,MAX(SQRT(-QOLD2),QMIN),
& Z,X*P(L,4),TYP,MV(L,4),IN)
IF(PYR(0).LT.PNOSPLIT1)THEN
GETNEWMASS=0.d0
ELSE
GETNEWMASS=GETMASS(MAX(SQRT(-QOLD2),QMIN),
& SQRT(-Q2),QA,Z,X*P(L,4),TYP,X*P(L,4),MV(L,4),IN)
ENDIF
ELSE
C WRITE(*,*)'decrease phase space'
GETNEWMASS=0.d0
ENDIF
ENDIF
GETNEWMASS=MIN(GETNEWMASS,P(L,4))
C WRITE(*,*)'---------------------------------------'
END
DOUBLE PRECISION FUNCTION GETPNORAD1(LINE)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER LINE
- DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,SCATPRIMFUNC,GETXSECINT,
- &GETSSCAT
+ DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT
UP=2.*MS*(P(LINE,4)-P(LINE,5))
LOW=MAX(Q0**2,P(LINE,5)**2)
C LOW=0.d0
IF((UP.LE.Q0**2).OR.(UP.LE.LOW).OR.(P(LINE,4).LT.Q0))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,5),'G','C',MS,MD)
+ SIGMATOT=GETSSCAT(P(LINE,4),P(LINE,5),0.d0,'G','C',MS,MD)
+C WRITE(*,*)'GETPNORAD: gluon sigmatot=',SIGMATOT
IF(SIGMATOT.EQ.0.d0)THEN
-C--jkl ??? why negative?
GETPNORAD1=-1.d0
RETURN
ENDIF
- GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD)-SCATPRIMFUNC(0.d0,MD))
- & + GETXSECINT(LOW,UP,'GB'))/SIGMATOT
-C GETPNORAD1=GETXSECINT(LOW,UP,'GB')/SIGMATOT
+ GETPNORAD1=1.d0
+ & - GETSSCAT(P(LINE,4),P(LINE,5),MAX(Q0,P(LINE,5)),'G','C',MS,MD)
+ & /SIGMATOT
ELSE
CCOL=2./3.
C--probability for no initial state radiation
- SIGMATOT=GETSSCAT(P(LINE,4),P(LINE,5),'Q','C',MS,MD)
+ SIGMATOT=GETSSCAT(P(LINE,4),P(LINE,5),0.d0,'Q','C',MS,MD)
+C WRITE(*,*)'GETPNORAD: quark sigmatot=',SIGMATOT
IF(SIGMATOT.EQ.0.d0)THEN
-C--jkl ??? why negative?
- GETPNORAD1=-1.d0
+ GETPNORAD1=1.d0
RETURN
ENDIF
- GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD)-SCATPRIMFUNC(0.d0,MD))
- & + GETXSECINT(LOW,UP,'QB'))/SIGMATOT
-C GETPNORAD1=GETXSECINT(LOW,UP,'QB')/SIGMATOT
+ GETPNORAD1=1.d0
+ & - GETSSCAT(P(LINE,4),P(LINE,5),MAX(Q0,P(LINE,5)),'Q','C',MS,MD)
+ & /SIGMATOT
ENDIF
+ IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))
+ & WRITE(*,*)'error: P_norad=',GETPNORAD1
END
SUBROUTINE GETQVEC(L,J,DT)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--local variables
- INTEGER L,J
+ INTEGER L,J,COUNTER
DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT
DOUBLE PRECISION R,PYR,PHI1,THETA1,
&NEWMOM(4),SHAT,T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,
&D3,ZETA3,PT2,PNORAD,GETINSUDAFAST,GETPDFXINT,GETMS
CHARACTER TYPS,TYPP
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA PI/3.141592653589793d0/
+C WRITE(*,*)'----------------------------------------'
+C WRITE(*,*)'GETQVEC for',L,P(L,1),P(L,2),P(L,3),P(L,4),P(L,5)
+C WRITE(*,*)'GETQVEC: Qsum^2:',QSUM2
+C WRITE(*,*)'GETQVEC: Qsumvec:',QSUMVEC
+
IF (J.GT.1000)THEN
WRITE(*,*)'GETQVEC: J too large'
CALL EXIT(1)
ENDIF
+ COUNTER=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
CALL HF2(202,REAL(XSC),REAL(YSC),EVWEIGHT)
- CALL GETSCATTERER(XSC,YSC,ZSC,TSC,
+ 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),
&GETMD(XSC,YSC,ZSC,TSC),GETTEMP(XSC,YSC,ZSC,TSC))
CALL HF1(300,REAL(P(1,4)),EVWEIGHT)
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'
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
203 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 CALL PYLIST(2)
C--pick a t from differential scattering cross section
SHAT=P(L,5)**2+P(1,5)**2+2.*P(L,4)*P(1,5)
C WRITE(*,*)'shat=',SHAT
MAXT=MIN(2.*GETMS(XSC,YSC,ZSC,TSC)*(P(L,4)-P(L,5)),
& 2.*P(1,5)*P(L,3)*(P(L,3)+P(L,4))/(P(L,3)+P(L,4)+P(1,5)))
MAXT=MIN(MAXT,P(L,4)**2)
C WRITE(*,*)'GETQVEC: tmax=',MAXT
C T=-GETT(SHAT,MAX(P(L,5)**2,Q0**2),MAXT)
T=-GETT(SHAT,0.d0,MAXT,
&GETMD(XSC,YSC,ZSC,TSC))
C WRITE(*,*)'GETQVEC: t=',T
202 NEWMOM(4)=P(L,4)+T/(2.*GETMS(XSC,YSC,ZSC,TSC))
C WRITE(*,*)'GETQVEC: E=',NEWMOM(4)
NEWMOM(3)=(T-2.*P(L,5)**2+2.*P(L,4)*NEWMOM(4))/(2.*P(L,3))
C WRITE(*,*)'GETQVEC: p||=',NEWMOM(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
C WRITE(*,*)'GETQVEC: pt^2=',PT2
T=0.9*T
C WRITE(*,*)'GETQVEC: need new t=',T
GOTO 202
ENDIF
PT=SQRT(PT2)
C WRITE(*,*)'GETQVEC: pt^2=',NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2
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 WRITE(*,*)'GETQVEC: q before boost=',P(1,1),P(1,2),P(1,3),P(1,5)
+C WRITE(*,*)'GETQVEC: q before boost=',
+C & P(1,1),P(1,2),P(1,3),P(1,4),P(1,5)
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))
-C WRITE(*,*)'GETQVEC: q after boost=',P(1,1),P(1,2),P(1,3),P(1,5)
+C WRITE(*,*)'GETQVEC: q after boost=',
+C & P(1,1),P(1,2),P(1,3),P(1,4),P(1,5)
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.100)THEN
+ WRITE(*,*)'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
+ GOTO 444
+ COUNTER=COUNTER+1
+ ENDIF
+ ENDIF
C WRITE(*,*)'GETQVEC: new t:',T
C WRITE(*,*)'GETQVEC: Qsum^2:',QSUM2
C WRITE(*,*)'GETQVEC: Qsumvec:',QSUMVEC
+C WRITE(*,*)'----------------------------------------'
END
***********************************************************************
*** subroutine makescattering
***********************************************************************
*** performs scattering of parton on line l of the event record
***********************************************************************
SUBROUTINE DOKINEMATICS(L,N1,N2,NEWM,RETRYSPLIT)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--discard event flag
COMMON/DISC/DISCARD
LOGICAL DISCARD
C--variables for angular ordering
COMMON/ANGOR/ZA(8000),NOSCAT1(8000)
DOUBLE PRECISION ZA
LOGICAL NOSCAT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--variables for coherent scattering
COMMON/COHERENT/NSTART,NEND,ALLQS(1000,6),SCATCENTRES(1000,10),
&QSUMVEC(4),QSUM2
INTEGER NSTART,NEND
DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2
C--number of scattering events
COMMON/CHECK/NSCAT,NSPLIT,DELTAECOL,DELTAECOLTOT,
&DELTAERAD,DELTAERADTOT,LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION DELTAECOL,DELTAECOLTOT,DELTAERAD,DELTAERADTOT,
&LSUM,TSUMCOH,TSUMINCOH
DOUBLE PRECISION NSCAT,NSPLIT
C--local variables
INTEGER L,I,COUNTER,LINE,N1,N2,J
DOUBLE PRECISION PYR,PS,THETA1,PHI1,PI,BETA(3),THETA,PHI,PYP,PT2,
&PT,PHI2,SHAT,MAXT,GETT,D3,ZETA3,R,T,MINT,NEWMASS,GETMASS,
&ENEW,MAXMASS,NEWM,DELTAM,DM,TTOT,MMAX2,DMLEFT,M4MAX2,M4MAX,M4,
&EGUESS,TMAX,GETTEMP,GETMS
CHARACTER*2 TYP
LOGICAL RETRYSPLIT
DATA D3/0.9d0/
DATA ZETA3/1.2d0/
DATA PI/3.141592653589793d0/
C WRITE(*,*)'---------------------------------------'
C WRITE(*,*)'DoKinematics for L=',L,' ,N1=',N1,' N2=',N2,' new m=',NEWM
C CALL PYLIST(2)
DELTAM=NEWM-P(L,5)
C WRITE(*,*)'Delta m: ',DELTAM
DMLEFT=DELTAM
TTOT=0.d0
DO 220 J=N1,N2
TTOT=TTOT+ALLQS(J,1)
220 CONTINUE
C WRITE(*,*)'t_tot: ',TTOT
LINE=L
DO 222 J=N1,N2
MV(L,5)=ALLQS(J,6)
COUNTER=0
C--projectile type
IF(K(LINE,2).EQ.21)THEN
TYP='GC'
ELSE
TYP='QQ'
ENDIF
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(TTOT.EQ.0.d0)THEN
DM=0.d0
ELSE
DM=DMLEFT*T/TTOT
ENDIF
C WRITE(*,*)'t: ',T
C WRITE(*,*)'t tot: ',TTOT
C WRITE(*,*)'delta m: ',DM
C DO 200 I=1,N
C V(I,1)=MV(I,1)
C V(I,2)=MV(I,2)
C V(I,3)=MV(I,3)
C V(I,4)=MV(I,4)
C V(I,5)=MV(I,5)
C 200 CONTINUE
C CALL PYLIST(3)
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)
IF(BETA(1).GT.1.d0.OR.BETA(2).GT.1.d0.OR.BETA(3).GT.1.d0)THEN
WRITE(*,*)'before boost',BETA(1),BETA(2),BETA(3)
CALL PEVREC
CALL EXIT(1)
ENDIF
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)
ENEW=P(LINE,4)+T/(2.*P(1,5))
IF((P(LINE,5).LT.0.d0).AND.(ENEW.LT.0.d0))THEN
RETRYSPLIT=.TRUE.
RETURN
ENDIF
C WRITE(*,*)'E new=',ENEW
IF(ENEW.LT.P(LINE,5))THEN
C--jkl ??? consistent?
T=2.*GETMS(MV(1,1),MV(1,2),MV(1,3),MV(1,4))*
&(P(LINE,5)-P(LINE,4))
DM=0.d0
ENEW=P(LINE,5)
C WRITE(*,*)'E new=',ENEW
ENDIF
MMAX2=P(LINE,5)**2+(P(1,5)*(P(LINE,4)+P(1,5))*T+
& SQRT(P(1,5)**2*P(LINE,3)**2*T*(T-4.*P(1,5)**2)))/P(1,5)**2
C WRITE(*,*)'mmax2=',MMAX2
NEWMASS=MIN(P(LINE,5)+DM,ENEW,SQRT(MAX(MMAX2,0.d0)))
IF(NEWMASS.LT.QMIN) NEWMASS=0.d0
C WRITE(*,*)'new projectile mass=',NEWMASS
IF(P(LINE,5).LE.1.d-10)THEN
M4MAX2=-((2.*P(LINE,4)*P(1,5)-NEWMASS**2+T)
& *(2.*P(LINE,4)*T+P(1,5)*(-NEWMASS**2+T)))
& /(2.*P(LINE,4)*(NEWMASS**2-T))
ELSE
M4MAX2=(P(LINE,4)*P(1,5)*(P(LINE,5)**2-NEWMASS**2+T)
& +P(LINE,5)**2*(P(1,5)**2+T)
& + SQRT(P(1,5)**2*P(LINE,3)**2*(P(LINE,5)**4
& +(NEWMASS**2-T)**2
& -2.*P(LINE,5)**2*(NEWMASS**2+T))))/P(LINE,5)**2
ENDIF
M4MAX=MIN(SQRT(-T),SQRT(M4MAX2),P(LINE,4)+P(1,4)-NEWMASS)
C WRITE(*,*)'max m4=',M4MAX
EGUESS=MAX((P(LINE,4)+P(1,4)-NEWMASS+P(LINE,4)
& +P(1,4)-ENEW)/2.d0,M4MAX)
C WRITE(*,*)'energy=',EGUESS
IF(M4MAX.GT.QMIN)THEN
M4=GETMASS(0.d0,M4MAX,1.d0,1.d0,EGUESS,TYP,M4MAX,
& MV(LINE,4),.FALSE.)
ELSE
M4=0.d0
ENDIF
IF(M4.EQ.0.d0) M4=P(1,5)
M4=P(1,5)
C WRITE(*,*)'new scattering centre mass=',M4
N=N+2
IF(N.GT.4990)THEN
WRITE(*,*)'event too long for event record'
DISCARD=.TRUE.
RETURN
ENDIF
C--calculate new momentum-vector
P(N,5)=NEWMASS
202 P(N,4)=P(LINE,4)+(P(1,5)**2-M4**2+T)/(2.*P(1,5))
P(N,3)=(T-P(LINE,5)**2
& -P(N,5)**2+2.*P(LINE,4)*P(N,4))/(2.*P(LINE,3))
IF(T.EQ.0.d0)THEN
PT2=0.d0
ELSE
PT2=P(N,4)**2-P(N,3)**2-P(N,5)**2
ENDIF
IF(DABS(PT2).LT.1e-10) PT2=0.d0
IF(PT2.LT.0.d0)THEN
C WRITE(*,*)'new mass kinematically not allowed'
C WRITE(*,*)'P(N,3)=',P(N,3)
C WRITE(*,*)'P(N,4)=',P(N,4)
C WRITE(*,*)'P(N,5)=',P(N,5)
C WRITE(*,*)'m4=',M4
C WRITE(*,*)'pt^2=',PT2
C WRITE(*,*)'t=',T
C WRITE(*,*)'tmax=',MIN(2.*P(1,5)*(P(LINE,4)-P(LINE,5)),
C & 2.*P(1,5)*P(LINE,3)*(P(LINE,3)+P(LINE,4))/(P(LINE,3)+P(LINE,4)+P(1,5)))
MAXT=MIN(2.*P(1,5)*(P(LINE,4)-P(LINE,5)),
& 2.*P(1,5)*P(LINE,3)*(P(LINE,3)+P(LINE,4))
& /(P(LINE,3)+P(LINE,4)+P(1,5)))
IF(-T.GT.MAXT) T=0.d0
IF(P(LINE,5).GE.0.d0) P(N,5)=P(LINE,5)
M4=P(1,5)
IF (P(LINE,5).LT.0.d0)THEN
RETRYSPLIT=.TRUE.
N=N-2
RETURN
ENDIF
GOTO 202
ENDIF
PT=SQRT(PT2)
PHI2=PYR(0)*2*PI
P(N,1)=PT*COS(PHI2)
P(N,2)=PT*SIN(PHI2)
ZA(N)=1.d0
C--outgoing projectile
K(N,1)=K(LINE,1)
K(N,2)=K(LINE,2)
K(N,3)=L
K(N,4)=0
K(N,5)=0
C--take care of incoming projectile
IF(K(LINE,1).EQ.1)THEN
K(LINE,1)=12
ELSE
K(LINE,1)=14
ENDIF
K(LINE,4)=N-1
K(LINE,5)=N
C--outgoing scattering centre
K(N-1,2)=K(1,2)
K(N-1,3)=0
K(N-1,4)=0
K(N-1,5)=0
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,5)=M4
P(N-1,4)=SQRT(P(N-1,1)**2+P(N-1,2)**2+P(N-1,3)**2+P(N-1,5)**2)
ZA(N-1)=1.d0
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))
IF(KEEPRECOIL)THEN
IF(SCATRECOIL.AND.(P(N-1,4).GT.1.5*3.*
&GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))))THEN
K(N-1,1)=2
ELSE
K(N-1,1)=3
ENDIF
ELSE
K(N-1,1)=11
ENDIF
IF(P(1,4).LT.10.d0) CALL HF1(301,REAL(P(N-1,4)),EVWEIGHT)
IF(PYP(1,10).LT.10.d0) CALL HF1(303,REAL(PYP(N-1,10)),EVWEIGHT)
CALL HF1(305,REAL(P(N-1,1)/PYP(N-1,8)),EVWEIGHT)
CALL HF1(307,REAL(ACOS(P(N-1,1)/PYP(N-1,8))),EVWEIGHT)
CALL HF2(800,REAL(PYP(N-1,10)),REAL(P(N-1,1)/PYP(N-1,8)),
& EVWEIGHT)
CALL HF2(801,REAL(P(N-1,4)),REAL(P(N-1,1)/PYP(N-1,8)),EVWEIGHT)
C--fill Delta E in histogram
CALL HF2(210,REAL(P(L,4)),REAL((P(LINE,4)-P(N,4))/P(LINE,4)),
& EVWEIGHT)
MV(N,4)=MV(L,5)
MV(N-1,4)=MV(L,5)
MV(N-1,5)=0.d0
IF(J.LT.N2)THEN
MV(N,5)=MV(N,4)
ELSE
MV(N,5)=0.d0
ENDIF
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)/P(L,4)
MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/P(L,4)
MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/P(L,4)
MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/P(L,4)
MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/P(L,4)
MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/P(L,4)
NSCAT=NSCAT+EVWEIGHT
DELTAECOL=DELTAECOL+P(LINE,4)-P(N,4)
DELTAECOLTOT=DELTAECOLTOT+P(LINE,4)-P(N,4)
DMLEFT=DMLEFT-(NEWMASS-P(LINE,5))
TTOT=TTOT-ALLQS(J,1)
LINE=N
222 CONTINUE
C CALL PYLIST(2)
C WRITE(*,*)'---------------------------------------'
END
***********************************************************************
*** function getproba
***********************************************************************
*** returns value of P(Q_max,Q) for parton of type 'type',
*** virtuality 'qf', maximum virtuality 'qi' and energy 'ebb',
*** mother virtuality 'qaa' and energy fraction 'zaa' of
*** splitting parton (needed for angular ordering)
***********************************************************************
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
INTEGER COL,LINE
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
***********************************************************************
*** returns value of sudakov form factor for parton of type
*** 'type3', virtuality 'qb1', maximum virtuality 'qmax' and
*** energy 'eb1', mother virtuality 'qa1' and energy fraction
*** 'za1' of splitting parton (needed for angular ordering)
*** numerical integraltion of dQ'^2 integral, splitting integral
*** is done analytically, since alphas(Q'^2) is used
***********************************************************************
DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1,
& TYPE3,T2,INS)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
INTEGER NOK,NBAD
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/
C DATA HFIRST/0.01d0/
QB2=QB1
C WRITE(*,*)'getsudakov: from',QB1,' to',QMAX1
- IF(QB2.LT.QMIN) WRITE(*,*) 'error: Q < Q0',QB1,QMAX1
- IF(QB2.LT.(QMIN+1.d-10))THEN
- QB2=QB2+1.d-10
- ENDIF
+ IF(QB2.LT.QMIN) WRITE(*,*) 'error: Q < Q0',QB2,QMAX1
+ IF(QB2.LT.(QMIN+1.d-10)) QB2=QB2+1.d-10
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
NOK=0
NBAD=0
+C WRITE(*,*)'getsudakov start integration'
CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,NOK,NBAD,1)
C WRITE(*,*)'getsudakov: ystart=',YSTART
GETSUDAKOV=EXP(-YSTART)
ENDIF
ENDIF
END
DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB1,QMAX1,TYPE3)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
INTEGER NOK,NBAD
DOUBLE PRECISION QMAX1,QB1,ZA1,EA1,TMAX,YSTART,EPSI,
&HFIRST
CHARACTER*2 TYPE3
DATA EPSI/1.d-4/
C DATA HFIRST/0.01d0/
C WRITE(*,*)'getsudakov: from',QB1,' to',QMAX1
IF(QB1.LT.Q0) WRITE(*,*) '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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,NOK,NBAD,6)
C WRITE(*,*)'getinsudakov: ystart=',YSTART
GETINSUDAKOV=EXP(-YSTART)
ENDIF
C WRITE(*,*)'getinsudakov =',GETINSUDAKOV
END
***********************************************************************
*** function deriv
***********************************************************************
*** integrand (= splitting integral) in numerical integration of
*** Sudakov form factor; 't': integration variable, 'qa5':
*** mother virtuality, 'za5': energy fraction of splitting
*** parton, 'eb5': energy of splitting parton, 'type7': type of
*** splitting parton
***********************************************************************
DOUBLE PRECISION FUNCTION DERIV(XVAL,W4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION QLOW
C--local variables
INTEGER W4
DOUBLE PRECISION XVAL,GETSPLITI,GETSCATI,PI,ALPHAS,GETINSPLITI,
&GETINSUDAFAST,SCATPRIMFUNC,GETINSUDAKOV,GETPDF,PQQ,PQG,PGG,PGQ,
&GETMD,MDT,MEDDERIV
DATA PI/3.141592653589793d0/
IF(W4.GE.11.AND.W4.LE.14)THEN
MDT=GETMD(0.d0,0.d0,0.d0,0.d0)
+ MDT=MD
ENDIF
IF(W4.EQ.1)THEN
C--Sudakov integration
IF(INSTATE)THEN
C WRITE(*,*)'you should not be here'
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
C WRITE(*,*)'getinspliti for',XVAL,TYP,'=',GETINSPLITI(XVAL,TYP)
ELSE
DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP,T)/XVAL
C WRITE(*,*)'what is wrong here?'
C WRITE(*,*)'args:',QA,XVAL,ZA2,EB,TYP,T
C WRITE(*,*)'getspliti=',GETSPLITI(QA,XVAL,ZA2,EB,TYP,T)
ENDIF
C WRITE(*,*)'deriv=',DERIV
ELSEIF(W4.EQ.2)THEN
C--P(q->qg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD,LPS)*
& PQQ(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*
C & PQQ(XVAL)/(2.*PI)
ELSEIF(W4.EQ.3)THEN
C--P(g->gg) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD,LPS)
& *PGG(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*PGG(XVAL)/(2.*PI)
C DERIV=0.d0
ELSEIF(W4.EQ.4)THEN
C--P(g->qq) integration
DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD,LPS)*
& PQG(XVAL)/(2.*PI)
C DERIV=(1.+FM)*ALPHAS(QQUAD,LPS)*PQG(XVAL)/(2.*PI)
C DERIV=0.d0
ELSEIF(W4.EQ.5)THEN
DERIV=EXP(-XVAL)/XVAL
ELSEIF(W4.EQ.6)THEN
DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL
C WRITE(*,*)'deriv=',DERIV
ELSEIF(W4.EQ.7)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PQQ(Z)/(2.*PI*XVAL)
C WRITE(*,*)'x,Q1,Q2,deriv=',Z,XVAL,XMAX,DERIV
C WRITE(*,*)'alphas,arg,sudakov=',ALPHAS((1.-Z)*XVAL**2,LPS),
C & (1.-Z)*XVAL**2,GETINSUDAFAST(XVAL,XMAX,'QQ')
ELSEIF(W4.EQ.8)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PGQ(Z)/(2.*PI*XVAL)
C WRITE(*,*)'x,Q1,Q2,deriv=',Z,XVAL,XMAX,DERIV
C WRITE(*,*)'alphas,sudakov,Pgq=',ALPHAS((1.-Z)*XVAL**2,LPS),
C & GETINSUDAFAST(XVAL,XMAX,'GC'),PGQ(Z)
ELSEIF(W4.EQ.9)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')
& *ALPHAS((1.-Z)*XVAL**2,LPS)
& *PQG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.10)THEN
DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')
& *ALPHAS((1.-Z)*XVAL**2,LPS)*
& *2.*PGG(Z)/(2.*PI*XVAL)
ELSEIF(W4.EQ.11)THEN
C WRITE(*,*)'deriv:',XVAL
DERIV=3.*GETINSPLITI(SQRT(XVAL),'GQ')*SCATPRIMFUNC(XVAL,MDT)
& /(2.*XVAL)
C WRITE(*,*)'deriv=',DERIV,SQRT(XVAL)
ELSEIF(W4.EQ.12)THEN
C WRITE(*,*)'deriv:',XVAL
DERIV=2.*GETINSPLITI(SQRT(XVAL),'QG')*SCATPRIMFUNC(XVAL,MDT)
& /(3.*XVAL)
C WRITE(*,*)'deriv=',DERIV,SQRT(XVAL)
ELSEIF(W4.EQ.13)THEN
DERIV=GETINSUDAFAST(QLOW,SQRT(XVAL),'GC')
& *3.*2.*PI*ALPHAS(XVAL+MDT**2,LQCD)**2/(2.*(XVAL+MDT**2)**2)
ELSEIF(W4.EQ.14)THEN
DERIV=GETINSUDAFAST(QLOW,SQRT(XVAL),'QQ')
& *2.*2.*PI*ALPHAS(XVAL+MDT**2,LQCD)**2/(3.*(XVAL+MDT**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
C WRITE(*,*)'x, deriv=',XVAL,DERIV
ELSE
DERIV=MEDDERIV(XVAL,W4-100)
ENDIF
-C WRITE(*,*)'deriv=',DERIV
+C WRITE(*,*)'deriv=',W4,DERIV
END
***********************************************************************
*** function getspliti
***********************************************************************
*** returns splitting integral for parton of type 'type1',
*** virtuality 'qb', energy 'eb', energy fraction 'zeta' and mother
*** virtuality 'qa'
***********************************************************************
DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1,T3)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
INTEGER I,J,TMAXLINE,TLINE,LTMAX,LT,QLMAX,ZLMAX,QLINE,ZLINE
DOUBLE PRECISION QA,QB,ZETA,EB,LOW,ALPHAS,PI,X1A(4),T3,
&X2A(4),YA(4,4),Y,DY,SPLITINTGG,SPLITINTQG,
&INTPQQ,INTPGGLOW,INTPGGHIGH,INTPQGLOW,INTPQGHIGH,ARG,
&GETMS,GETTEMP
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
IF(ANGORD.AND.(ZETA.NE.1.d0))THEN
IF(CONSTR)THEN
LOW=MAX(0.5-0.5*SQRT(1.-QMIN**2/QB**2)
& *SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)),
& MINEN*Q0/EB)
ELSE
LOW=MAX(0.5-0.5*SQRT(1.-QB**2/EB**2),
& 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2)),
& MINEN*Q0/EB)
LOW=MIN(LOW,0.5)
ENDIF
ELSE
IF(CONSTR)THEN
LOW=MAX(0.5-0.5*SQRT(1.-QMIN**2/QB**2)
& *SQRT(1.-QB**2/EB**2),MINEN*Q0/EB)
ELSE
LOW=MAX(0.5-0.5*SQRT(1.-QB**2/EB**2),MINEN*Q0/EB)
LOW=MIN(LOW,0.5)
ENDIF
ENDIF
C IF(LOW.EQ.0.5) WRITE(*,*)'getspliti: low',LOW
C IF(LOW.EQ.0.5) WRITE(*,*)'getspliti: Qb,Eb,Qmin=',QB,EB,QMIN
C--if production time is during plasma lifetime use medium enhanced splitting
C function, otherwise use the vacuum function
IF(EXACT)THEN
IF(GETTEMP(0.d0,0.d0,0.d0,T3).GE.0.1d0)THEN
C--find values in array
QLMAX=INT((QB-Q0)*NPOINT/(QMAX-Q0))
QLINE=MAX(QLMAX-1,1)
QLINE=MIN(QLINE,NPOINT-3)
ZLMAX=INT((LOG(LOW)-LOG(ZMMIN))*NPOINT/(LOG(0.5)-LOG(ZMMIN)))
ZLINE=MAX(ZLMAX-1,1)
ZLINE=MIN(ZLINE,NPOINT-3)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 11 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 10 J=1,4
YA(I,J)=SPLITIGGM(QLINE-1+I,ZLINE-1+J)
10 CONTINUE
11 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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 13 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 12 J=1,4
YA(I,J)=SPLITIQGM(QLINE-1+I,ZLINE-1+J)
12 CONTINUE
13 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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 15 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 14 J=1,4
YA(I,J)=SPLITIQQM(QLINE-1+I,ZLINE-1+J)
14 CONTINUE
15 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ELSE
C--find values in array
QLMAX=INT((QB-Q0)*NPOINT/(QMAX-Q0))
QLINE=MAX(QLMAX-1,1)
QLINE=MIN(QLINE,NPOINT-3)
ZLMAX=INT((LOG(LOW)-LOG(ZMMIN))*NPOINT/(LOG(0.5)-LOG(ZMMIN)))
ZLINE=MAX(ZLMAX-1,1)
ZLINE=MIN(ZLINE,NPOINT-3)
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
DO 17 I=1,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 16 J=1,4
YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J)
16 CONTINUE
17 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 18 J=1,4
YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J)
18 CONTINUE
19 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
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,4
X1A(I)=QVAL(QLINE-1+I)
X2A(I)=ZMVAL(ZLINE-1+I)
DO 20 J=1,4
YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J)
20 CONTINUE
21 CONTINUE
CALL POLINT2(X1A,X2A,YA,4,4,QB,LOW,Y,DY)
GETSPLITI=MIN(Y,10.d0)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ENDIF
ELSE
IF(GETTEMP(0.D0,0.D0,0.D0,T3).GE.0.1D0)THEN
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=(1.+FMED)*(INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB))
ELSE
SPLITINTGG=(1.+FMED)*(INTPGGLOW(0.5d0,QB)
& - INTPGGLOW(LOW,QB) + INTPGGHIGH(1.-LOW,QB)
& - INTPGGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=(1.+FMED)*NF*(INTPQGLOW(0.5d0,QB)
& - INTPQGLOW(LOW,QB) + INTPQGHIGH(1.-LOW,QB)
& - INTPQGHIGH(0.5d0,QB))
ELSE
SPLITINTQG=(1.+FMED)*NF*(INTPQGLOW(0.5d0,QB)
& -INTPQGLOW(LOW,QB)+INTPQGHIGH(1.-LOW,QB)
& -INTPQGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
GETSPLITI=(1.+FMED)*(INTPQQ(1.d0-LOW,QB) - INTPQQ(LOW,QB))
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ELSE
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'GG')THEN
GETSPLITI=INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB)
ELSE
SPLITINTGG=INTPGGLOW(0.5d0,QB) - INTPGGLOW(LOW,QB)
& + INTPGGHIGH(1.-LOW,QB) - INTPGGHIGH(0.5d0,QB)
ENDIF
ENDIF
IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN
IF(TYPE1.EQ.'QG')THEN
GETSPLITI=NF*(INTPQGLOW(0.5d0,QB) - INTPQGLOW(LOW,QB)
& + INTPQGHIGH(1.-LOW,QB) - INTPQGHIGH(0.5d0,QB))
ELSE
SPLITINTQG=NF*(INTPQGLOW(0.5d0,QB) - INTPQGLOW(LOW,QB)
& + INTPQGHIGH(1.-LOW,QB) - INTPQGHIGH(0.5d0,QB))
ENDIF
ENDIF
IF(TYPE1.EQ.'QQ')THEN
GETSPLITI=INTPQQ(1.d0-LOW,QB) - INTPQQ(LOW,QB)
ENDIF
IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG
ENDIF
ENDIF
C WRITE(*,*)'getspliti=',GETSPLITI
END
DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
C--local variables
DOUBLE PRECISION QB,EA,LOW,ALPHAS,PI,
&Y,SPLITINTGG,SPLITINTQG,UP,EI
CHARACTER*2 TYPE1
DATA PI/3.141592653589793d0/
C--find boundaries for z integration
C WRITE(*,*)'getinspliti for Q, type = ',QB,' ',TYPE1
UP = 1. - Q0**2/(4.*QB**2)
C WRITE(*,*)'getinspliti: up',UP
IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN
LOW=Q0**2/(4.*QB**2)
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=Q0**2/(4.*QB**2)
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))
C Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2))
C & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2
C & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4
C & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2))
C & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2
C & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 )
C & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF))
GETINSPLITI=Y
ENDIF
IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG
C WRITE(*,*)'getinspliti=',GETINSPLITI
END
DOUBLE PRECISION FUNCTION GETPDF(X,Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER XBIN,QBIN1,QBIN2,I,XCLOSE,QLBIN,QRBIN,J
DOUBLE PRECISION X,Q1,Q2,GETINSUDAFAST,DELTAQ,SFAC1,
&SFAC2,DELTAX,QLOW,QHIGH,XA(4),YA(4),Y,DY,GETPDFEXACT
CHARACTER*2 TYP
IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q1.LT.Q0).OR.(Q2.LT.Q0))THEN
WRITE(*,*)'error in GETPDF: parameter out of bound',X,Q1,Q2
GETPDF=0.d0
RETURN
ENDIF
GETPDF=GETPDFEXACT(X,Q1,Q2,TYP)
RETURN
DELTAX=QINQ(2,101)-QINQ(1,101)
XCLOSE=INT(X/DELTAX+1)
XBIN=MAX(XCLOSE-1,1)
XBIN=MIN(XBIN,100-3)
QLBIN=INT((LOG(Q1**2)-LOG(QINQ(101,1)))*100.d0/
& (LOG(QINQ(101,100))-LOG(QINQ(101,1)))+1)
QRBIN=INT((LOG(Q2**2)-LOG(QINQ(101,1)))*100.d0/
& (LOG(QINQ(101,100))-LOG(QINQ(101,1)))+1)
IF(QINQ(101,QLBIN).GT.Q1**2) QLBIN=QLBIN-1
IF(QINQ(101,QRBIN).GT.Q2**2) QRBIN=QRBIN-1
IF(QINQ(101,QLBIN+1).LT.Q1**2) QLBIN=QLBIN+1
IF(QINQ(101,QRBIN+1).LT.Q2**2) QRBIN=QRBIN+1
IF(((QRBIN-QLBIN).LE.1).OR.(Q2**2.GT.QINQ(101,100)))THEN
GETPDF=GETPDFEXACT(X,Q1,Q2,TYP)
RETURN
ENDIF
DO 23 I=1,4
XA(I)=QINQ(XBIN-1+I,101)
IF(TYP.EQ.'QQ')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *QINQ(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 24 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'QQ')
& *QINQ(XBIN-1+I,J)
24 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GINQ(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 25 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'GC')
& *GINQ(XBIN-1+I,J)
25 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'QQ')
& *QING(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 26 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'QQ')
& *QING(XBIN-1+I,J)
26 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
IF(Q1**2.GT.QINQ(101,QLBIN))THEN
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GETPDFEXACT(XA(I),Q1,SQRT(QINQ(101,QLBIN+1)),TYP)
ELSE
YA(I)=GETINSUDAFAST(SQRT(QINQ(101,QLBIN+1)),Q2,'GC')
& *GING(XBIN-1+I,QLBIN)
ENDIF
YA(I)=YA(I)+GETPDFEXACT(XA(I),SQRT(QINQ(101,QRBIN)),Q2,TYP)
DO 27 J=QLBIN+1,QRBIN-1
YA(I)=YA(I)+GETINSUDAFAST(SQRT(QINQ(101,J+1)),Q2,'GC')
& *GING(XBIN-1+I,J)
27 CONTINUE
ELSE
WRITE(*,*)'error: pdf-type ',TYP,' does not exist'
GETPDF=0.d0
RETURN
ENDIF
23 CONTINUE
CALL POLINT(XA,YA,4,X,Y,DY)
GETPDF=Y
END
DOUBLE PRECISION FUNCTION GETPDFEXACT(X,Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,Q1,Q2,GETINSUDAFAST,DELTAQ,SFAC1,
&SFAC2,DELTAX,QLOW,QHIGH,YSTART,EPSI,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
IF(TYP.EQ.'QQ')THEN
Z=X
XMAX=Q2
C--f_q^q
QLOW=MAX(Q1,Q0/(2.*SQRT(1.-X)))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,7)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'GQ')THEN
Z=X
XMAX=Q2
C--f_q^g
QLOW=MAX(Q1,MAX(Q0/(2.*SQRT(1.-X)),Q0/(2.*SQRT(X))))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,8)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'QG')THEN
Z=X
XMAX=Q2
C--f_q^g
QLOW=MAX(Q1,Q0/(2.*SQRT(1.-X)))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,9)
ENDIF
GETPDFEXACT=YSTART
ELSEIF(TYP.EQ.'GG')THEN
Z=X
XMAX=Q2
C--f_q^q
QLOW=MAX(Q1,MAX(Q0/(2.*SQRT(1.-X)),Q0/(2.*SQRT(X))))
QHIGH=Q2
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
NOK=0
NBAD=0
CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,NOK,NBAD,10)
ENDIF
GETPDFEXACT=YSTART
ELSE
WRITE(*,*)'error: pdf-type ',TYP,' does not exist'
GETPDFEXACT=0.d0
ENDIF
END
DOUBLE PRECISION FUNCTION GETPDFXINT(Q1,Q2,TYP)
IMPLICIT NONE
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--local variables
INTEGER I,J,Q1CLOSE,Q2CLOSE,Q1LINE,Q2LINE
DOUBLE PRECISION Q1,Q2,X1A(4),X2A(4),YA(4,4),Y,DY,
&GETPDFXINTEXACT
CHARACTER*2 TYP
Q1CLOSE=INT((LOG(Q1**2)-LOG(QINQX(1,101)))*99/
& (LOG(QINQX(100,101))-LOG(QINQX(1,101)))+1)
Q1LINE=MAX(Q1CLOSE-1,1)
Q1LINE=MIN(Q1LINE,100-3)
Q2CLOSE=INT((LOG(Q2**2)-LOG(QINQX(101,1)))*99/
& (LOG(QINQX(101,100))-LOG(QINQX(101,1)))+1)
Q2LINE=MAX(Q2CLOSE-1,1)
Q2LINE=MIN(Q2LINE,100-3)
IF(TYP.EQ.'QQ')THEN
DO 12 I=1,4
X1A(I)=QINQX(Q1LINE-1+I,101)
X2A(I)=QINQX(101,Q2LINE-1+I)
DO 11 J=1,4
YA(I,J)=QINQX(Q1LINE-1+I,Q2LINE-1+J)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP.EQ.'GQ')THEN
DO 14 I=1,4
X1A(I)=GINQX(Q1LINE-1+I,101)
X2A(I)=GINQX(101,Q2LINE-1+I)
DO 13 J=1,4
YA(I,J)=GINQX(Q1LINE-1+I,Q2LINE-1+J)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP.EQ.'QG')THEN
DO 16 I=1,4
X1A(I)=QINGX(Q1LINE-1+I,101)
X2A(I)=QINGX(101,Q2LINE-1+I)
DO 15 J=1,4
YA(I,J)=QINGX(Q1LINE-1+I,Q2LINE-1+J)
15 CONTINUE
16 CONTINUE
ELSEIF(TYP.EQ.'GG')THEN
DO 18 I=1,4
X1A(I)=GINGX(Q1LINE-1+I,101)
X2A(I)=GINGX(101,Q2LINE-1+I)
DO 17 J=1,4
YA(I,J)=GINGX(Q1LINE-1+I,Q2LINE-1+J)
17 CONTINUE
18 CONTINUE
ELSE
WRITE(*,*)'error in GETPDFXINT: unknown integral type ',TYP
ENDIF
CALL POLINT2(X1A,X2A,YA,4,4,Q1**2,Q2**2,Y,DY)
GETPDFXINT=Y
C WRITE(*,*)'GETPDFXINT for',Q1,Q2,'interpolation/exact:',
C &Y/GETPDFXINT,TYP
END
DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q1,Q2,TYP)
IMPLICIT NONE
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,Q1,Q2,EPSI,YSTART,HFIRST
CHARACTER*2 TYP
DATA EPSI/1.d-4/
HFIRST=0.01d0
YSTART=0.d0
NOK=0
NBAD=0
XMAX=Q2
Z=0.d0
IF(TYP.EQ.'QQ')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,21)
ELSEIF(TYP.EQ.'QG')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,22)
ELSEIF(TYP.EQ.'GQ')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,23)
ELSEIF(TYP.EQ.'GG')THEN
CALL ODEINT(YSTART,Q1,Q2,EPSI,HFIRST,0.d0,NOK,NBAD,24)
ENDIF
GETPDFXINTEXACT=YSTART
END
DOUBLE PRECISION FUNCTION GETXSECINT(Q2,TM,TYP2)
IMPLICIT NONE
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--local variables
INTEGER QLINE,QCLOSE,TLINE,TCLOSE,I,J
DOUBLE PRECISION Q2,TM,X1A(4),X2A(4),YA(4,4),Y,DY
CHARACTER*2 TYP2
QCLOSE=INT((LOG(Q2)-LOG(INTQ1(1,101)))*99/
& (LOG(INTQ1(100,101))-LOG(INTQ1(1,101)))+1)
QLINE=MAX(QCLOSE-1,1)
QLINE=MIN(QLINE,100-3)
TCLOSE=INT((LOG(TM)-LOG(INTQ1(101,1)))*99/
& (LOG(INTQ1(101,100))-LOG(INTQ1(101,1)))+1)
TLINE=MAX(TCLOSE-1,1)
TLINE=MIN(TLINE,100-3)
IF(TYP2.EQ.'QA')THEN
DO 12 I=1,4
X1A(I)=INTQ1(QLINE-1+I,101)
X2A(I)=INTQ1(101,TLINE-1+I)
DO 11 J=1,4
YA(I,J)=INTQ1(QLINE-1+I,TLINE-1+J)
11 CONTINUE
12 CONTINUE
ELSEIF(TYP2.EQ.'QB')THEN
DO 18 I=1,4
X1A(I)=INTQ2(QLINE-1+I,101)
X2A(I)=INTQ2(101,TLINE-1+I)
DO 17 J=1,4
YA(I,J)=INTQ2(QLINE-1+I,TLINE-1+J)
17 CONTINUE
18 CONTINUE
ELSEIF(TYP2.EQ.'GA')THEN
DO 14 I=1,4
X1A(I)=INTG1(QLINE-1+I,101)
X2A(I)=INTG1(101,TLINE-1+I)
DO 13 J=1,4
YA(I,J)=INTG1(QLINE-1+I,TLINE-1+J)
13 CONTINUE
14 CONTINUE
ELSEIF(TYP2.EQ.'GB')THEN
DO 16 I=1,4
X1A(I)=INTG2(QLINE-1+I,101)
X2A(I)=INTG2(101,TLINE-1+I)
DO 15 J=1,4
YA(I,J)=INTG2(QLINE-1+I,TLINE-1+J)
15 CONTINUE
16 CONTINUE
ELSE
WRITE(*,*)'error in GETXSECINT: unknown integral type ',TYP2
ENDIF
CALL POLINT2(X1A,X2A,YA,4,4,Q2,TM,Y,DY)
GETXSECINT=Y
END
DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Q1,Q2,GETINSUDARED
CHARACTER*2 TYP
IF(Q2.LE.Q1)THEN
GETINSUDAFAST=1.d0
ELSEIF(Q1.EQ.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.0.d0) WRITE(*,*)'ERROR: GETINSUDAFAST < 0:',
&GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP
END
DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2)
IMPLICIT NONE
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2),
&SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--local variables
INTEGER QCLOSE,QBIN,I
DOUBLE PRECISION Q,XA(4),YA(4),Y,DY
CHARACTER*2 TYP2
QCLOSE=INT((Q-SUDAQQ(1,1))*100/(SUDAQQ(100,1)-SUDAQQ(1,1))+1)+1
QBIN=MAX(QCLOSE-1,1)
QBIN=MIN(QBIN,100-3)
C WRITE(*,*)'getinsudared: Q,Qbin=',Q,QBIN
IF(TYP2.EQ.'QQ')THEN
DO 16 I=1,4
XA(I)=SUDAQQ(QBIN-1+I,1)
YA(I)=SUDAQQ(QBIN-1+I,2)
16 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'QG')THEN
DO 17 I=1,4
XA(I)=SUDAQG(QBIN-1+I,1)
YA(I)=SUDAQG(QBIN-1+I,2)
17 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'GG')THEN
DO 18 I=1,4
XA(I)=SUDAGG(QBIN-1+I,1)
YA(I)=SUDAGG(QBIN-1+I,2)
18 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSEIF(TYP2.EQ.'GC')THEN
DO 19 I=1,4
XA(I)=SUDAGC(QBIN-1+I,1)
YA(I)=SUDAGC(QBIN-1+I,2)
19 CONTINUE
CALL POLINT(XA,YA,4,Q,Y,DY)
GETINSUDARED=Y
ELSE
WRITE(*,*)'error in GETINSUDARED: unknown type ',TYP2
ENDIF
END
***********************************************************************
*** function getsscat
***********************************************************************
*** returns the integrated scattering cross section for a parton
*** of type 'type1' and energy 'en'
***********************************************************************
- DOUBLE PRECISION FUNCTION GETSSCAT(EN,MP,TYPE1,TYPE2,MS1,MDEB)
+ DOUBLE PRECISION FUNCTION GETSSCAT(EN,MP,LW,TYPE1,TYPE2,MS1,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--variables for cross section integration
COMMON/XSECV/QLOW
DOUBLE PRECISION QLOW
C--local variables
INTEGER NOK,NBAD
- DOUBLE PRECISION UP,EN,SCATPRIMFUNC,CCOL,T3,NTAU,MP,
+ DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,T3,NTAU,MP,
&LOW,GETPDFXINT,GETXSECINT,MS1,MDEB
CHARACTER TYPE1,TYPE2
+ MS1=MS
+ MDEB=MD
+
IF(TYPE1.EQ.'Q')THEN
CCOL=2./3.
ELSE
CCOL=3./2.
ENDIF
UP=2.*EN*MS1-2.*MS1*MP
C LOW=MAX(Q0**2,MP**2)
- LOW=0.d0
+ 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))
ELSE
GETSSCAT=0.d0
ENDIF
C WRITE(*,*)'sigma=',GETSSCAT
LOW=MAX(Q0**2,MP**2)
+C WRITE(*,*)'low,up=',LOW,UP
IF(UP.GT.LOW)THEN
IF(TYPE1.EQ.'Q')THEN
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+GETPDFXINT(SQRT(LOW),SQRT(UP),'GQ')
& *3.*SCATPRIMFUNC(UP,MDEB)/2.
GETSSCAT=GETSSCAT-GETXSECINT(LOW,UP,'QA')
ENDIF
+C WRITE(*,*)'get sigma for quark: first and second term:',
+C &GETPDFXINT(SQRT(LOW),SQRT(UP),'GQ')*3.*SCATPRIMFUNC(UP,MDEB)/2.,
+C &GETXSECINT(LOW,UP,'QA')
+C WRITE(*,*)'final sigma=',GETSSCAT
ELSE
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN
GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)-
- &SCATPRIMFUNC(LOW,MDEB))
+ & SCATPRIMFUNC(LOW,MDEB))
& - GETXSECINT(LOW,UP,'GB')
-C WRITE(*,*)'get gluon cross section: first and second term:',
-C &CCOL*(SCATPRIMFUNC(UP)-SCATPRIMFUNC(LOW)),
-C &GETXSECINT(LOW,UP,'GB'),LOW,UP
+C WRITE(*,*)'get sigma for gluon: first and second term:',
+C &CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB)),
+C &-GETXSECINT(LOW,UP,'GB')
+C WRITE(*,*)'sigma=',GETSSCAT
ENDIF
IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN
- GETSSCAT=GETSSCAT+2.*GETPDFXINT(SQRT(LOW),SQRT(UP),'QG')
+ GETSSCAT=GETSSCAT+GETPDFXINT(SQRT(LOW),SQRT(UP),'QG')
& *2.*SCATPRIMFUNC(UP,MDEB)/3.
GETSSCAT=GETSSCAT-2.*GETXSECINT(LOW,UP,'GA')
+C WRITE(*,*)'get sigma for gluon: third and fourth term:',
+C &GETPDFXINT(SQRT(LOW),SQRT(UP),'QG')*2.*SCATPRIMFUNC(UP,MDEB)/3.,
+C &-2.*GETXSECINT(LOW,UP,'GA')
+C WRITE(*,*)'final sigma=',GETSSCAT
ENDIF
-C WRITE(*,*)'ystart,mp^2,up=',YSTART,LOW,UP
-C WRITE(*,*)'sigma=',GETSSCAT
-C WRITE(*,*)
ENDIF
ENDIF
+ IF(GETSSCAT.LT.-1.d-4)
+ & WRITE(*,*) 'error: cross section < 0',GETSSCAT,'for',
+ & EN,MP,TYPE1,TYPE2,MS1,MDEB
+ GETSSCAT=MAX(GETSSCAT,0.d0)
END
***********************************************************************
*** function getnoscat
***********************************************************************
*** returns the probability for no scattering of a parton of
*** type 'type2', energy 'ep' and velocity 'beta' between times
*** 'ti' and 'ti'+'dti' (the finite plasma lifetime is taken
*** into account)
***********************************************************************
DOUBLE PRECISION FUNCTION GETNOSCAT(EP,MP1,TI,DTI,TYPE2,BETA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION EP,TI,DTI,GETSSCAT,BETA,MP1
CHARACTER TYPE2
C--no scattering if the parton is produced after the end of the QGP
C lifetime
IF((TI.GE.LTIME).OR.(TEMP.EQ.0.d0))THEN
GETNOSCAT=1.d0
GOTO 40
ENDIF
C--end of QGP lifetime may be reached during parton lifetime
IF((TI+DTI).GE.LTIME) DTI=LTIME-TI
C--get no-scattering probility
- GETNOSCAT=EXP(-GETSSCAT(EP,MP1,TYPE2,'C',MS,MD)*NP*DTI*5.*BETA)
+ GETNOSCAT=EXP(-GETSSCAT(EP,MP1,0.d0,TYPE2,'C',MS,MD)
+ & *NP*DTI*5.*BETA)
40 END
***********************************************************************
*** function getdeltal
***********************************************************************
*** generates a delta t after which a scattering of a parton of
*** type 'type3', energy 'e1' and velocity 'bet1' takes place,
*** starting time is 't1' and the maximum delta t is 'dlmax'
***********************************************************************
DOUBLE PRECISION FUNCTION GETDELTAL(E1,MAS1,T1,DLMAX,TYPE3,BET1)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION E1,MAS1,T1,DLMAX,BET1,LAMBDA,GETSSCAT,R1,PYR
CHARACTER TYPE3
- LAMBDA=1.d0/(NP*GETSSCAT(E1,MAS1,TYPE3,'C',MS,MD)*5.d0*BET1)
+ LAMBDA=1.d0/(NP*GETSSCAT(E1,MAS1,0.d0,TYPE3,'C',MS,MD)*5.d0*BET1)
C--end of QGP lifetime may be reached during parton lifetime
IF((T1+DLMAX).GE.LTIME) DLMAX=LTIME-T1
R1=PYR(0)
GETDELTAL=-LAMBDA*LOG(1.+R1*(EXP(-DLMAX/LAMBDA)-1.))
END
DOUBLE PRECISION FUNCTION GETMOMOLD(TYPE4)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
INTEGER I,NINTV2
DOUBLE PRECISION X(1000),Y(1000),DLMIN,FACTOR2,
&A(1000),B(1000),INTTMP,INTE(1000),PYR,R1,R2,R3,AA,BB,X1,X2,
&CAND1,CAND2,CAND,YY,GETNOSCAT,GETSSCAT,BET1,DLMAX,Y1,Y2
CHARACTER TYPE4
DATA DLMIN/0.d0/
NINTV2=10
FACTOR2=1.5d0
DLMAX=10.*TEMP
DO 45 I=0,NINTV2
X(I+1)=I*(DLMAX-DLMIN)/(NINTV2*1.d0)+DLMIN
IF(TYPE4.EQ.'Q')THEN
Y(I+1)=1./(EXP(SQRT(X(I+1)**2+MS**2)/TEMP)+1)
ELSE
Y(I+1)=1./(EXP(SQRT(X(I+1)**2+MS**2)/TEMP)-1)
ENDIF
45 CONTINUE
C PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 46 I=1,NINTV2
A(I)=(Y(I+1)-Y(I))/(X(I+1)-X(I))
B(I)=Y(I)-A(I)*X(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(X(I+1)**2-X(I)**2)/2.+B(I)*(X(I+1)-X(I))
46 CONTINUE
49 R1=PYR(0)
DO 47 I=1,NINTV2
IF(R1.LT.INTE(I)/INTE(NINTV2))THEN
X1=X(I)
X2=X(I+1)
AA=A(I)
BB=B(I)
GOTO 48
ENDIF
47 CONTINUE
48 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+X1**2+R2*(X2**2-X1**2)
& +2.*BB*(X1+R2*(X2-X1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+X1**2+R2*(X2**2-X1**2)
& +2.*BB*(X1+R2*(X2-X1))/AA)
IF((CAND1.GT.X1).AND.(CAND1.LT.X2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
IF(TYPE4.EQ.'Q')THEN
YY=1./(EXP(SQRT(CAND**2+MS**2)/TEMP)+1)/(AA*CAND+BB)
ELSE
YY=1./(EXP(SQRT(CAND**2+MS**2)/TEMP)-1)/(AA*CAND+BB)
ENDIF
C IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
C IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R3=PYR(0)
IF(R3.GT.YY)THEN
GOTO 49
ELSE
GETMOMOLD=CAND
ENDIF
END
***********************************************************************
*** function getmass
***********************************************************************
*** picks a virtuality for a parton of type 'type' with energy
*** 'ep', maximum virtuality 'qbmax', mother virtuality 'qm'
*** and energy fraction 'zm' of splitting parton
*** returns 0.d0 for masses below cut-off Q0
***********************************************************************
DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,QM,ZM,EP,TYPE,
& MAX2,TIME,INS)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--technical variables for getmass
COMMON/VIOL/FACTOR,NINTV,NVIOLQ,NVSEVQ,NVIOLG,NVSEVG,NEWMC
INTEGER NINTV,NVIOLQ,NVIOLG,NVSEVQ,NVSEVG
DOUBLE PRECISION FACTOR
LOGICAL NEWMC
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
INTEGER I
DOUBLE PRECISION QBMAX,R1,R2,PYR,CAND,Y,GETSUDAKOV,AA,BB,
&CC,DD,EP,PI,GETPROBA,GETSPLITI,MAXY,MIN2,MAX2,A(101),
&B(101),QM,ZM,MIN3,MAX3,QHELP,ALPHAS,INTE(101),R3,PQ(101),
&Q(101),Q1,Q2,INTTMP,CAND1,CAND2,MASS,TIME,PQ1,PQ2,QBMIN,
&GETMASSVETO,GETMASSVETOIN
CHARACTER*2 TYPE
LOGICAL INS
IF(.NOT.NEWMC)THEN
DATA AA/5.d0/
DATA BB/0.1d0/
DATA CC/25.d0/
DATA DD/0.1d0/
ENDIF
IF(VETO)THEN
IF(INS)THEN
GETMASS=GETMASSVETOIN(QBMIN,QBMAX,QM,ZM,EP,TYPE,MAX2,TIME)
ELSE
GETMASS=GETMASSVETO(QBMIN,QBMAX,QM,ZM,EP,TYPE,MAX2,TIME)
ENDIF
RETURN
ENDIF
MIN3=MAX(QMIN,QBMIN)
MAX3=MIN(QBMAX,MAX2)
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.MIN3) THEN
GETMASS=0.d0
RETURN
ENDIF
C--probability to go to Q_0
IF(QBMIN.EQ.0.d0)THEN
R1=PYR(0)
IF(R1.LT.GETSUDAKOV(MAX3,QM,MIN3,ZM,EP,TYPE,TIME,INS))THEN
GETMASS=0.d0
RETURN
ENDIF
ENDIF
C--vacuum calculations
43 IF((TYPE.EQ.'QQ').OR.(TYPE.EQ.'GQ'))THEN
IF(NEWMC)THEN
C--generate value from P(t_max,t) for quark with importance sampling
DO 45 I=0,NINTV
Q(I+1)=I*(MAX3-MIN3)/(NINTV*1.d0)+MIN3
PQ(I+1)=FACTOR*GETPROBA(MAX3,Q(I+1),QM,ZM,EP,TYPE,TIME,INS)
45 CONTINUE
PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 46 I=1,NINTV
A(I)=(PQ(I+1)-PQ(I))/(Q(I+1)-Q(I))
B(I)=PQ(I)-A(I)*Q(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(Q(I+1)**2-Q(I)**2)/2.
& +B(I)*(Q(I+1)-Q(I))
46 CONTINUE
49 R1=PYR(0)
DO 47 I=1,NINTV
IF(R1.LT.INTE(I)/INTE(NINTV))THEN
Q1=Q(I)
Q2=Q(I+1)
AA=A(I)
BB=B(I)
GOTO 48
ENDIF
47 CONTINUE
48 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
IF((CAND1.GT.Q1).AND.(CAND1.LT.Q2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)/(AA*CAND+BB)
IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R3=PYR(0)
IF(R3.GT.Y)THEN
GOTO 49
ELSE
MASS=CAND
ENDIF
ELSE
C--generate value from P(t_max,t) for quark with importance sampling
C (f(x)=a/(x+b))
40 R1=PYR(0)
CAND=(MIN3+BB)**(1-R1)*(MAX3+BB)**R1-BB
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& *(CAND+BB)/AA
IF(Y.GT.1.d0) NVIOLQ=NVIOLQ+1
IF(Y.GT.1.01d0) NVSEVQ=NVSEVQ+1
R2=PYR(0)
IF(R2.GT.Y)THEN
GOTO 40
ELSE
MASS=CAND
ENDIF
ENDIF
ELSE
IF(NEWMC)THEN
C--generate value from P(Q_max,Q) for gluon with importance sampling
DO 55 I=0,NINTV
Q(I+1)=I*(MAX3-MIN3)/(NINTV*1.d0)+MIN3
PQ(I+1)=FACTOR*GETPROBA(MAX3,Q(I+1),QM,ZM,EP,TYPE,
& TIME,INS)
55 CONTINUE
PQ(1)=MAX(PQ(1),PQ(2)*0.9)
DO 56 I=1,NINTV
A(I)=(PQ(I+1)-PQ(I))/(Q(I+1)-Q(I))
B(I)=PQ(I)-A(I)*Q(I)
IF(I.EQ.1)THEN
INTTMP=0.d0
ELSE
INTTMP=INTE(I-1)
ENDIF
INTE(I)=INTTMP+A(I)*(Q(I+1)**2-Q(I)**2)/2.
& +B(I)*(Q(I+1)-Q(I))
56 CONTINUE
59 R1=PYR(0)
DO 57 I=1,NINTV
IF(R1.LT.INTE(I)/INTE(NINTV))THEN
Q1=Q(I)
Q2=Q(I+1)
AA=A(I)
BB=B(I)
GOTO 58
ENDIF
57 CONTINUE
58 R2=PYR(0)
CAND1=-BB/AA+SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
CAND2=-BB/AA-SQRT(BB**2/AA**2+Q1**2+R2*(Q2**2-Q1**2)
& +2.*BB*(Q1+R2*(Q2-Q1))/AA)
IF((CAND1.GT.Q1).AND.(CAND1.LT.Q2))THEN
CAND=CAND1
ELSE
CAND=CAND2
ENDIF
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& /(AA*CAND+BB)
IF(Y.GT.1.d0) NVIOLG=NVIOLG+1
IF(Y.GT.1.01d0) NVSEVG=NVSEVG+1
R3=PYR(0)
IF(R3.GT.Y)THEN
GOTO 59
ELSE
MASS=CAND
ENDIF
ELSE
C--generate value from P(Q_max,Q) for gluon with importance sampling
C (f(x)=c/(x+d))
41 R1=PYR(0)
CAND=(MIN3+DD)**(1-R1)*(MAX3+DD)**R1-DD
Y=GETPROBA(MAX3,CAND,QM,ZM,EP,TYPE,TIME,INS)
& *(CAND+DD)/CC
IF(Y.GT.1.d0) NVIOLG=NVIOLG+1
IF(Y.GT.1.01d0) NVSEVG=NVSEVG+1
R2=PYR(0)
IF(R2.GT.Y)THEN
GOTO 41
ELSE
MASS=CAND
ENDIF
ENDIF
ENDIF
44 GETMASS=MASS
END
DOUBLE PRECISION FUNCTION GETMASSVETO(QMIN2,QBMAX2,QM2,ZM2,EP2,
& TYPE,MAX22,TIME2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
DOUBLE PRECISION QBMAX2,QM2,ZM2,EP2,MAX22,TIME2,MAX3,RZERO,CAND,
&REQUAL,TEQUAL,R,R2,PYR,ALPH,ALPHAS,PI,TZERO,TMAX,PREF,LNA,LN4,
&GETSPLITI,QCAND,TRUEVAL,QMIN2
CHARACTER*2 TYPE
DATA PI/3.141592653589793d0/
ALPH=ALPHAS((KTMIN*LPS)**2,LPS)
LNA=LOG((4.*EP2**2-QMIN**2)/LPS**2)
LN4=LOG(4.d0)
IF(TYPE.EQ.'QQ')THEN
PREF=4.*ALPH/(3.*2.*PI)
ELSE
PREF=3.*ALPH/(2.*PI)
ENDIF
MAX3=MIN(QBMAX2,MAX22)
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.QMIN) THEN
GETMASSVETO=0.d0
RETURN
ENDIF
TZERO=LOG(QMIN**2/LPS**2)
TMAX=LOG(MAX3**2/LPS**2)
TEQUAL=LOG(QMIN*EP2/LPS**2)
21 IF(TMAX.GT.TEQUAL)THEN
RZERO=EXP(PREF*(LN4**2-(TEQUAL-TZERO+LN4)**2
& -(TEQUAL-LNA)**2+(TMAX-LNA)**2))
ELSE
RZERO=EXP(PREF*(LN4**2-(TMAX-TZERO+LN4)**2))
ENDIF
REQUAL=EXP(PREF*(-(TEQUAL-LNA)**2+(TMAX-LNA)**2))
IF(QMIN2.EQ.0.d0)THEN
R=PYR(0)
ELSE
R=PYR(0)*(1.d0-RZERO)+RZERO
ENDIF
IF(R.LE.RZERO)THEN
GETMASSVETO=0.d0
RETURN
ELSEIF(TMAX.GT.TEQUAL)THEN
IF(R.LT.REQUAL)THEN
CAND=SQRT((TEQUAL-TZERO+LN4)**2+(TEQUAL-LNA)**2-(TMAX-LNA)**2
& +LOG(R)/PREF)+TZERO-LN4
ELSE
CAND=-SQRT((TMAX-LNA)**2-LOG(R)/PREF)+LNA
ENDIF
ELSE
CAND=SQRT((TMAX-TZERO+LN4)**2+LOG(R)/PREF)+TZERO-LN4
ENDIF
QCAND=SQRT(LPS**2*EXP(CAND))
TRUEVAL=GETSPLITI(QM2,QCAND,ZM2,EP2,TYPE,TIME2)
R2=PYR(0)
IF(CAND.LT.TEQUAL)THEN
IF(R2.LT.TRUEVAL/(2.*PREF*(CAND-TZERO+LN4)))THEN
GETMASSVETO=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
ELSE
IF(R2.LT.TRUEVAL/(2.*PREF*(LNA-CAND)))THEN
GETMASSVETO=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
ENDIF
END
DOUBLE PRECISION FUNCTION GETMASSVETOIN(QMIN2,QBMAX2,QM2,ZM2,EP2,
& TYPE,MAX22,TIME2)
IMPLICIT NONE
C--Common block of Pythia
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
COMMON/TEMP/EXACT,VETO
LOGICAL EXACT,VETO
C--local variables
DOUBLE PRECISION QBMAX2,QM2,ZM2,EP2,MAX22,TIME2,MAX3,RZERO,CAND,
&REQUAL,TEQUAL,R,R2,PYR,ALPH,ALPHAS,PI,TZERO,TMAX,PREF,LNA,LN4,
&GETINSPLITI,QCAND,TRUEVAL,QMIN2
CHARACTER*2 TYPE
DATA PI/3.141592653589793d0/
ALPH=ALPHAS((KTMIN*LPS)**2,LPS)
LNA=LOG((4.*EP2**2-QMIN**2)/LPS**2)
LN4=LOG(4.d0)
IF((TYPE.EQ.'QQ').OR.((TYPE.EQ.'GQ')))THEN
PREF=4.*ALPH/(3.*2.*PI)
ELSE
PREF=3.*ALPH/(2.*PI)
ENDIF
MAX3=MIN(QBMAX2,MAX22)
C WRITE(*,*)'GETMASS: max3, qmin',MAX3,QMIN
C--check if virtual mass is allowed, return 0.d0 otherwise
IF(MAX3.LE.QMIN) THEN
GETMASSVETOIN=0.d0
RETURN
ENDIF
TZERO=LOG(QMIN**2/LPS**2)
TMAX=LOG(MAX3**2/LPS**2)
21 RZERO=EXP(PREF*(LN4**2-(TMAX-TZERO+LN4)**2))
IF(QMIN2.EQ.0.d0)THEN
R=PYR(0)
ELSE
R=PYR(0)*(1.d0-RZERO)+RZERO
ENDIF
IF(R.LE.RZERO)THEN
GETMASSVETOIN=0.d0
RETURN
ELSE
CAND=SQRT((TMAX-TZERO+LN4)**2+LOG(R)/PREF)+TZERO-LN4
ENDIF
QCAND=SQRT(LPS**2*EXP(CAND))
TRUEVAL=GETINSPLITI(QCAND,TYPE)
R2=PYR(0)
IF(R2.LT.TRUEVAL/(2.*PREF*(CAND-TZERO+LN4)))THEN
GETMASSVETOIN=QCAND
RETURN
ELSE
TMAX=CAND
GOTO 21
ENDIF
END
***********************************************************************
*** function generatez
***********************************************************************
*** picks a value from the splitting function for a splitting of
*** type 'type' with virtuality 'ti' and energy 'ea' of the
*** splitting parton and additional contraint 'epsi' due to
*** angular ordering
***********************************************************************
DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI
CHARACTER*2 TYPE
C WRITE(*,*)'generatez: ti=',TI
C WRITE(*,*)'generatez: ea=',EA
C WRITE(*,*)'generatez: epsi=',EPSI
C WRITE(*,*)'generatez: type=',TYPE
IF(TI.EQ.0.d0)THEN
EPS=EPSI
ELSE
IF(CONSTR)THEN
EPS=MAX(0.5-0.5*SQRT(1.-QMIN**2/TI)
& *SQRT(1.-TI/EA**2),MINEN*Q0/EA,EPSI)
C EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI)
C & *SQRT(1-TI/EA**2),MINEN*Q0/EA,EPSI)
ELSE
EPS=MAX(0.5-0.5*SQRT(1.-TI/EA**2),MINEN*Q0/EA,EPSI)
ENDIF
ENDIF
C WRITE(*,*)'generatez: eps=',EPS
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
C WRITE(*,*)'generatez: generatez=',GENERATEZ
61 END
***********************************************************************
*** function ifqqbar
***********************************************************************
*** decide whether a gluon with virtuality 'virt' and energy
*** 'ea' should split in two gluons or a qqbar pair
***********************************************************************
LOGICAL FUNCTION IFQQBAR(VIRTB,VIRTA,ZAA,EB,TIM)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION VIRTB,VIRTA,ZAA,EB,INTG,INTQ,R,PYR,
&GETSPLITI,TIM
C WRITE(*,*)'ifqqbar: virt=',VIRT
C WRITE(*,*)'ifqqbar: ea=',EA
C--calculate integral of g->gg splitting fnc
INTG=GETSPLITI(VIRTA,VIRTB,ZAA,EB,'GG',TIM)
C--calculate integral of g->q qbar splitting fnc
INTQ=GETSPLITI(VIRTA,VIRTB,ZAA,EB,'QG',TIM)
C--decide which process to use according to probility
R=PYR(0)
IF(R.LT.(INTQ/(INTQ+INTG)))THEN
IFQQBAR=.TRUE.
ELSE
IFQQBAR=.FALSE.
ENDIF
C WRITE(*,*)'ifqqbar: ifqqbar=',IFQQBAR
END
***********************************************************************
*** subroutine showana
***********************************************************************
*** analysis of the shower
***********************************************************************
SUBROUTINE SHOWANA(PMAX)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
COMMON/MEANKT/NKT1(20),SUMKT1(20)
INTEGER NKT1
DOUBLE PRECISION SUMKT1
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
INTEGER I,NGLUON,MAXLINE,NSCAT,J,PL,NKT2(20),II
DOUBLE PRECISION PMAX,XP,PYP,THETA,PHI,ENMAX,PTOT(4),DP,DE,
&DQ,XI,TRIGMIN,TRIGMAX,ASSMIN,THETA2,PHI2,SUMKT2(20)
DATA TRIGMIN/2.5d0/
DATA TRIGMAX/4.d0/
DATA ASSMIN/1.d0/
DO 76 I=1,20
NKT2(I)=0
SUMKT2(I)=0.d0
76 CONTINUE
C--off we go
NGLUON=0
PTOT(1)=0.d0
PTOT(2)=0.d0
PTOT(3)=0.d0
PTOT(4)=0.d0
ENMAX=0.d0
MAXLINE=0
C--rotate event such that initiating parton points in z-direction
THETA=PYP(2,13)
PHI=PYP(2,15)
CALL PYROBO(2,N,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(2,N,-THETA,0d0,0d0,0d0,0d0)
DO 70 I=2,N
CC--lifetimes of decayed partons
C IF(P(I,5).NE.0d0) CALL HF1(104,REAL(P(I,4)/P(I,5)**2*0.2),1.)
CC--virtuality ratio mass(daughter)/mass(mother)
C IF((P(I,5).NE.0d0).AND.(I.NE.2))
C & CALL HF1(108,REAL(P(I,5)/P(K(I,3),5)),1.)
C--analysis of final state partons
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/PMAX
XI=LOG(1/XP)
C--xi
C IF(PYP(I,6).NE.0) CALL HF1(100,REAL(XI),1.)
C--energy
CALL HF1(321,REAL(P(I,4)),EVWEIGHT)
C--theta wrt jet axis
CALL HF1(118,REAL(PYP(I,13)),EVWEIGHT)
C--theta weighted with energy
CALL HF1(120,REAL(PYP(I,13)),REAL(P(I,4)))
C--2D-histogram xi - theta
CALL HF2(200,REAL(LOG(1/XP)),REAL(PYP(I,13)),EVWEIGHT)
C--kt wrt jet axis
IF(I.GT.2) CALL HF1(115,REAL(PYP(I,10)),EVWEIGHT)
C--kt above threshold
IF((I.GT.2).AND.(P(I,4).GT.0.5))
& CALL HF1(401,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.1.))
& CALL HF1(402,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.2.))
& CALL HF1(403,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.5.))
& CALL HF1(404,REAL(PYP(I,10)),EVWEIGHT)
IF((I.GT.2).AND.(P(I,4).GT.10.))
& CALL HF1(405,REAL(PYP(I,10)),EVWEIGHT)
C--mean kt above threshold
DO 77 II=1,20
IF((I.GT.2).AND.(P(I,4).GT.(II-1)/2.))THEN
NKT1(II)=NKT1(II)+1
SUMKT1(II)=SUMKT1(II)+PYP(I,10)
NKT2(II)=NKT2(II)+1
SUMKT2(II)=SUMKT2(II)+PYP(I,10)
ENDIF
77 CONTINUE
C--xi of quarks
IF(K(I,2).EQ.1)THEN
CALL HF1(101,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of antiquarks
ELSEIF(K(I,2).EQ.-1)THEN
CALL HF1(120,REAL(LOG(1/XP)),EVWEIGHT)
ELSE
C--xi of gluons
CALL HF1(102,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons from gluon splitting
IF(K(K(I,3),2).EQ.21) CALL HF1(121,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons radiated by quarks
IF(K(K(I,3),2).EQ.1) CALL HF1(122,REAL(LOG(1/XP)),EVWEIGHT)
C--xi of gluons radiated by antiquarks
IF(K(K(I,3),2).EQ.-1) CALL HF1(123,REAL(LOG(1/XP)),EVWEIGHT)
NGLUON=NGLUON+1
ENDIF
C--find leading parton
IF(P(I,4).GT.ENMAX)THEN
ENMAX=P(I,4)
MAXLINE=I
ENDIF
C--determine number of scatterings experienced by parton
NSCAT=0
PL=K(I,3)
DO 73 J=1,N
IF(K(PL,1).EQ.12) NSCAT=NSCAT+1
IF(K(PL,3).EQ.0)THEN
GOTO 74
ELSE
PL=K(PL,3)
ENDIF
73 CONTINUE
C--2D-histogramm xi - number of scatterings
74 CALL HF2(220,REAL(XI),REAL(NSCAT),EVWEIGHT)
C--PHENIX-like correlation in theta and kt
IF((P(I,4).GT.TRIGMIN).AND.(P(I,4).LT.TRIGMAX))THEN
DO 75 J=1,N
IF((K(J,1).LT.11).AND.(P(J,4).GT.ASSMIN)
& .AND.(P(J,4).LT.P(I,4)))THEN
THETA2=PYP(I,13)
PHI2=PYP(I,15)
CALL PYROBO(J,J,THETA2,0d0,0d0,0d0,0d0)
CALL PYROBO(J,J,0d0,PHI2,0d0,0d0,0d0)
CALL HF1(135,REAL(PYP(J,13)),EVWEIGHT)
CALL HF1(400,REAL(PYP(J,10)),EVWEIGHT)
CALL PYROBO(J,J,0d0,-PHI2,0d0,0d0,0d0)
CALL PYROBO(J,J,-THETA2,0d0,0d0,0d0,0d0)
ENDIF
75 CONTINUE
ENDIF
ENDIF
70 CONTINUE
DO 78 II=1,20
IF(NKT2(II).GT.0) CALL HF2(407,(II-1)/2.,
& REAL(SUMKT2(II)/NKT2(II)),EVWEIGHT)
78 CONTINUE
C--theta of leading parton
CALL HF1(117,REAL(PYP(MAXLINE,13)),EVWEIGHT)
C--rotate back
CALL PYROBO(2,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(2,N,0d0,PHI,0d0,0d0,0d0)
C--number of final state gluons in the jet
CALL HF1(106,REAL(NGLUON),EVWEIGHT)
C--rotate such the leading particle points in z-direction
THETA=PYP(MAXLINE,13)
PHI=PYP(MAXLINE,15)
CALL PYROBO(2,N,0d0,-PHI,0d0,0d0,0d0)
CALL PYROBO(2,N,-THETA,0d0,0d0,0d0,0d0)
DO 71 I=2,N
IF((K(I,1).LT.11).AND.(I.NE.MAXLINE))THEN
IF(I.GT.2) THEN
C--kt wrt leading parton
CALL HF1(116,REAL(PYP(I,10)),EVWEIGHT)
C--theta wrt leading parton
CALL HF1(119,REAL(PYP(I,13)),EVWEIGHT)
IF(P(MAXLINE,4).GT.PMAX/10.d0) THEN
C--kt and theta wrt to leading parton for leading parton above E_jet/10
CALL HF1(131,REAL(PYP(I,10)),EVWEIGHT)
CALL HF1(133,REAL(PYP(I,13)),EVWEIGHT)
IF(P(I,4).GT.PMAX/20.d0)THEN
C--kt and theta wrt to leading parton for leading parton above E_jet/10 and
C associated above E_jet/20
CALL HF1(132,REAL(PYP(I,10)),EVWEIGHT)
CALL HF1(134,REAL(PYP(I,13)),EVWEIGHT)
ENDIF
ENDIF
ENDIF
ENDIF
71 CONTINUE
C--rotate back
CALL PYROBO(2,N,THETA,0d0,0d0,0d0,0d0)
CALL PYROBO(2,N,0d0,PHI,0d0,0d0,0d0)
C--calculate total 4-momentum of jet (including recoil)
DO 72 I=2,N
IF(K(I,1).LT.11)THEN
PTOT(1)=PTOT(1)+P(I,1)
PTOT(2)=PTOT(2)+P(I,2)
PTOT(3)=PTOT(3)+P(I,3)
PTOT(4)=PTOT(4)+P(I,4)
ENDIF
72 CONTINUE
C--total jet energy gain (or loss)
DE=PTOT(4)-P(2,4)
C--total jet 3-momentum gain (or loss)
DP=SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)-P(2,1)
C--total jet virtuality gain (or loss)
DQ=PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2 - P(2,5)**2
CALL HF1(140,REAL(DE),EVWEIGHT)
CALL HF1(141,REAL(DP),EVWEIGHT)
CALL HF1(142,REAL(DQ),EVWEIGHT)
END
SUBROUTINE NJETANA(NJ,PARTON,E)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,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
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--local variables
- INTEGER NJ,I,NJET,NHIS
+ INTEGER NJ,I,NJET,NHIS,NPART
DOUBLE PRECISION E,PYP,XI,XP,LOGYCUT
LOGICAL PARTON
+ NPART=0
+ DO 666 I=1,N
+ IF(K(I,1).EQ.1) NPART=NPART+1
+ 666 CONTINUE
+ IF(NPART.EQ.0) RETURN
+
IF(PARTON)THEN
NHIS=0
ELSE
NHIS=10
ENDIF
IF(NJ.EQ.1)THEN
DO 78 I=1,N
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/E
XI=LOG(1/XP)
IF(PARTON)THEN
CALL HF1(100,REAL(XI),EVWEIGHT)
ELSE
IF(PYP(I,6).NE.0) CALL HF1(110,REAL(XI),EVWEIGHT)
ENDIF
ENDIF
78 CONTINUE
ENDIF
DO 76 I=0,29
LOGYCUT=-6.+I*0.2
PARU(45)=10.**LOGYCUT
IF(I.EQ.0)THEN
MSTU(48)=0
ELSE
MSTU(48)=1
ENDIF
NJET=0
CALL PYCLUS(NJET)
IF(NJET.EQ.1)THEN
CALL HF2(600+NHIS+1,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.2)THEN
CALL HF2(600+NHIS+2,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.3)THEN
CALL HF2(600+NHIS+3,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.EQ.4)THEN
CALL HF2(600+NHIS+4,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ELSEIF(NJET.GE.5)THEN
CALL HF2(600+NHIS+5,REAL(LOGYCUT),REAL(NJ-1),EVWEIGHT)
ENDIF
76 CONTINUE
END
SUBROUTINE EVSHAPEANA(NJ,PARTON,E)
IMPLICIT NONE
C--pythia common block
C COMMON/PYJETS/N,NPAD,K(8000,5),P(8000,5),V(8000,5)
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Common block of PAW
INTEGER NHBOOK,NPRIME,NTAGS,NINFO
PARAMETER (NHBOOK=5000000,NPRIME=30000,NINFO=1)
COMMON /PAWC/ PAW(NHBOOK)
REAL PAW
C--event weight
COMMON/WEIGHT/EVWEIGHT
REAL EVWEIGHT
C--local variables
- INTEGER NJ,I,NHIS
+ INTEGER NJ,I,NHIS,NPART
DOUBLE PRECISION E,PYP,XI,XP,SPHE,APLA,THRU,OBLA,MH,ML,
&TAXIS(3),SUM1,SUM2,BT,VECT(3)
LOGICAL PARTON
+ NPART=0
+ DO 666 I=1,N
+ IF(K(I,1).EQ.1) NPART=NPART+1
+ 666 CONTINUE
+ IF(NPART.EQ.0) RETURN
+
IF(PARTON)THEN
NHIS=0
ELSE
NHIS=10
ENDIF
IF(NJ.EQ.1)THEN
DO 78 I=1,N
IF(K(I,1).LT.11)THEN
XP=PYP(I,8)/E
XI=LOG(1/XP)
IF(PARTON)THEN
CALL HF1(100,REAL(XI),EVWEIGHT)
CALL HF1(322,REAL(PYP(I,10)),EVWEIGHT)
ELSE
IF(PYP(I,6).NE.0) CALL HF1(110,REAL(XI),EVWEIGHT)
IF((PYP(I,6).NE.0).OR.(K(I,2).EQ.111))
& CALL HF1(321,REAL(PYP(I,10)),EVWEIGHT)
ENDIF
ENDIF
78 CONTINUE
ENDIF
CALL PYTHRU(THRU,OBLA)
CALL HF2(700+NHIS+8,REAL(P(N+1,4)),REAL(NJ-1),EVWEIGHT)
CALL HF2(700+NHIS+3,REAL(P(N+2,4)),REAL(NJ-1),EVWEIGHT)
CALL HF2(700+NHIS+4,REAL(P(N+3,4)),REAL(NJ-1),EVWEIGHT)
END
***********************************************************************
*** function scatprimfunc
***********************************************************************
*** evaluates the primitive function in the scattering integral
***********************************************************************
DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB
DATA PI/3.141592653589793d0/
IF(BRICK)THEN
SCATPRIMFUNC= - 2.*PI*ALPHAS(0.d0,LQCD)**2/(T+MDEB**2)
ELSE
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
ENDIF
C WRITE(*,*)'scatprimfunction:',SCATPRIMFUNC
END
C DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,S)
C IMPLICIT NONE
CC--Parameter common block
C COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
C &LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
C INTEGER NF
C DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
C &LTIME,LPS
C LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
CC--local variables
C DOUBLE PRECISION T,PI,S,EI
C DATA PI/3.141592653589793d0/
C
C SCATPRIMFUNC=16.*PI**3*(-2.*EI(-LOG(T/LQCD**2))*S**2/LQCD**2
C & - 2.*S**2/(T*LOG(T/LQCD**2)) + 2.*S/LOG(T/LQCD**2)
C & + LQCD**2*EI(LOG(T/LQCD**2)) - T/LOG(T/LQCD**2))
C & /(S**2*(11.-2.*NF/3.)**2)
C END
DOUBLE PRECISION FUNCTION INTPQQ(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q
INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF)
END
DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q
INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF)
END
DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
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
DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION Z,Q,EI
C INTPQGHIGH=6.*(-2.*LPS**6*(Q**4*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))
C & /LPS**4
C & - 2.*Q**2*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/LPS**2
C & + EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/LPS**2)/Q**6
C & - 2.*LPS**4*(EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))
C & - Q**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/LPS**2)/Q**4
C & - LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2)/((33.-2.*NF)*2.)
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
***********************************************************************
*** generates a t value for projectile mass 'mp', mass 'ms' of the
*** scattering centre and projectile energy 'ep' from the
*** differential scattering cross section
***********************************************************************
DOUBLE PRECISION FUNCTION GETT(S,TMIN,MAXT,MDEB)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION S,TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT,
&MDEB
DATA PI/3.141592653589793d0/
C TMAX=MIN(MAXT,4.*MDEB**2)
TMAX=MAXT
IF(TMIN.GT.TMAX) THEN
GETT=0.d0
RETURN
ENDIF
MAXI=ALPHAS(MDEB**2,LQCD)**2*2.*S**2/(MDEB**4)
20 R1=PYR(0)*(TMAX-TMIN)+TMIN
Y=ALPHAS(R1+MDEB**2,LQCD)**2*(S**2+(S-R1)**2)/(R1+MDEB**2)**2
IF(Y.GT.MAXI) WRITE(*,*) 'maximum violated in gett',Y
R2=PYR(0)*MAXI
IF(R2.LT.Y)THEN
GETT=R1
ELSE
GOTO 20
ENDIF
END
***********************************************************************
*** function ei
***********************************************************************
*** evaluates the exponential integral
***********************************************************************
DOUBLE PRECISION FUNCTION EI(X)
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C--local variables
INTEGER K,LINE,LMAX
DOUBLE PRECISION X,R,GA,XA(4),YA(4),Y,DY
IF(X.GE.0.d0)THEN
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
25 EI=EI+R
EI=DEXP(X)/X*EI
ENDIF
ELSE
LMAX=INT(-X*NVAL/VALMAX)
LINE=MAX(LMAX-1,1)
LINE=MIN(LINE,97)
DO 26 K=1,4
XA(K)=EIX(1,LINE-1+K)
YA(K)=EIX(2,LINE-1+K)
26 CONTINUE
CALL POLINT(XA,YA,4,-X,Y,DY)
EI=Y
ENDIF
END
DOUBLE PRECISION FUNCTION PQQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQQ=4.*(1.+Z**2)/(3.*(1.-Z))
END
DOUBLE PRECISION FUNCTION PGQ(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGQ=4.*(1.+(1.-Z)**2)/(3.*Z)
END
DOUBLE PRECISION FUNCTION PGG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z))
END
DOUBLE PRECISION FUNCTION PQG(Z)
IMPLICIT NONE
DOUBLE PRECISION Z
PQG=0.5*(Z**2 + (1.-Z)**2)
END
***********************************************************************
*** function alphas
***********************************************************************
*** evaluates the coupling alpha_s at scale 't'
***********************************************************************
DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--local variables
DOUBLE PRECISION T,L0,PI,LAMBDA
DATA PI/3.141592653589793d0/
IF(BRICK)THEN
ALPHAS=0.3
ELSE
ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2))
ENDIF
END
***********************************************************************
*** subroutine splitfncint
***********************************************************************
*** integrates the splitting functions in vacuum and in medium
***********************************************************************
SUBROUTINE SPLITFNCINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--splitting integral
COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
&SPLITIQGV(1000,1000),
&SPLITIGGM(1000,1000),SPLITIQQM(1000,1000),
&SPLITIQGM(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
INTEGER NPOINT
DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
&SPLITIGGM,SPLITIQQM,SPLITIQGM,QVAL,ZMVAL,QMAX,ZMMIN
C--variables for splitting function integration
COMMON/INTSPLITF/QQUAD,FM
DOUBLE PRECISION QQUAD,FM
C--local variables
INTEGER NSTEP,I,J,NOK,NBAD
DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN,
&LNZMMAX,ZM,ZM2,Q
DATA ZMMAX/0.5/
DATA NSTEP/99/
DATA EPSI/1.d-5/
QMAX=EMAX
ZMMIN=QMIN/EMAX
LNZMMIN=LOG(ZMMIN)
LNZMMAX=LOG(ZMMAX)
NPOINT=NSTEP
DO 100 I=0,NSTEP
Q=I*(QMAX-QMIN)/NSTEP+QMIN
QVAL(I+1)=Q
QQUAD=Q**2
DO 110 J=0,NSTEP
ZM=EXP(J*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN)
ZMVAL(J+1)=ZM
IF(Q.LE.QMIN)THEN
SPLITIQQV(I+1,J+1)=0.d0
SPLITIQQM(I+1,J+1)=0.d0
SPLITIGGV(I+1,J+1)=0.d0
SPLITIGGM(I+1,J+1)=0.d0
SPLITIQGV(I+1,J+1)=0.d0
SPLITIQGM(I+1,J+1)=0.d0
ELSE
C ZM2=0.5-0.5*SQRT((1.-QMIN**2/Q**2)*(1.-Q**2/EMAX**2))
ZM2=0.5-0.5*SQRT(1.-4.*(KTMIN*LPS)**2/Q**2)
ZM=MAX(ZM,ZM2)
IF(ZM.EQ.0.5)THEN
SPLITIQQV(I+1,J+1)=0.d0
SPLITIQQM(I+1,J+1)=0.d0
SPLITIGGV(I+1,J+1)=0.d0
SPLITIGGM(I+1,J+1)=0.d0
SPLITIQGV(I+1,J+1)=0.d0
SPLITIQGM(I+1,J+1)=0.d0
ELSE
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
C WRITE(*,*)'q=',Q
C WRITE(*,*)'qmin=',QMIN
C WRITE(*,*)'zm=',ZM
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,2)
SPLITIQQV(I+1,J+1)=YSTART
C WRITE(*,*)'splitiqqv=',YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,2)
SPLITIQQM(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,3)
SPLITIGGV(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,3)
SPLITIGGM(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=0.d0
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,4)
SPLITIQGV(I+1,J+1)=YSTART
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
FM=FMED
CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,NOK,NBAD,4)
SPLITIQGM(I+1,J+1)=YSTART
ENDIF
ENDIF
110 CONTINUE
100 CONTINUE
END
SUBROUTINE PDFINT(QMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--pdf common block
COMMON/PDFS/QINQ(101,101),GINQ(101,101),QING(101,101),
&GING(101,101),QINQX(101,101),GINQX(101,101),QINGX(101,101),
&GINGX(101,101)
DOUBLE PRECISION QINQ,GINQ,QING,GING,QINQX,GINQX,QINGX,GINGX
C--variables for pdf integration
COMMON/PDFINTV/XMAX,Z
DOUBLE PRECISION XMAX,Z
C--local variables
INTEGER I,J,NOK,NBAD
DOUBLE PRECISION DELTAQ,QMAX,Q1,Q2,GETPDFXINTEXACT,
&GETPDFXINT,YSTART,HFIRST,EPSI,X,Q2LEFT,Q2MAX,DELTAQ2,
&Q2RIGHT,Q2LOW,GETMS
DATA EPSI/1.d-4/
C--jkl must use max MS
Q2MAX=2.*QMAX*GETMS(0.d0,0.d0,0.d0,0.d0)
Q2MAX=2.*QMAX*MS
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
C WRITE(*,*)'PDFINT for',Q2MAX
DO 13 I=1,100
X = (I-1)*1.d0/99.d0
QINQ(I,101)=X
GINQ(I,101)=X
QING(I,101)=X
GING(I,101)=X
DO 14 J=1,100
Q2LEFT = EXP((J-1)*DELTAQ2/100.d0 + LOG(Q0**2))
Q2RIGHT = EXP(J*DELTAQ2/100.d0 + LOG(Q0**2))
C WRITE(*,*)I,J,X,Q2LEFT,Q2RIGHT
IF(I.EQ.1)THEN
QINQ(101,J)=Q2LEFT
GINQ(101,J)=Q2LEFT
QING(101,J)=Q2LEFT
GING(101,J)=Q2LEFT
ENDIF
Z=X
XMAX=SQRT(Q2RIGHT)
C--f_q^q
Q2LOW=MAX(Q2LEFT,Q0**2/(4.*(1.-X)))
IF((Q2LOW.GE.Q2RIGHT*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,7)
ENDIF
QINQ(I,J)=YSTART
C--f_g^q
Q2LOW=MAX(Q2LEFT,MAX(Q0**2/(4.*(1.-X)),Q0**2/(4.*(X))))
IF((Q2LOW.GE.Q2RIGHT*(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*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,8)
ENDIF
GINQ(I,J)=YSTART
C--f_q^g
Q2LOW=MAX(Q2LEFT,Q0**2/(4.*(1.-X)))
IF((Q2LOW.GE.Q2RIGHT*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN
YSTART=0.d0
ELSE
HFIRST=0.01*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,9)
ENDIF
QING(I,J)=YSTART
C--f_g^g
Q2LOW=MAX(Q2LEFT,MAX(Q0**2/(4.*(1.-X)),Q0**2/(4.*(X))))
IF((Q2LOW.GE.Q2RIGHT*(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*(SQRT(Q2RIGHT)-SQRT(Q2LOW))
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,SQRT(Q2LOW),SQRT(Q2RIGHT),EPSI,HFIRST,
& 0.d0,NOK,NBAD,10)
ENDIF
GING(I,J)=YSTART
14 CONTINUE
13 CONTINUE
DELTAQ=LOG(QMAX**2)-LOG(Q0**2)
DO 11 I=1,100
Q1 = EXP((I-1)*DELTAQ/99.d0 + LOG(Q0**2))
QINQX(I,101)=Q1
GINQX(I,101)=Q1
QINGX(I,101)=Q1
GINGX(I,101)=Q1
DO 12 J=1,100
Q2 = EXP((J-1)*DELTAQ/99.d0 + LOG(Q0**2))
IF(I.EQ.1)THEN
QINQX(101,J)=Q2
GINQX(101,J)=Q2
QINGX(101,J)=Q2
GINGX(101,J)=Q2
ENDIF
IF(Q2.LE.Q1)THEN
QINQX(I,J)=0.d0
GINQX(I,J)=0.d0
QINGX(I,J)=0.d0
GINGX(I,J)=0.d0
ELSE
QINQX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'QQ')
GINQX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'GQ')
QINGX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'QG')
GINGX(I,J)=GETPDFXINTEXACT(SQRT(Q1),SQRT(Q2),'GG')
ENDIF
12 CONTINUE
11 CONTINUE
END
SUBROUTINE XSECINT(EMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--cross secttion common block
COMMON/XSECS/INTQ1(101,101),INTQ2(101,101),INTG1(101,101),
&INTG2(101,101)
DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
C--variables for cross section integration
COMMON/XSECV/QLOW
DOUBLE PRECISION QLOW
C--local variables
INTEGER I,J,NOK,NBAD
DOUBLE PRECISION EMAX,TMAX,Q2,TMAXMAX,Q2MAX,DELTAQ2,DELTATMAX,
&YSTART,HFIRST,EPSI,GETMS
DATA EPSI/1.d-4/
C--jkl ??? must use maximum MS
- TMAXMAX=2.*EMAX*GETMS(0.d0,0.d0,0.d0,0.d0)
+C TMAXMAX=2.*EMAX*GETMS(0.d0,0.d0,0.d0,0.d0)
TMAXMAX=2.*EMAX*MS
Q2MAX=EMAX**2
DELTAQ2=LOG(Q2MAX)-LOG(Q0**2)
DELTATMAX=LOG(TMAXMAX)-LOG(Q0**2*(1.d0+1.d-6))
DO 11 I=1,100
Q2 = EXP((I-1)*DELTAQ2/99.d0 + LOG(Q0**2))
INTQ1(I,101)=Q2
INTQ2(I,101)=Q2
INTG1(I,101)=Q2
INTG2(I,101)=Q2
DO 12 J=1,100
TMAX = EXP((J-1)*DELTATMAX/99.d0 + LOG(Q0**2*(1.d0+1.d-6)))
IF(I.EQ.1)THEN
INTQ1(101,J)=TMAX
INTQ2(101,J)=TMAX
INTG1(101,J)=TMAX
INTG2(101,J)=TMAX
ENDIF
C WRITE(*,*)'Q^2,tmax:',Q2,TMAX
IF(TMAX.LT.Q2)THEN
INTQ1(I,J)=0.d0
INTQ2(I,J)=0.d0
INTG1(I,J)=0.d0
INTG2(I,J)=0.d0
ELSE
C--first quark integral
QLOW=SQRT(Q2)
HFIRST=0.01*(TMAX-Q2)
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,11)
INTQ1(I,J)=YSTART
C--second quark integral
QLOW=SQRT(Q2)
HFIRST=0.01*(TMAX-Q2)
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,14)
INTQ2(I,J)=YSTART
C--first gluon integral
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,12)
INTG1(I,J)=YSTART
C--second gluon integral
YSTART=0.d0
NOK=0
NBAD=0
CALL ODEINT(YSTART,Q2,TMAX,EPSI,HFIRST,0.d0,NOK,NBAD,13)
INTG2(I,J)=YSTART
ENDIF
12 CONTINUE
11 CONTINUE
END
SUBROUTINE INSUDAINT(QMAX)
IMPLICIT NONE
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C--Sudakov common block
COMMON/INSUDA/SUDAQQ(101,2),SUDAQG(101,2),SUDAGG(101,2),
&SUDAGC(101,2)
DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
C--local variables
INTEGER I
DOUBLE PRECISION QMAX,Q,GETINSUDAKOV
DO 22 I=1,101
Q=(I-1)*(1.5*QMAX-Q0)/100.+Q0
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
***********************************************************************
*** subroutine expint
***********************************************************************
*** integrates the exponential integral for negative arguments
***********************************************************************
SUBROUTINE EIXINT
IMPLICIT NONE
C--exponential integral for negative arguments
COMMON/EXPINT/EIX(2,1000),VALMAX,NVAL
INTEGER NVAL
DOUBLE PRECISION EIX,VALMAX
C-local variables
INTEGER I,NOK,NBAD
DOUBLE PRECISION X,EPSI,HFIRST,YSTART
DATA EPSI/1.d-5/
NVAL=100
VALMAX=25.
DO 10 I=1,100
X=I*25./100.
EIX(1,I)=X
YSTART=0d0
NOK=0
NBAD=0
HFIRST=0.01
CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,NOK,NBAD,5)
EIX(2,I)=-YSTART
10 CONTINUE
END
***********************************************************************
*** subroutine polint2
***********************************************************************
*** 2d plynom interpolation
***********************************************************************
SUBROUTINE POLINT2(X1A,X2A,YA,M,N,X1,X2,Y,DY)
IMPLICIT NONE
INTEGER M,N,NMAX,MMAX,J,K
DOUBLE PRECISION X1A,X2A,YA,X1,X2,Y,DY,YNTMP,YMTMP
PARAMETER (NMAX=20,MMAX=20)
DIMENSION X1A(M),X2A(N),YA(M,N),YNTMP(NMAX),YMTMP(MMAX)
DO 12 J=1,M
DO 11 K=1,N
YNTMP(K)=YA(J,K)
11 CONTINUE
CALL POLINT(X2A,YNTMP,N,X2,YMTMP(J),DY)
12 CONTINUE
CALL POLINT(X1A,YMTMP,M,X1,Y,DY)
RETURN
END
***********************************************************************
*** subroutine polint
***********************************************************************
*** 1d plynom interpolation
***********************************************************************
SUBROUTINE POLINT(XA,YA,N,X,Y,DY)
IMPLICIT NONE
INTEGER N,NMAX,NS,I,M
DOUBLE PRECISION XA,YA,X,Y,DY,C,D,DIF,DIFT,HO,HP,W,DEN
PARAMETER (NMAX=10)
DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
NS=1
DIF=ABS(X-XA(1))
DO 11 I=1,N
DIFT=ABS(X-XA(I))
IF(DIFT.LT.DIF)THEN
NS=I
DIF=DIFT
ENDIF
C(I)=YA(I)
D(I)=YA(I)
11 CONTINUE
Y=YA(NS)
NS=NS-1
DO 13 M=1,N-1
DO 12 I=1,N-M
HO=XA(I)-X
HP=XA(I+M)-X
W=C(I+1)-D(I)
DEN=HO-HP
C IF(DEN.EQ.0d0)PAUSE
IF(DEN.EQ.0d0)THEN
WRITE(*,*)'error in polint: den==0'
RETURN
ENDIF
DEN=W/DEN
D(I)=HP*DEN
C(I)=HO*DEN
12 CONTINUE
IF(2*NS.LT.N-M)THEN
DY=C(NS+1)
ELSE
DY=D(NS)
NS=NS-1
ENDIF
Y=Y+DY
13 CONTINUE
14 RETURN
END
***********************************************************************
*** subroutine odeint
***********************************************************************
*** numerical solution of ODE using quality controlled
*** Runge-Kutta with adaptive step size
***********************************************************************
SUBROUTINE ODEINT(YSTART,X1,X2,EPS,H1,HMIN,NOK,NBAD,W1)
IMPLICIT NONE
INTEGER NOK,NBAD,NSTP,MAXSTP,W1
DOUBLE PRECISION YSTART,X1,X2,EPS,H1,HMIN,X,H,Y,YSCAL,T4,
&HDID,HNEXT,TWO,ZERO,TINY,DYDX,DERIV,QA2,ZA2,EB2
PARAMETER (MAXSTP=100000,TWO=2.,ZERO=0.,TINY=1.E-30)
CHARACTER*2 TYPE4
X=X1
H=SIGN(H1,X2-X1)
Y=YSTART
DO 20 NSTP=1,MAXSTP
DYDX=DERIV(X,W1)
YSCAL=ABS(Y)+ABS(H*DYDX)+TINY
IF((X+H-X2)*(X+H-X1).GT.ZERO) H=X2-X
CALL RKQC(Y,DYDX,X,H,EPS,YSCAL,HDID,HNEXT,W1)
IF(HDID.EQ.H)THEN
NOK=NOK+1
ELSE
NBAD=NBAD+1
ENDIF
IF((X-X2)*(X2-X1).GE.ZERO)THEN
YSTART=Y
RETURN
ENDIF
C IF(ABS(HNEXT).LT.HMIN) PAUSE 'Stepsize smaller than minimum'
IF(ABS(HNEXT).LT.HMIN) THEN
WRITE(*,*) 'Stepsize smaller than minimum'
RETURN
ENDIF
H=HNEXT
20 CONTINUE
C PAUSE 'Too many steps'
WRITE(*,*) 'Too many steps'
RETURN
END
***********************************************************************
*** subroutine rkqc
***********************************************************************
*** quality controlled Runge-Kutta routine
***********************************************************************
SUBROUTINE RKQC(Y,DYDX,X,HTRY,EPS,YSCAL,HDID,HNEXT,W2)
IMPLICIT NONE
INTEGER W2
DOUBLE PRECISION Y,DYDX,X,HTRY,EPS,YSCAL,HDID,HNEXT,T5,
&XSAV,YSAV,DYSAV,H,HH,ERRMAX,YTEMP,PGROW,PSHRINK,FCOR,ONE,
&SAFETY,ERRCON,RK4,DERIV,QA3,ZA3,EB3
CHARACTER*2 TYPE5
PARAMETER (PGROW=-0.2,PSHRINK=-0.25,FCOR=1d0/15d0,ONE=1.,
& SAFETY=0.9,ERRCON=6.E-4)
XSAV=X
YSAV=Y
DYSAV=DYDX
H=HTRY
10 HH=0.5*H
YTEMP=RK4(YSAV,DYSAV,XSAV,HH,W2)
X=XSAV+HH
DYDX=DERIV(X,W2)
Y=RK4(YTEMP,DYDX,X,HH,W2)
X=XSAV+H
IF(X.EQ.XSAV)THEN
WRITE(*,*)'RKQC: type=',W2
C PAUSE 'Stepsize not significant in RKQC'
WRITE(*,*) 'Stepsize not significant in RKQC'
RETURN
ENDIF
YTEMP=RK4(YSAV,DYSAV,XSAV,H,W2)
ERRMAX=0.
YTEMP=Y-YTEMP
ERRMAX=MAX(ERRMAX,ABS(YTEMP/YSCAL))
ERRMAX=ERRMAX/EPS
IF(ERRMAX.GT.ONE)THEN
H=SAFETY*H*(ERRMAX**PSHRINK)
GOTO 10
ELSE
HDID=H
IF(ERRMAX.GT.ERRCON)THEN
HNEXT=SAFETY*H*(ERRMAX**PGROW)
ELSE
HNEXT=4.*H
ENDIF
ENDIF
Y=Y+YTEMP*FCOR
RETURN
END
***********************************************************************
*** subroutine rk4
***********************************************************************
*** 4th order Runge-Kutta step
***********************************************************************
DOUBLE PRECISION FUNCTION RK4(Y,DYDX,X,H,W3)
IMPLICIT NONE
INTEGER W3
DOUBLE PRECISION Y,DYDX,X,H,HH,H6,XH,YT,DYT,DYM,YOUT,
&DERIV,QA4,ZA4,EB4,T6
CHARACTER*2 TYPE6
HH=H*0.5
H6=H/6
XH=X+HH
YT=Y+HH*DYDX
DYT=DERIV(XH,W3)
YT=Y+HH*DYT
DYM=DERIV(XH,W3)
YT=Y+H*DYM
DYM=DYT+DYM
DYT=DERIV(X+H,W3)
YOUT=Y+H6*(DYDX+DYT+2.*DYM)
RK4=YOUT
END
C> returns if there is a scattering for parton in line 'LINE'
C> within 'DTMAX'
C> if yes 'DELTAT' is set to the time of the scattering
C>
C> \param LINE line of parton in the event record
C> \param DTMAX upper limit when scattering can happen
C> \param DELTAT time of scattering (if none, undefined)
LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX,MUST,GETPNOSCAT,
&DELTAT,PNOSCAT)
IMPLICIT NONE
C line of parton to scatter
INTEGER LINE
C start and max. time for scattering
DOUBLE PRECISION TSTART,DTMAX
C must scatter in given time interval?
C calculate no-scattering probability
LOGICAL MUST,GETPNOSCAT
C scattering time (if any)
DOUBLE PRECISION DELTAT
C no scattering probability
DOUBLE PRECISION PNOSCAT
C pythia common block
INTEGER NMAX
PARAMETER (NMAX=5000)
COMMON/PYJETS/N,NPAD,K(NMAX,5),P(NMAX,5),V(NMAX,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--Parameter common block
COMMON/PARAM/Q0,QMIN,LPS,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK,NF
INTEGER NF
DOUBLE PRECISION Q0,QMIN,LQCD,KTMIN,MINEN,FMED,MD,MS,TEMP,NP,
&LTIME,LPS
LOGICAL ANGORD,CONSTR,KEEPRECOIL,SCATRECOIL,BRICK
C time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
INTEGER I,NSTEP,TYPE
PARAMETER (NSTEP=5)
DOUBLE PRECISION FF(NSTEP+1)
DOUBLE PRECISION R,PYR,F,DF,DT,EN,M,BETA,PYP,DELTA,
&GETSSCAT,GETNEFF,LAMBDA,GETMD,GETMS,GETTEMP
C potential scattering position
DOUBLE PRECISION XSC,YSC,ZSC,TSC,TOFF
CHARACTER TYPE2
C--initialization
GETDELTAT=.FALSE.
DELTAT=0.D0
C--check for uppper bound from plasma lifetime
IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART
IF(DTMAX.LT.0.D0)THEN
DTMAX=0.d0
IF(MUST)THEN
WRITE(*,*)'error: must scatter after end of plasma life time!'
GETDELTAT=.TRUE.
PNOSCAT=0.D0
DELTAT=0.D0
ENDIF
RETURN
ENDIF
TOFF=TSTART-MV(LINE,4)
DT=DTMAX/NSTEP
R=-LOG(PYR(0))
EN=P(LINE,4)
M=P(LINE,5)
BETA=PYP(LINE,8)/P(LINE,4)
TYPE=K(LINE,2)
IF(TYPE.EQ.21)THEN
TYPE2='G'
ELSE
TYPE2='Q'
ENDIF
F=0.d0
FF(1)=0.D0
DO 100 I=1,NSTEP
C potential position of scattering
XSC=MV(LINE,1)+(TOFF+DT*(I-1))*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(TOFF+DT*(I-1))*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(TOFF+DT*(I-1))*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+(TOFF+DT*(I-1))
IF(GETNEFF(XSC,YSC,ZSC,TSC).LE.1d-2)THEN
FF(I+1)=FF(I)
IF(.NOT.MUST.AND..NOT.GETPNOSCAT)GOTO 104
ELSE
- DF=GETSSCAT(EN,M,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
+ DF=GETSSCAT(EN,M,0.d0,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
&GETMD(XSC,YSC,ZSC,TSC))*
&GETNEFF(XSC,YSC,ZSC,TSC)*
&DT*5.d0*BETA
F=F+DF
FF(I+1)=FF(I)+DF
IF(.NOT.GETDELTAT.AND.F.GT.R)THEN
GETDELTAT=.TRUE.
DELTAT=(I-1)*DT
IF(.NOT.MUST.AND..NOT.GETPNOSCAT)GOTO 104
ENDIF
ENDIF
100 CONTINUE
PNOSCAT=EXP(-F)
C-- if there must be a scattering, find one
IF(MUST)THEN
GETDELTAT=.TRUE.
R=PYR(0)
DO 101 I=1,NSTEP
IF(R.LT.((EXP(-FF(I+1))-1.D0)/(EXP(-FF(NSTEP+1))-1.D0)))THEN
DELTAT=(I-1)*DT
C now refine DELTAT within the bin assuming constant medium properties
IF(GETNEFF(XSC,YSC,ZSC,TSC).GT.1d-2)THEN
110 LAMBDA=1.d0/(GETNEFF(XSC,YSC,ZSC,TSC)*
- &GETSSCAT(EN,M,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
+ &GETSSCAT(EN,M,0.d0,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
&GETMD(XSC,YSC,ZSC,TSC))*5.d0*BETA)
R=PYR(0)
DELTA=DELTAT-LAMBDA*LOG(1+R*(EXP(-DT/LAMBDA)-1))
C WRITE(*,*)DELTAT
IF(GETNEFF(MV(LINE,1)+(TOFF+DELTA)*P(LINE,1)/P(LINE,4),
&MV(LINE,2)+(TOFF+DELTA)*P(LINE,2)/P(LINE,4),
&MV(LINE,3)+(TOFF+DELTA)*P(LINE,3)/P(LINE,4),
&MV(LINE,4)+(TOFF+DELTA)).LT.1.d-2)GOTO 110
DELTAT=DELTA
ENDIF
C WRITE(*,*)TSTART,DTMAX,MV(LINE,4)+TOFF+DELTAT
RETURN
ENDIF
101 CONTINUE
RETURN
ENDIF
104 IF(GETDELTAT)THEN
C potential position of scattering
XSC=MV(LINE,1)+(TOFF+DELTAT)*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(TOFF+DELTAT)*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(TOFF+DELTAT)*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+(TOFF+DELTAT)
C now refine DELTAT within the bin assuming constant medium properties
LAMBDA=1.d0/(GETNEFF(XSC,YSC,ZSC,TSC)*
- &GETSSCAT(EN,M,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
+ &GETSSCAT(EN,M,0.d0,TYPE2,'C',GETMS(XSC,YSC,ZSC,TSC),
&GETMD(XSC,YSC,ZSC,TSC))*5.d0*BETA)
R=PYR(0)
DELTAT=DELTAT-LAMBDA*LOG(1+R*(EXP(-DT/LAMBDA)-1))
C potential position of scattering
XSC=MV(LINE,1)+(TOFF+DELTAT)*P(LINE,1)/P(LINE,4)
YSC=MV(LINE,2)+(TOFF+DELTAT)*P(LINE,2)/P(LINE,4)
ZSC=MV(LINE,3)+(TOFF+DELTAT)*P(LINE,3)/P(LINE,4)
TSC=MV(LINE,4)+(TOFF+DELTAT)
C sanity check, still in medium
IF(GETNEFF(XSC,YSC,ZSC,TSC).LE.1d-2) GETDELTAT=.FALSE.
ENDIF
END
SUBROUTINE PEVREC
COMMON/PYJETS/N,NPAD,K(5000,5),P(5000,5),V(5000,5)
INTEGER N,NPAD,K
DOUBLE PRECISION P,V
C--time common block
COMMON/TIME/MV(8000,5)
DOUBLE PRECISION MV
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)
202 CONTINUE
CALL PYLIST(3)
END

File Metadata

Mime Type
text/x-diff
Expires
Wed, May 14, 11:29 AM (11 h, 4 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
5111439
Default Alt Text
(347 KB)

Event Timeline