+++ /dev/null
-C***********************************************************************
-C
-C
-C
-C PHOJET version 1.12
-C -------------------
-C
-C
-C ($Revision$, $Date$)
-C
-C
-C Authors: Ralph Engel
-C (eng@lepton.bartol.udel.edu)
-C
-C Johannes Ranft
-C (johannes.ranft@cern.ch)
-C
-C Stefan Roesler
-C (sroesler@SLAC.Stanford.EDU)
-C
-C
-C For the latest version and documentation check
-C http://lepton.bartol.udel.edu/~eng/phojet.html
-C
-C
-C Bug reports, questions, complaints are welcome
-C (please send a mail to eng@lepton.bartol.udel).
-C
-C
-C Note that the code is available with several interfaces to
-C Lund fragmentation programs (JETSET7.x, 1.x and a double
-C precision JETSET version). This file is the code with
-C
-
-C interface to PYTHIA 6.1 (or higher)
-
-C for usage in DPMJET 3.x (Lund common block dimensions increased)
-
-C
-C***********************************************************************
-C
-C
-C List of subroutines and functions
-C ---------------------------------
-C
-C
-C main event simulation routines
-C
-C PHO_EVENT
-C PHO_PARTON
-C PHO_POSPOM
-C
-C PHO_STDPAR
-C PHO_POMSCA
-C
-C
-C user steering interface
-C
-C PHO_SETMDL
-C PHO_PRESEL
-C
-C
-C experimental setup / photon flux calculation
-C
-C PHO_FIXLAB
-C PHO_FIXCOL
-C PHO_GPHERA
-C PHO_GGEPEM
-C PHO_WGEPEM
-C PHO_GGBLSR
-C PHO_GGBEAM
-C PHO_GGHIOF
-C PHO_GGHIOG
-C PHO_GGFLCL
-C PHO_GGFLCR
-C PHO_GGFAUX
-C PHO_GGFNUC
-C PHO_GHHIOF
-C PHO_GHHIAS
-C
-C
-C initialization
-C
-C PHO_INIT
-C PHO_DATINI
-C PHO_PARDAT
-C PHO_MCINI
-C
-C PHO_EVEINI
-C
-C PHO_HARINI
-C PHO_FRAINI
-C
-C PHO_FITPAR
-C
-C
-C cross section calculation
-C
-C PHO_CSINT
-C
-C PHO_XSECT
-C PHO_BORNCS
-C PHO_HARXTO
-C
-C PHO_DSIGDT
-C
-C PHO_TRIREG
-C PHO_LOOREG
-C PHO_TRXPOM
-C
-C PHO_EIKON
-C PHO_CHAN2A
-C
-C PHO_SCALES
-C
-C
-C multiple interaction structure
-C
-C PHO_IMPAMP
-C PHO_PRBDIS
-C PHO_SAMPRO
-C PHO_SAMPRB
-C
-C
-C hadron / photon remnant treatment, soft x selection
-C
-C PHO_HARREM
-C PHO_PARREM
-C
-C PHO_HADSP2
-C PHO_HADSP3
-C PHO_SOFTXX
-C PHO_SELSXR
-C PHO_SELSX2
-C PHO_SELSXS
-C PHO_SELSXI
-C
-C PHO_VALFLA
-C PHO_REGFLA
-C PHO_SEAFLA
-C PHO_FLAUX
-C PHO_BETAF
-C IPHO_DIQU
-C
-C
-C primordial kt and soft parton pt
-C
-C PHO_PRIMKT
-C PHO_PARTPT
-C PHO_SOFTPT
-C PHO_SELPT
-C
-C PHO_CONN0
-C PHO_CONN1
-C
-C
-C simulation of hard scattering, initial state radiation
-C
-C PHO_HARCOL
-C PHO_SELCOL
-C PHO_HARCOR
-C
-C PHO_HARDIR
-C PHO_HARX12
-C PHO_HARDX1
-C PHO_HARKIN
-C PHO_HARWGH
-C PHO_HARSCA
-C PHO_HARFAC
-C PHO_HARWGX
-C PHO_HARWGI
-C PHO_HARINT
-C PHO_HARMCI
-C
-C PHO_HARXR3
-C PHO_HARXR2
-C PHO_HARXD2
-C PHO_HARXPT
-C PHO_HARISR
-C PHO_HARZSP
-C
-C PHO_PTCUT
-C PHO_ALPHAE
-C PHO_ALPHAS
-C
-C
-C diffraction dissociation
-C
-C PHO_DIFDIS
-C PHO_DIFPRO
-C PHO_DIFPAR
-C PHO_QELAST
-C PHO_CDIFF
-C PHO_DFWRAP
-C
-C PHO_SAMASS
-C PHO_DSIGDM
-C PHO_DFMASS
-C
-C PHO_SDECAY
-C PHO_SDECY2
-C PHO_SDECY3
-C
-C PHO_DIFSLP
-C PHO_DIFKIN
-C PHO_VECRES
-C PHO_DIFRES
-C
-C PHO_REGPAR
-C
-C PHO_PECMS
-C PHO_SETPAR
-C
-C
-C fragmentation, treatment of low-mass strings
-C
-C PHO_STRING
-C PHO_STRFRA
-C
-C PHO_ID2STR
-C PHO_MCHECK
-C PHO_POMCOR
-C PHO_MASCOR
-C PHO_PARCOR
-C
-C PHO_GLU2QU
-C PHO_GLUSPL
-C
-C PHO_DQMASS
-C PHO_BAMASS
-C PHO_MEMASS
-C
-C
-C particle code tables, particle numbering conversion
-C
-C PHO_PNAME
-C PHO_PMASS
-C IPHO_CHR3
-C IPHO_BAR3
-C
-C IPHO_ANTI
-C
-C IPHO_PDG2ID
-C IPHO_ID2PDG
-C IPHO_LU2PDG
-C IPHO_PDG2LU
-C
-C IPHO_CNV1
-C PHO_HACODE
-C
-C
-C
-C Lorentz transformations, rotations and mass adjustment
-C
-C PHO_ALTRA
-C PHO_LTRANS
-C PHO_TRANS
-C PHO_TRANI
-C
-C PHO_MKSLTR
-C PHO_GETLTR
-C
-C PHO_LTRHEP
-C
-C PHO_MSHELL
-C PHO_MASSAD
-C
-C
-C program debugging and internal cross-checks
-C
-C PHO_PREVNT
-C PHO_PRSTRG
-C PHO_CHECK
-C
-C PHO_TRACE
-C
-C PHO_REJSTA
-C
-C PHO_ABORT
-C
-C
-C cross section fitting
-C
-C PHO_FITMAI
-C PHO_FITINP
-C PHO_FITDAT
-C PHO_FITOUT
-C PHO_FITAMP
-C PHO_FITTST
-C PHO_FITMSQ
-C PHO_FITVD1
-C PHO_FITCN1
-C PHO_FITINI
-C
-C
-C cross section parametrizations
-C
-C PHO_HADCSL
-C PHO_ALLM97
-C PHO_CSDIFF
-C
-
-C
-C random numbers
-C
-
-C DPMJET random number generator DT_RNDM used
-
-C
-C PHO_SFECFE
-C PHO_RNDBET
-C PHO_RNDGAM
-C
-C
-C auxiliary routines / numerical methods
-C
-C PHO_GAUSET
-C PHO_GAUDAT
-C
-C pho_samp1d
-C
-C PHO_DZEROX
-C PHO_EXPINT
-C PHO_BESSJ0
-C PHO_BESSI0
-C pho_ExpBessI0
-C PHO_BESSI1
-C PHO_BESSK0
-C PHO_BESSK1
-C
-C PHO_XLAM
-C
-C PHO_SWAPD
-C PHO_SWAPI
-C
-C
-C parton density parametrization management / interface
-C
-C PHO_PDF
-C
-C PHO_SETPDF
-C PHO_GETPDF
-C PHO_ACTPDF
-C
-C PHO_QPMPDF
-C
-C PHO_PDFTST
-C
-C
-C parton density parametrizations from other authors
-C
-C PHO_DOR98LO
-C PHO_DOR98SC
-C PHO_DOR94LO
-C PHO_DOR94HO
-C PHO_DOR94DI
-C PHO_DOR92LO
-C PHO_DOR92HO
-C PHO_DORPLO
-C PHO_DORPHO
-C PHO_DORGLO
-C PHO_DORGHO
-C PHO_DORGH0
-C PHO_DOR94FV
-C PHO_DOR94FW
-C PHO_DOR94FS
-C PHO_DOR92FV
-C PHO_DOR92FW
-C PHO_DOR92FS
-C PHO_DORFVP
-C PHO_DORFGP
-C PHO_DORFQP
-C PHO_DORGF
-C PHO_DORGFS
-C PHO_grsf1
-C PHO_grsf2
-C
-C PHO_CKMTPA
-C PHO_CKMTPD
-C PHO_CKMTPO
-C PHO_CKMTFV
-C
-C PHO_DBFINT
-C
-C PHO_SASGAM
-C PHO_SASVMD
-C PHO_SASANO
-C PHO_SASBEH
-C PHO_SASDIR
-C
-C PHO_PHGAL
-C PHVAL
-C
-C
-C***********************************************************************
-
-CDECK ID>, PHO_INIT
-**sr temporarily changed
-C SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
- SUBROUTINE PHO_INIT(LINP,IREJ)
-**
-C***********************************************************************
-C
-C main subroutine to configure and manage PHOJET calculations
-C
-C input: LINP input unit to read from
-C -1 to skip reading of input file
-C LOUT output unit to write to
-C
-C output: IREJ 0 success
-C 1 failure
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C cut probability distribution
- INTEGER IEETA1,IIMAX,KKMAX
- PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
- INTEGER IEEMAX,IMAX,KMAX
- REAL PROB
- DOUBLE PRECISION EPTAB
- COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
- & IEEMAX,IMAX,KMAX
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
- INTEGER MSTU,MSTJ
- DOUBLE PRECISION PARU,PARJ
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-
- INTEGER KCHG
- DOUBLE PRECISION PMAS,PARF,VCKM
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
-
- INTEGER MDCY,MDME,KFDP
- DOUBLE PRECISION BRAT
- COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
-
- INTEGER PYCOMP
-
- DIMENSION ITMP(0:11)
- CHARACTER*10 CNAME
- CHARACTER*70 NUMBER,FILENA
-
- 14 FORMAT(A10,A69)
- 15 FORMAT(A12)
-
-C define input/output units
- IF(LINP.GE.0) THEN
- LI = LINP
- ELSE
- LI = 5
- ENDIF
-**sr temporarily changed
-C LO = LOUT
- LO = 6
-**
-
- IREJ = 0
-
- WRITE(LO,*)
- WRITE(LO,*) ' ==================================================='
- WRITE(LO,*) ' '
- WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
- WRITE(LO,*) ' '
- WRITE(LO,*) ' ==================================================='
- WRITE(LO,*) ' Authors: Ralph Engel (Bartol Res. Inst.)'
- WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
- WRITE(LO,*) ' Stefan Roesler (SLAC)'
- WRITE(LO,*) ' ---------------------------------------------------'
- WRITE(LO,*) ' Manual, updates, and further information:'
- WRITE(LO,*) ' http://lepton.bartol.udel.edu/~eng/phojet.html'
- WRITE(LO,*) ' ---------------------------------------------------'
- WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
- WRITE(LO,*) ' eng@lepton.bartol.udel.edu'
- WRITE(LO,*) ' ==================================================='
- WRITE(LO,*) ' $Date$'
- WRITE(LO,*) ' $Revision$'
-
- WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
-
- WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
-
- WRITE(LO,*) ' ==================================================='
- WRITE(LO,*)
-
-C standard initializations
- CALL PHO_DATINI
- CALL PHO_PARDAT
- DUM = PHO_PMASS(0,-1)
-
-C initialize standard PDFs
-C proton
- CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
- CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
-C neutron
- CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
- CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
-C photon
- CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
-C pomeron
- CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
-C pions
- CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
- CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
- CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
-C kaons
- CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
- CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
- CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
- CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
-
-C nothing to be done
- IF(LINP.LT.0) RETURN
-
-C main loop to read input cards
- 1200 CONTINUE
- READ(LINP,14,END=1300) CNAME,NUMBER
- IF(CNAME.EQ.'ENDINPUT ') THEN
- GOTO 1300
- ELSE IF(CNAME.EQ.'STOP ') THEN
- WRITE(LO,*) 'STOP'
- STOP
- ELSE IF(CNAME.EQ.'COMMENT ') THEN
- WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
- ELSE IF(CNAME(1:1).EQ.'*') THEN
- WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
- ELSE IF(CNAME.EQ.'PTCUT ') THEN
- READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
- WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
- & PARMDL(38),PARMDL(39)
- ELSE IF(CNAME.EQ.'PROCESS ') THEN
- READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
- WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
- ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
- READ(NUMBER,*) (ITMP(KK),KK=0,11)
- WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
- DO 112 KK=1,8
- IPRON(KK,ITMP(0)) = ITMP(KK)
- 112 CONTINUE
- ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
- READ(NUMBER,*) IMPRO,IP,ION
- WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
- MH_pro_on(IMPRO,IP) = ION
- ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
- READ(NUMBER,*) IDPDG,PVIR
- IHFLS(1) = 1
- XPSUB = 1.D0
- CALL PHO_SETPAR(1,IDPDG,0,PVIR)
- WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
- ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
- READ(NUMBER,*) IDPDG,PVIR
- IHFLS(2) = 1
- XTSUB = 1.D0
- CALL PHO_SETPAR(2,IDPDG,0,PVIR)
- WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
- ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
- READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
- IHFLS(1) = IVAL
- IHFLD(1,1) = IFL1
- IHFLD(1,2) = IFL2
- XPSUB = XSUB
- PVIR = 0.D0
- CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
- WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
- ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
- READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
- IHFLS(2) = IVAL
- IHFLD(2,1) = IFL1
- IHFLD(2,2) = IFL2
- XTSUB = XSUB
- PVIR = 0.D0
- CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
- WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
- ELSE IF(CNAME.EQ.'PDF ') THEN
- READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
- WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
- CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
- ELSE IF(CNAME.EQ.'SETMODEL ') THEN
- READ(NUMBER,*) I,IVAL
- WRITE(LO,*) 'SETMODEL ',I,IVAL
- CALL PHO_SETMDL(I,IVAL,1)
- ELSE IF(CNAME.EQ.'SETPARAM ') THEN
- READ(NUMBER,*) I,PARNEW
- WRITE(LO,*) 'SETPARAM ',I,PARNEW
- PARMDL(I) = PARNEW
- ELSE IF(CNAME.EQ.'DEBUG ') THEN
- READ(NUMBER,*) IDEBF,IDEBN,IDLEV
- WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
- CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
- ELSE IF(CNAME.EQ.'TRACE ') THEN
- READ(NUMBER,*) IDEBF,IDLEV
- WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
- IDEB(IDEBF) = IDLEV
- ELSE IF(CNAME.EQ.'SETICUT ') THEN
- READ(NUMBER,*) I,ICUT
- WRITE(LO,*) 'SETICUT ',I,ICUT
- ISWCUT(I) = ICUT
- ELSE IF(CNAME.EQ.'SETFCUT ') THEN
- READ(NUMBER,*) I,PARNEW
- WRITE(LO,*) 'SETFCUT ',I,PARNEW
- HSWCUT(I) = PARNEW
- ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
- READ(NUMBER,*) I,IVAL
- WRITE(LO,*) 'LUND-MSTU ',I,IVAL
- MSTU(I) = IVAL
- ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
- READ(NUMBER,*) I,IVAL
- WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
- MSTJ(I) = IVAL
- ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
- READ(NUMBER,*) I,EE
- WRITE(LO,*) 'LUND-PARJ ',I,EE
- PARJ(I) = REAL(EE)
- ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
- READ(NUMBER,*) I,EE
- WRITE(LO,*) 'LUND-PARU ',I,EE
- PARU(I) = REAL(EE)
- ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
- READ(NUMBER,*) ID,ION
- WRITE(LO,*) 'LUND-DECAY ',ID,ION
-
- KC=PYCOMP(ID)
-
- MDCY(KC,1) = ION
- ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
- READ(NUMBER,*) PSOMIN
- WRITE(LO,*) 'PSOFTMIN ',PSOMIN
- ELSE IF(CNAME.EQ.'INTPREC ') THEN
- READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-
-C PDF test utility
- ELSE IF(CNAME.EQ.'PDFTEST ') THEN
- READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
- PVIRT2 = ABS(PVIRT2)
- WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
- CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
-
-C mass cut on gamma-gamma or gamma-hadron system
- ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
- READ(NUMBER,*) ECMIN,ECMAX
- WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
-
-C beam lepton (anti-)tagging system
- ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
- READ(NUMBER,*) ITAG1,ITAG2
- WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
- ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
- READ(NUMBER,*)
- & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
- WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
- & Q2MIN1,Q2MAX1,THMIN1,THMAX1
- ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
- READ(NUMBER,*)
- & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
- WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
- & Q2MIN2,Q2MAX2,THMIN2,THMAX2
-
-C sampling of gamma-p events in ep (HERA)
- ELSE IF( (CNAME.EQ.'WW-HERA ')
- & .OR.(CNAME.EQ.'GP-HERA ')) THEN
- READ(NUMBER,*) EE1,EE2,NEV
- WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
- IF(YMAX2.LT.0.D0) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
- ELSE
- CALL PHO_GPHERA(NEV,EE1,EE2)
- KEVENT = 0
- ENDIF
-
-C sampling of gamma-gamma events in e+e- (LEP)
- ELSE IF( (CNAME.EQ.'GG-EPEM ')
- & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
- READ(NUMBER,*) EE1,EE2,NEV
- WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
- IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
- ELSE
- CALL PHO_GGEPEM(-1,EE1,EE2)
- CALL PHO_GGEPEM(NEV,EE1,EE2)
- CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
- KEVENT = 0
- ENDIF
-
-C sampling of gamma-gamma in heavy-ion collisions
- ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
- READ(NUMBER,*) EE,NA,NZ,NEV
- WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
- IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
- ELSE
- CALL PHO_GGHIOF(NEV,EE,NA,NZ)
- KEVENT = 0
- ENDIF
- ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
- READ(NUMBER,*) EE,NA,NZ,NEV
- WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
- IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
- ELSE
- CALL PHO_GGHIOG(NEV,EE,NA,NZ)
- KEVENT = 0
- ENDIF
-
-C sampling of gamma-hadron events in heavy ion collisions
- ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
- READ(NUMBER,*) EE,NA,NZ,NEV
- WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
- IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
- ELSE
- CALL PHO_GHHIOF(NEV,EE,NA,NZ)
- KEVENT = 0
- ENDIF
-
-C sampling of hadron-gamma events in hadron - heavy ion collisions
- ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
- READ(NUMBER,*) EP,EE,NA,NZ,NEV
- WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
- IF(YMAX2.LT.0.D0) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
- ELSE
- CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
- KEVENT = 0
- ENDIF
-
-C sampling of photoproduction events e+e-, backscattered laser
- ELSE IF(CNAME.EQ.'BLASER ') THEN
- READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
- WRITE(LO,*) 'BLASER ',EE1,EE2,
- & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
- CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
- KEVENT = 0
-
-C sampling of photoproduction events beamstrahlung
- ELSE IF(CNAME.EQ.'BEAMST ') THEN
- READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
- WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
- IF(YMAX1.LT.0.D0) THEN
- WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
- ELSE
- CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
- KEVENT = 0
- ENDIF
-
-C fixed-energy events in LAB system of particle 2
- ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
- READ(NUMBER,*) PLAB,NEV
- WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
- CALL PHO_FIXLAB(PLAB,NEV)
- KEVENT = 0
-
-C fixed-energy events in CM system
- ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
- READ(NUMBER,*) ECM,NEV
- WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
- PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
- PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
- CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
- E1 = EE
- E2 = ECM-EE
- THETA = 0.D0
- PHI = 0.D0
- CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
- KEVENT = 0
-
-C fixed-energy events for collider setup with crossing angle
- ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
- READ(NUMBER,*) E1,E2,THETA,PHI,NEV
- WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
- CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
- KEVENT = 0
-
-C unknown data card
- ELSE
- WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
- ENDIF
-
- GOTO 1200
- 1300 CONTINUE
- WRITE(LO,*) ' RETURN'
-
- END
-
-CDECK ID>, PHO_SETMDL
- SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
-C**********************************************************************
-C
-C set model switches
-C
-C input: INDX model parameter number
-C (positive: ISWMDL, negative: IPAMDL)
-C IVAL new value
-C IMODE -1 print value of parameter INDX
-C 1 set new value
-C -2 print current settings
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
- IF(IMODE.EQ.-2) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
-C & '----------------------------'
- DO 100 I=1,48,3
- IF(ISWMDL(I).EQ.-9999) GOTO 200
- IF(ISWMDL(I+1).EQ.-9999) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
- GOTO 200
- ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
-C WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
-C & I+1,':',MDLNA(I+1),ISWMDL(I+1)
- GOTO 200
- ELSE
-C WRITE(LO,'(3(5X,I3,A1,A,I6))')
-C & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
- ENDIF
- 100 CONTINUE
- 200 CONTINUE
- ELSE IF(IMODE.EQ.-1) THEN
-C WRITE(LO,'(1X,A,1X,A,I6)')
-C & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
- ELSE IF(IMODE.EQ.1) THEN
- IF(INDX.GT.0) THEN
- IF(ISWMDL(INDX).NE.IVAL) THEN
- WRITE(LO,'(1X,A,I4,1X,A,2I6)')
- & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
- & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
- ISWMDL(INDX) = IVAL
- ENDIF
- ELSE IF(INDX.LT.0) THEN
- IF(IPAMDL(-INDX).NE.IVAL) THEN
- WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
- & -INDX,IPAMDL(-INDX),IVAL
- IPAMDL(-INDX) = IVAL
- ENDIF
- ENDIF
- ELSE
- WRITE(LO,'(/1X,A,I6)')
- & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
- ENDIF
- END
-
-CDECK ID>, PHO_DATINI
- SUBROUTINE PHO_DATINI
-C*********************************************************************
-C
-C initialization of variables and switches
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C cut probability distribution
- INTEGER IEETA1,IIMAX,KKMAX
- PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
- INTEGER IEEMAX,IMAX,KMAX
- REAL PROB
- DOUBLE PRECISION EPTAB
- COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
- & IEEMAX,IMAX,KMAX
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C parameters of the "simple" Vector Dominance Model
- DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
- COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
-C parameters for DGLAP backward evolution in ISR
- INTEGER NFSISR
- DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
- COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
-C particles created by initial state evolution
- INTEGER MXISR1,MXISR2
- PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
- INTEGER IFLISR,IPOISR,IMXISR
- DOUBLE PRECISION PHISR
- COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
- & IPOISR(2,2,MXISR2),IMXISR(2)
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C interpolation tables for hard cross section and MC selection weights
- INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
- PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
- INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
- DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
- & HQ2a_tab,HQ2b_tab,HEcm_tab
- COMMON /POHTAB/
- & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
- & HEcm_tab(1:Max_tab_E,0:4),
- & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
-
-C initialize /POCONS/
- PI = ATAN(1.D0)*4.D0
- PI2 = 2.D0*PI
- PI4 = 2.D0*PI2
-C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
- GEV2MB = 0.389365D0
-C precalculate quark charges
- do i=1,6
- Q_ch(i) = dble(2-3*mod(i,2))/3.D0
- Q_ch(-i) = -Q_ch(i)
-
- Q_ch2(i) = Q_ch(i)**2
- Q_ch2(-i) = Q_ch2(i)
-
- Q_ch4(i) = Q_ch2(i)**2
- Q_ch4(-i) = Q_ch4(i)
- enddo
- Q_ch(0) = 0.D0
- Q_ch2(0) = 0.D0
- Q_ch4(0) = 0.D0
-
-C initialize /GLOCMS/
- ECM = 50.D0
- PMASS(1) = 0.D0
- PVIRT(1) = 0.D0
- PMASS(2) = 0.D0
- PVIRT(2) = 0.D0
- IFPAP(1) = 22
- IFPAP(2) = 22
-C initialize /HADVAL/
- IHFLD(1,1) = 0
- IHFLD(1,2) = 0
- IHFLD(2,1) = 0
- IHFLD(2,2) = 0
- IHFLS(1) = 1
- IHFLS(2) = 1
-C initialize /MODELS/
- ISWMDL(1) = 3
- MDLNA(1) = 'AMPL MOD'
- ISWMDL(2) = 1
- MDLNA(2) = 'MIN-BIAS'
- ISWMDL(3) = 1
- MDLNA(3) = 'PTS DISH'
- ISWMDL(4) = 1
- MDLNA(4) = 'PTS DISP'
- ISWMDL(5) = 2
- MDLNA(5) = 'PTS ASSI'
- ISWMDL(6) = 3
- MDLNA(6) = 'HADRONIZ'
- ISWMDL(7) = 2
- MDLNA(7) = 'MASS COR'
- ISWMDL(8) = 3
- MDLNA(8) = 'PAR SHOW'
- ISWMDL(9) = 0
- MDLNA(9) = 'GLU SPLI'
- ISWMDL(10) = 2
- MDLNA(10) = 'VIRT PHO'
- ISWMDL(11) = 0
- MDLNA(11) = 'LARGE NC'
- ISWMDL(12) = 0
- MDLNA(12) = 'LIPA POM'
- ISWMDL(13) = 1
- MDLNA(13) = 'QELAS VM'
- ISWMDL(14) = 2
- MDLNA(14) = 'ENHA GRA'
- ISWMDL(15) = 4
- MDLNA(15) = 'MULT SCA'
- ISWMDL(16) = 4
- MDLNA(16) = 'MULT DIF'
- ISWMDL(17) = 4
- MDLNA(17) = 'MULT CDF'
- ISWMDL(18) = 0
- MDLNA(18) = 'BALAN PT'
- ISWMDL(19) = 1
- MDLNA(19) = 'POMV FLA'
- ISWMDL(20) = 0
- MDLNA(20) = 'SEA FLA'
- ISWMDL(21) = 2
- MDLNA(21) = 'SPIN DEC'
- ISWMDL(22) = 1
- MDLNA(22) = 'DIF.MASS'
- ISWMDL(23) = 1
- MDLNA(23) = 'DIFF RES'
- ISWMDL(24) = 0
- MDLNA(24) = 'PTS HPOM'
- ISWMDL(25) = 0
- MDLNA(25) = 'POM CORR'
- ISWMDL(26) = 1
- MDLNA(26) = 'OVERLAP '
- ISWMDL(27) = 0
- MDLNA(27) = 'MUL R/AN'
- ISWMDL(28) = 1
- MDLNA(28) = 'SUR PROB'
- ISWMDL(29) = 1
- MDLNA(29) = 'PRIMO KT'
- ISWMDL(30) = 0
- MDLNA(30) = 'DIFF. CS'
- ISWMDL(31) = -9999
-C mass-independent sea flavour ratios (for low-mass strings)
- PARMDL(1) = 0.425D0
- PARMDL(2) = 0.425D0
- PARMDL(3) = 0.15D0
- PARMDL(4) = 0.D0
- PARMDL(5) = 0.D0
- PARMDL(6) = 0.D0
-C suppression by energy momentum conservation
- PARMDL(8) = 9.D0
- PARMDL(9) = 7.D0
-C VDM factors
- PARMDL(10) = 0.866D0
- PARMDL(11) = 0.288D0
- PARMDL(12) = 0.288D0
- PARMDL(13) = 0.288D0
- PARMDL(14) = 0.866D0
- PARMDL(15) = 0.288D0
- PARMDL(16) = 0.288D0
- PARMDL(17) = 0.288D0
- PARMDL(18) = 0.D0
-C lower energy limit for initialization
- PARMDL(19) = 5.D0
-C soft pt for hard scattering remnants
- PARMDL(20) = 5.D0
-C low energy beta of soft pt distribution 1
- PARMDL(21) = 4.5D0
-C high energy beta of soft pt distribution 1
- PARMDL(22) = 3.0D0
-C low energy beta of soft pt distribution 0
- PARMDL(23) = 2.5D0
-C high energy beta of soft pt distribution 0
- PARMDL(24) = 0.4D0
-C effective quark mass in photon wave function
- PARMDL(25) = 0.2D0
-C normalization of unevolved Pomeron PDFs
- PARMDL(26) = 0.3D0
-C effective VDM parameters for Q**2 dependence of cross section
- PARMDL(27) = 0.65D0
- PARMDL(28) = 0.08D0
- PARMDL(29) = 0.05D0
- PARMDL(30) = 0.22D0
- PARMDL(31) = 0.589824D0
- PARMDL(32) = 0.609961D0
- PARMDL(33) = 1.038361D0
- PARMDL(34) = 1.96D0
-C Q**2 suppression of multiple interactions
- PARMDL(35) = 0.59D0
-C pt cutoff defaults
- PARMDL(36) = 2.5D0
- PARMDL(37) = 2.5D0
- PARMDL(38) = 2.5D0
- PARMDL(39) = 2.5D0
-C enhancement factor for diffractive cross sections
- PARMDL(40) = 1.D0
- PARMDL(41) = 1.D0
- PARMDL(42) = 1.D0
-C mass in soft pt distribution
- PARMDL(43) = 0.D0
-C maximum of x allowed for leading particle
- PARMDL(44) = 0.9D0
-C max. mass sampled in diffraction
- PARMDL(45) = sqrt(0.4D0)
-C mass threshold in diffraction (2pi mass)
- PARMDL(46) = 0.3D0
-C regularization of slope parameter in diffraction
- PARMDL(47) = 4.D0
-C renormalized intercept for enhanced graphs
- PARMDL(48) = 1.08D0
-C coherence constraint for diff. cross sections
- PARMDL(49) = sqrt(0.05D0)
-C exponents of x distributions
-C baryon
- PARMDL(50) = 1.5D0
- PARMDL(51) = -0.5D0
- PARMDL(52) = -0.99D0
- PARMDL(53) = -0.99D0
-C meson (non-strangeness part)
- PARMDL(54) = -0.5D0
- PARMDL(55) = -0.5D0
- PARMDL(56) = -0.99D0
- PARMDL(57) = -0.99D0
-C meson (strangeness part)
- PARMDL(58) = -0.2D0
- PARMDL(59) = -0.2D0
- PARMDL(60) = -0.99D0
- PARMDL(61) = -0.99D0
-C particle remnant (no valence quarks)
- PARMDL(62) = -0.5D0
- PARMDL(63) = -0.5D0
- PARMDL(64) = -0.99D0
- PARMDL(65) = -0.99D0
-C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
- PARMDL(66) = 10.D0
-C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
- PARMDL(67) = 10.D0
-C min. abs(t) in diffraction
- PARMDL(68) = 0.D0
-C max. abs(t) in diffraction
- PARMDL(69) = 10.D0
-C min. mass for elastic pomerons in central diffraction
- PARMDL(70) = 2.D0
-C min. mass of diffractive blob in central diffraction
- PARMDL(71) = 2.D0
-C min. Feynman x cut in central diffraction
- PARMDL(72) = 0.D0
-C direct pomeron coupling
- PARMDL(74) = 0.D0
-C relative deviation allowed for energy-momentum conservation
-C energy-momentum relative deviation
- PARMDL(75) = 0.01D0
-C transverse momentum deviation
- PARMDL(76) = 0.01D0
-C couplings for unitarization in diffraction
-C non-unitarized pomeron coupling (sqrt(mb))
- PARMDL(77) = 3.D0
-C rescaling factor for pomeron PDF
- PARMDL(78) = 3.D0
-C coupling probabilities
- PARMDL(79) = 1.D0
- PARMDL(80) = 0.D0
-C scales to calculate alpha-s of matrix element
- PARMDL(81) = 1.D0
- PARMDL(82) = 1.D0
- PARMDL(83) = 1.D0
-C scales to calculate alpha-s of initial state radiation
- PARMDL(84) = 1.D0
- PARMDL(85) = 1.D0
- PARMDL(86) = 1.D0
-C scales to calculate alpha-s of final state radiation
- PARMDL(87) = 1.D0
- PARMDL(88) = 1.D0
- PARMDL(89) = 1.D0
-C scales to calculate PDFs
- PARMDL(90) = 1.D0
- PARMDL(91) = 1.D0
- PARMDL(92) = 1.D0
-C scale for ISR starting virtuality
- PARMDL(93) = 1.D0
-C min. virtuality to generate time-like showers in ISR
- PARMDL(94) = 2.D0
-C factor to scale the max. allowed time-like parton shower virtuality
- PARMDL(95) = 4.D0
-C max. transverse momentum for primordial kt
- PARMDL(100) = 2.D0
-C weight factors for pt-distribution
- PARMDL(101) = 2.D0
- PARMDL(102) = 2.D0
- PARMDL(103) = 4.D0
- PARMDL(104) = 2.D0
- PARMDL(105) = 6.D0
- PARMDL(106) = 4.D0
-C
-* PARMDL(110-125) reserved for hard scattering
-C currently chosen scales for hard scattering
- DO 10 I=1,16
- PARMDL(109+I) = 0.D0
- 10 CONTINUE
-C virtuality cutoff in initial state evolution
- PARMDL(126) = PARMDL(36)**2
- PARMDL(127) = PARMDL(37)**2
- PARMDL(128) = PARMDL(38)**2
- PARMDL(129) = PARMDL(39)**2
-C virtuality cutoff for direct contribution to photon PDF
- PARMDL(130) = 1.D30
- PARMDL(131) = 1.D30
- PARMDL(132) = 1.D30
- PARMDL(133) = 1.D30
-C fraction of events without popcorn
- PARMDL(134) = -1.D0
-C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
- PARMDL(135) = 0.5D0
-C soft color re-connection (fraction)
-C g g final state
- PARMDL(140) = 1.D0/64.D0
-C g q final state
- PARMDL(141) = 1.D0/24.D0
-C q q final state
- PARMDL(142) = 1.D0/9.D0
-C effective scale in Drees-Godbole like suppresion in photon PDF
- PARMDL(144) = 0.766D0**2
-C QCD scales (if PDF scales are not used, 4 active flavours)
- PARMDL(145) = 0.2D0**2
- PARMDL(146) = 0.2D0**2
- PARMDL(147) = 0.2D0**2
-C threshold scales for variable flavour calculation (GeV**2)
- PARMDL(148) = 1.5D0**2
- PARMDL(149) = 4.5D0**2
- PARMDL(150) = 175.D0**2
-C constituent quark masses
- PARMDL(151) = 0.3D0
- PARMDL(152) = 0.3D0
- PARMDL(153) = 0.5D0
- PARMDL(154) = 1.6D0
- PARMDL(155) = 5.D0
- PARMDL(156) = 174.D0
-C min. masses of valence quark
- PARMDL(157) = 0.3D0
-C min. masses of valence diquark
- PARMDL(158) = 0.8D0
-C min. mass of sea quark
- PARMDL(159) = 0.D0
-C suppression of strange quarks as photon valences
- PARMDL(160) = 0.2D0
-C min. masses for strings (used in PHO_SOFTXX)
- PARMDL(161) = 1.D0
- PARMDL(162) = 1.D0
- PARMDL(163) = 1.D0
- PARMDL(164) = 1.D0
-C min. momentum fraction for soft processes
- PARMDL(165) = 0.3D0
-C min. phase space for x-sampling
- PARMDL(166) = 0.135D0
-C Ross-Stodolsky exponent
- PARMDL(170) = 4.2D0
-C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
- PARMDL(175) = 2.D0
-
-**sr
-* extra factor multiplying difference between Goulianos and PHOJET-
-* diff. cross sections
- PARMDL(200) = 0.6D0
-**
-
-C complex amplitudes, eikonal functions
- IPAMDL(1) = 0
-C allow for Reggeon cuts
- IPAMDL(2) = 1
-C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
- IPAMDL(3) = 0
-C polarization of photon resonances (0 none, 1 trans, 2 long)
- IPAMDL(4) = 1
-C pt of valence partons
- IPAMDL(5) = 1
-C pt of hard scattering remnant
- IPAMDL(6) = 2
-C running cutoff for hard scattering
- IPAMDL(7) = 1
-C intercept used for the calculation of enhanced graphs
- IPAMDL(8) = 1
-C effective slope of hard scattering amplitde
- IPAMDL(9) = 1
-C mass dependence of slope parameters
- IPAMDL(10) = 0
-C lepton-photon vertex 1
- IPAMDL(11) = 0
-C lepton-photon vertex 2
- IPAMDL(12) = 0
-C call by DPMJET
- IPAMDL(13) = 0
-C method to sample x distributions
- IPAMDL(14) = 3
-C energy-momentum check
- IPAMDL(15) = 1
-C phase space correction for DPMJET interface
- IPAMDL(16) = 1
-C fragment strings from projectile/target/central diff. separately
- IPAMDL(17) = 1
-C method to construct strings for hard interactions
- IPAMDL(18) = 1
-C method to construct strings for soft sea (pomeron cuts)
- IPAMDL(19) = 0
-C method to construct strings in pomeron interactions
- IPAMDL(20) = 0
-C soft color re-connection
- IPAMDL(21) = 0
-C resummation of triple- and loop-Pomeron
- IPAMDL(24) = 1
-C resummation of X iterated triple-Pomeron
- IPAMDL(25) = 1
-C dimension of interpolation table for weights in hard scattering
- IPAMDL(30) = Max_tab_E
-C dimension of interpolation table for pomeron cut distribution
- IPAMDL(31) = IEETA1
-C number of cut soft pomerons (restriction by field dimension)
- IPAMDL(32) = IIMAX
-C number of cut hard pomerons (restriction by field dimension)
- IPAMDL(33) = KKMAX
-C tau pair production in direct photon-photon collisions
- IPAMDL(64) = 0
-C currently chosen scales for hard scattering
-C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
- DO 15 I=1,16
- IPAMDL(64+I) = -99999
- 15 CONTINUE
-C scales to calculate alpha-s of matrix element
- IPAMDL(81) = 1
- IPAMDL(82) = 1
- IPAMDL(83) = 1
-C scales to calculate alpha-s of initial state radiation
- IPAMDL(84) = 1
- IPAMDL(85) = 1
- IPAMDL(86) = 1
-C scales to calculate alpha-s of final state radiation
- IPAMDL(87) = 1
- IPAMDL(88) = 1
- IPAMDL(89) = 1
-C scales to calculate PDFs
- IPAMDL(90) = 1
- IPAMDL(91) = 1
- IPAMDL(92) = 1
-C where to get the parameter sets from
- IPAMDL(99) = 1
-C program PHO_ABORT for fatal errors (simulation of division by zero)
- IPAMDL(100) = 0
-C initial state parton showers for all / hardest interaction(s)
- IPAMDL(101) = 1
-C final state parton showers for all / hardest interaction(s)
- IPAMDL(102) = 1
-C initial virtuality for ISR generation
- IPAMDL(109) = 1
-C qqbar-gamma coupling in initial state showers
- IPAMDL(110) = 1
-C generation of time-like showers during ISR
- IPAMDL(111) = 1
-C reweighting of multiple soft contributions for virtual photons
- IPAMDL(114) = 1
-C reweighting / use photon virtuality in photon PDF calculations
- IPAMDL(115) = 0
-C use full QPM model incl. interference terms (direct part in gam-gam)
- IPAMDL(116) = 0
-C matching sigma_tot to F2 as given by parton density at high Q2
- IPAMDL(117) = 1
-C use virtuality of target in F2 calculations (two-gamma only)
- IPAMDL(118) = 1
-C calculation of alpha_em
- IPAMDL(120) = 1
-C strict pt cutoff for gamma-gamma events
- IPAMDL(121) = 0
-C photon virtuality sampled in photon flux approximations
- IPAMDL(174) = 1
-C photon-pomeron: 0,1,2: both,left,right photon emission
- IPAMDL(175) = 0
-C keep full history information in PHOJET-JETSET interface
- IPAMDL(178) = 1
-C max. number of conservation law violations allowed in one run
- IPAMDL(179) = 20
-C selection of soft X values
-C max. iteration number in PHO_SELSXS
- IPAMDL(180) = 50
-C max. iteration number in PHO_SELSXR
- IPAMDL(181) = 200
-C max. iteration number in PHO_SELSX2
- IPAMDL(182) = 100
-C max. iteration number in PHO_SELSXI
- IPAMDL(183) = 50
-
-C initialize /PROBAB/
- IEEMAX = IEETA1
- IMAX = IIMAX
- KMAX = KKMAX
-
- DO 20 I=1,30
- PARMDL(300+I) = -100000.D0
- 20 CONTINUE
-C initialize /POHDRN/
- QMASS(1) = PARMDL(151)
- QMASS(2) = PARMDL(152)
- QMASS(3) = PARMDL(153)
- QMASS(4) = PARMDL(154)
- QMASS(5) = PARMDL(155)
- QMASS(6) = PARMDL(156)
- BET = 8.D0
- PCOUDI = 0.D0
- VALPRG(1) = 1.D0
- VALPRG(2) = 1.D0
-C number of light flavours (quarks treated as massless)
- NFS = 4
-C initialize /POCUT1/
- PTCUT(1) = PARMDL(36)
- PTCUT(2) = PARMDL(37)
- PTCUT(3) = PARMDL(38)
- PTCUT(4) = PARMDL(39)
- PSOMIN = 0.D0
- XSOMIN = 0.D0
-C initialize /POHAPA/
- NFbeta = 4
- NF = 4
- BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
- BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
- BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
- BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
-C initialize /POGAUP/
- NGAUP1 = 12
- NGAUP2 = 12
- NGAUET = 16
- NGAUIN = 12
- NGAUSO = 96
-C initialize //
- DO 30 I=1,100
- IDEB(I) = 0
- 30 CONTINUE
-C initialize /PROCES/
- DO 35 I=1,11
- IPRON(I,1) = 1
- 35 CONTINUE
-
-C DPMJET default: no elastic scattering
- IPRON(2,1) = 0
-
- DO 36 K=2,4
- DO 37 I=2,11
- IPRON(I,K) = 0
- 37 CONTINUE
- IPRON(1,K) = 1
- IPRON(8,K) = 1
- 36 CONTINUE
-C initialize /POSVDM/
- TWOPIM = 0.28D0
- RMIN(1) = 0.285D0
- RMIN(2) = 0.45D0
- RMIN(3) = 1.D0
- RMIN(4) = TWOPIM
- VMAS(1) = 0.770D0
- VMAS(2) = 0.787D0
- VMAS(3) = 1.02D0
- VMAS(4) = TWOPIM
- GAMM(1) = 0.155D0
- GAMM(2) = 0.01D0
- GAMM(3) = 0.0045D0
- GAMM(4) = 1.D0
- RMAX(1) = VMAS(1)+TWOPIM
- RMAX(2) = VMAS(2)+TWOPIM
- RMAX(3) = VMAS(3)+TWOPIM
- RMAX(4) = VMAS(1)+TWOPIM
- VMSL(1) = 11.D0
- VMSL(2) = 10.D0
- VMSL(3) = 6.D0
- VMSL(4) = 4.D0
- VMFA(1) = 0.0033D0
- VMFA(2) = 0.00036D0
- VMFA(3) = 0.0002D0
- VMFA(4) = 0.0002D0
-C initialize /PODGL1/
- Q2MISR(1) = PARMDL(36)**2
- Q2MISR(2) = PARMDL(36)**2
- PMISR(1) = 1.D0
- PMISR(2) = 1.D0
- ZMISR(1) = 0.001D0
- ZMISR(2) = 0.001D0
- AL2ISR(1) = 0.046D0
- AL2ISR(2) = 0.046D0
- NFSISR = 4
-C initialize /POPISR/
- DO 40 I=1,50
- IPOISR(1,2,I) = 0
- IPOISR(2,2,I) = 0
- 40 CONTINUE
-C initialize /POHPRO/
- PROC(0) = 'sum over processes'
- PROC(1) = 'G +G --> G +G '
- PROC(2) = 'Q +QB --> G +G '
- PROC(3) = 'G +Q --> G +Q '
- PROC(4) = 'G +G --> Q +QB '
- PROC(5) = 'Q +QB --> Q +QB '
- PROC(6) = 'Q +QB --> QP +QBP'
- PROC(7) = 'Q +Q --> Q +Q '
- PROC(8) = 'Q +QP --> Q +QP '
- PROC(9) = 'resolved processes'
- PROC(10) = 'gam+Q --> G +Q '
- PROC(11) = 'gam+G --> Q +QB '
- PROC(12) = 'Q +gam--> G +Q '
- PROC(13) = 'G +gam--> Q +QB '
- PROC(14) = 'gam+gam--> Q +QB '
- PROC(15) = 'direct processes '
- PROC(16) = 'gam+gam--> l+ +l- '
-
-C initialize /POHRCS/
- do M=1,Max_pro_2
- HWgx(M) = 0.D0
- HSig(M) = 0.D0
- Hdpt(M) = 0.D0
- enddo
- DO I=0,4
- DO M=-1,Max_pro_2
-C switch all hard subprocesses on
- MH_pro_on(M,I) = 1
-C reset all counters
- MH_tried(M,I) = 0
- MH_acc_1(M,I) = 0
- MH_acc_2(M,I) = 0
- ENDDO
- MH_pro_on(16,I) = 0
- ENDDO
-
-C initialize /POHTAB/
- do I=0,4
- IH_Ecm_up(I) = 0
- IH_Q2a_up(I) = 0
- IH_Q2b_up(I) = 0
- HEcm_tab(1,I) = 0.D0
- enddo
- HEcm_last = 0.D0
- IHa_last = 0.D0
- IHb_last = 0.D0
-
-C initialize /POFSRC/
- IGHEL(1) = -1
- IGHEL(2) = -1
-C initialize /LEPCUT/
- ECMIN = 5.D0
- ECMAX = 1.D+30
- EEMIN1 = 1.D0
- EEMIN2 = 1.D0
- YMAX1 = -1.D0
- YMAX2 = -1.D0
- THMIN1 = 0.D0
- THMAX1 = PI
- THMIN2 = 0.D0
- THMAX2 = PI
- ITAG1 = 1
- ITAG2 = 1
-C initialize /POWGHT/
- DO 70 I=1,20
- HSWCUT(I) = 0.D0
- ISWCUT(I) = 0
- 70 CONTINUE
- EVWGHT(1) = 1.D0
- IVWGHT(1) = 0
- SIGGEN(1) = 0.D0
- SIGGEN(2) = 0.D0
- SIGGEN(3) = 0.D0
- SIGGEN(4) = 0.D0
-
- END
-
-CDECK ID>, PHO_PARDAT
- SUBROUTINE PHO_PARDAT
-C***********************************************************************
-C
-C particle data (based on 1996 PDG naming scheme and data tables)
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-C particle decay data
- double precision wg_sec_list
- integer idec_list,isec_list
- COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
- & isec_list(3,500)
-
-C external functions
-
- integer ipho_pdg2id
- double precision pho_pmass
-
-C local variables for storing data tables
-
- integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
- & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
-
- dimension number(300),ich3(300),iba3(300),iq_linear(900),
- & idec_linear(900),isec_linear(900),id_psm_linear(36),
- & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
-
- double precision xmass,gamma,wg_chan
- dimension xmass(300),gamma(300),wg_chan(300)
-
- character*12 name
- dimension name(300)
-
- integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
- double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
-
- integer itmp
-
- DATA i_tab_max /260/
-
- DATA (number(K),K= 1, 171) /
- & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
- & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
- & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
- & 110, 990, 21, 22, 24, 23, 11, 13, 15,
- & 12, 14, 16, 211, 111, 221, 113, 213, 223,
- & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
- & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
- & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
- & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
- & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
- & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
- & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
- & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
- & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
- & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
- & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
- & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
- & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
- & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
- DATA (number(K),K= 172, 260) /
- & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
- & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
- & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
- & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
- & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
- & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
- & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
- & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
- & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
- & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
- DATA (name(K),K= 1, 76) /
- &'d ','u ','s ','c ',
- &'b ','t ','(dd)_1 ','(ud)_0 ',
- &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
- &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
- &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
- &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
- &'string ','mod. string ','coll. string','reggeon ',
- &'pomeron ','gluon ','gamma ','W ',
- &'Z ','e ','mu ','tau ',
- &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
- &'pi ','eta ','rho(770) ','rho(770) ',
- &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
- &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
- &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
- &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
- &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
- &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
- &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
- &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
- DATA (name(K),K= 77, 152) /
- &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
- &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
- &'K ','K(S) ','K(L) ','K*(892) ',
- &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
- &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
- &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
- &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
- &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
- &'K(4)*(2045) ','D ','D ','D*(2007) ',
- &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
- &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
- &'B ','B* ','B* ','B(s) ',
- &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
- &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
- &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
- &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
- &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
- &'Ups(10860) ','Ups(11020) ','p ','n ',
- &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
- DATA (name(K),K= 153, 228) /
- &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
- &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
- &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
- &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
- &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
- &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
- &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
- &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
- &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
- &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
- &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
- &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
- &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
- &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
- &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
- &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
- &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
- &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
- &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
- DATA (name(K),K= 229, 260) /
- &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
- &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
- &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
- &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
- &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
- &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
- &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
- &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
- DATA (ich3(K),K= 1, 260) /
- &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
- & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
- & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
- & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
- & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
- & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
- &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
- & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
- & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
- & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
- DATA (iba3(K),K= 1, 260) /
- &1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,
- &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- &0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
- &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
- &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
- &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
- DATA (iq_linear(K),K= 1, 418) /
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
- & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
- & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
- & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
- &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
- & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
- & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
- &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
- & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
- & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
- &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
- & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
- & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
- &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
- & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
- & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
- DATA (iq_linear(K),K= 419, 780) /
- &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
- & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
- & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
- & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
- & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
- & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
- & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
- & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
- & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
- & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
- & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
- & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
- & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
- & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
- & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
- & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
- & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
- DATA (xmass(K),K= 1, 114) /
- &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
- &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
- &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
- &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
- &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
- &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
- &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
- &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
- &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
- &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
- &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
- &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
- &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
- &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
- &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
- &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
- DATA (xmass(K),K= 115, 228) /
- &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
- &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
- &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
- &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
- &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
- &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
- &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
- &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
- &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
- &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
- &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
- &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
- &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
- &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
- &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
- &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
- &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
- &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
- &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
- DATA (xmass(K),K= 229, 260) /
- &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
- &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
- &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
- &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
- &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
- &2.7040E+00,5.6240E+00/
- DATA (gamma(K),K= 1, 114) /
- &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
- &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
- &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
- &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
- &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
- &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
- &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
- &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
- &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
- &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
- &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
- &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
- &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
- &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
- &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
- &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
- DATA (gamma(K),K= 115, 228) /
- &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
- &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
- &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
- &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
- &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
- &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
- &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
- &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
- &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
- &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
- &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
- &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
- &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
- &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
- &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
- &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
- &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
- &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
- &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
- DATA (gamma(K),K= 229, 260) /
- &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
- &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
- &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
- &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
- &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
- &1.0200E-11,5.3100E-13/
- DATA (idec_linear(K),K= 1, 304) /
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
- & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 1, 25, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 30, 32,
- & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
- & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
- & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
- & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (idec_linear(K),K= 305, 608) /
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 2, 77, 78, 2, 79, 82, 1, 83, 84,
- & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
- & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 1, 99,101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
- &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 1,137,144, 1,145,152, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
- &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
- &163,169, 1,170,176, 1,177,180, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (idec_linear(K),K= 609, 780) /
- & 0, 0, 0, 0, 3,181,182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,183,184, 3,185,
- &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,195,203, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 1,204,216, 0, 0, 0, 3,217,217, 3,
- &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
- &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
- & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
- DATA (isec_linear(K),K= 1, 152) /
- & 11, 12, -12, 13, -14, 16, 11, -12,
- & 16, -213, 16, 0, -211, 16, 0, -323,
- & 16, 0, -13, 12, 0, 22, 22, 0,
- & 22, -11, 11, 22, 22, 0, 111, 22,
- & 22, 111, 111, 111, 211, -211, 111, 211,
- & -211, 22, 211, -211, 0, 111, 111, 0,
- & 211, 111, 0, 211, -211, 111, 211, -211,
- & 0, 111, 22, 0, 221, 211, -211, 221,
- & 111, 111, 211, -211, 22, 22, 22, 0,
- & 321, -321, 0, 130, 310, 0, 113, 111,
- & 0, 211, -211, 111, 221, 22, 0, 113,
- & 111, 0, -213, 211, 0, 213, -211, 0,
- & 211, -211, 0, 111, 111, 0, 113, 111,
- & 0, -213, 211, 0, 213, -211, 0, 311,
- & -313, 0, -311, 313, 0, 113, 211, -211,
- & -13, 12, 0, 211, 111, 0, 211, 211,
- & -211, 211, 111, 111, -13, 111, 12, -11,
- & 111, 12, 211, -211, 0, 111, 111, 0,
- & 111, 111, 111, 211, -211, 111, 211, 13/
- DATA (isec_linear(K),K= 153, 304) /
- & 12, 211, 11, 12, 321, 111, 0, 311,
- & 211, 0, 311, 111, 0, 321, -211, 0,
- & 311, 111, 0, 321, -211, 0, 321, 111,
- & 0, 311, 211, 0, 311, 111, 0, 321,
- & -211, 0, 313, 111, 0, 323, -211, 0,
- & 311, 113, 0, 321, -213, 0, 311, 223,
- & 0, 311, 221, 0, 321, 111, 0, 311,
- & 211, 0, 323, 111, 0, 313, 211, 0,
- & 321, 113, 0, 311, 213, 0, 321, 223,
- & 0, 321, 221, 0, -321, 211, 211, -311,
- & 211, 0, -321, 211, 0, -321, 211, 111,
- & 311, 211, -211, 311, 111, 0, 421, 111,
- & 0, 421, 22, 0, 421, 211, 0, 411,
- & 111, 0, 411, 22, 0, 221, 211, 0,
- & 321, -321, 321, 321, -311, 0, 431, 22,
- & 0, 431, 22, 0, 111, 111, 0, 211,
- & -211, 0, 22, 22, 0, -11, 11, 0,
- & -13, 13, 0, 211, -211, 111, 443, 211,
- & -211, 443, 111, 111, 443, 221, 0, 2212/
- DATA (isec_linear(K),K= 305, 456) /
- & 11, 12, 2112, 111, 0, 2212, -211, 0,
- & 2112, 111, 111, 2112, 211, -211, 1114, 211,
- & 0, 2114, 111, 0, 2214, -211, 0, 2112,
- & 113, 0, 2212, -213, 0, 2112, 221, 0,
- & 2212, 111, 0, 2112, 211, 0, 2212, 111,
- & 111, 2212, 211, -211, 2224, -211, 0, 2214,
- & 111, 0, 2114, 211, 0, 2212, 113, 0,
- & 2112, 213, 0, 2212, 221, 0, 2212, -211,
- & 0, 2112, 111, 0, 2214, -211, 0, 2114,
- & 111, 0, 1114, 211, 0, 2212, -213, 0,
- & 2112, 113, 0, 2212, 111, 0, 2112, 211,
- & 0, 2224, -211, 0, 2214, 111, 0, 2114,
- & 211, 0, 2212, 113, 0, 2112, 213, 0,
- & 2212, -211, 0, 2112, 111, 0, 2212, -213,
- & 0, 2112, 113, 0, 3122, 311, 0, 3212,
- & 311, 0, 3112, 321, 0, 2112, 221, 0,
- & 2212, 111, 0, 2112, 211, 0, 2212, 113,
- & 0, 2112, 213, 0, 3122, 321, 0, 3222,
- & 311, 0, 3212, 321, 0, 2212, 221, 0/
- DATA (isec_linear(K),K= 457, 608) /
- & 2112, -211, 0, 2212, -211, 0, 2112, 111,
- & 0, 2212, 111, 0, 2112, 211, 0, 2212,
- & 211, 0, 2112, -211, 0, 2114, -211, 0,
- & 1114, 111, 0, 2112, -213, 0, 2212, -211,
- & 0, 2112, 111, 0, 2214, -211, 0, 2114,
- & 111, 0, 1114, 211, 0, 2212, -213, 0,
- & 2112, 113, 0, 2212, 111, 0, 2112, 211,
- & 0, 2224, -211, 0, 2214, 111, 0, 2114,
- & 211, 0, 2212, 113, 0, 2112, 213, 0,
- & 2212, 211, 0, 2224, 111, 0, 2214, 211,
- & 0, 2212, 213, 0, 2212, -211, 0, 2112,
- & 111, 0, 2212, 111, 0, 2112, 211, 0,
- & 3122, 22, 0, 2112, -211, 0, 3122, 211,
- & 0, 3212, 211, 0, 3222, 111, 0, 3122,
- & 111, 0, 3222, -211, 0, 3112, 211, 0,
- & 3122, -211, 0, 3212, -211, 0, 2112, -311,
- & 0, 2212, -321, 0, 3222, -211, 0, 3212,
- & 111, 0, 3112, 211, 0, 3122, 221, 0,
- & 3224, -211, 0, 3114, 211, 0, 3214, 111/
- DATA (isec_linear(K),K= 609, 760) /
- & 0, 2112, -311, 0, 2212, -321, 0, 3122,
- & 111, 0, 3122, 223, 0, 3122, 113, 0,
- & 3222, -213, 0, 3112, 213, 0, 3212, 113,
- & 0, 3122, 221, 0, 3212, 221, 0, 3222,
- & -211, 0, 3112, 211, 0, 3212, 111, 0,
- & 3122, 111, 0, 3122, -211, 0, 3322, 111,
- & 0, 3312, 211, 0, 3322, -211, 0, 3312,
- & 111, 0, 3322, -211, 0, 3312, 111, 0,
- & 3122, -321, 0, 3222, 221, 0, 3222, 331,
- & 0, 2212, -311, 0, 3322, 321, 0, 3224,
- & 221, 0, 2214, 331, 0, 2224, -321, 0,
- & 3122, 213, 0, 3212, 213, 0, 3222, 113,
- & 0, 3222, 223, 0, 2212, -313, 0, 2214,
- & -313, 0, 2224, -323, 0, 4122, 211, 0,
- & 4122, 111, 0, 4122, -211, 0, 3222, -311,
- & 0, 3322, 211, 0, 3222, -313, 0, 3322,
- & 213, 0, 3212, -313, 0, 3222, -323, 0,
- & 3322, 223, 0, 3312, 213, 0, 3214, -313,
- & 0, 3322, -311, 0, 3322, 313, 0, 3334/
- DATA (isec_linear(K),K= 761, 765) /
- & 213, 0, 3334, 211, 0/
- DATA (wg_chan(K),K= 1, 114) /
- &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
- &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
- &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
- &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
- &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
- &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
- &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
- &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
- &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
- &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
- &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
- &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
- &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
- &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
- &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
- &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
- &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
- &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
- &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
- DATA (wg_chan(K),K= 115, 228) /
- &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
- &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
- &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
- &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
- &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
- &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
- &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
- &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
- &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
- &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
- &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
- &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
- &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
- &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
- &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
- &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
- &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
- &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
- &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
- DATA (wg_chan(K),K= 229, 255) /
- &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
- &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
- &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
- &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
- &2.0000E-01,3.6000E-01,7.0000E-02/
- DATA (id_psm_linear(K),K= 1, 36) /
- & 111, 211, -311, 411, 0, 0, -211, 111,
- & -321, 421, 0, 0, 311, 321, 221, 431,
- & 0, 0, -411, -421, -431, 441, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0/
- DATA (id_vem_linear(K),K= 1, 36) /
- & 113, 213, -313, 413, 0, 0, -213, 113,
- & -323, 423, 0, 0, 313, 323, 333, 433,
- & 0, 0, -413, -423, -433, 20443, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0/
- DATA (id_b8_linear(K),K= 1, 171) /
- & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
- & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
- & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
- & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
- & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
- & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
- & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
- & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
- & 4412, 4422, 4432, 4444, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (id_b8_linear(K),K= 172, 216) /
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (id_b10_linear(K),K= 1, 171) /
- & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
- & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
- & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
- & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
- & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
- & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
- & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
- & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
- & 4414, 4424, 4434, 4444, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (id_b10_linear(K),K= 172, 216) /
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0,
- & 0, 0, 0, 0, 0, 0, 0, 0, 0/
-
- ID_pdg_max = i_tab_max
-
-C copy from local to global variables
- do i=1,i_tab_max
- ID_pdg_list(i) = number(i)
- name_list(i) = name(i)
- xm_list(i) = xmass(i)
- gam_list(i) = gamma(i)
- ich3_list(i) = ich3(i)
- iba3_list(i) = iba3(i)
- do j=1,3
- iq_list(j,i) = iq_linear(3*(i-1)+j)
- idec_list(j,i) = idec_linear(3*(i-1)+j)
- enddo
- enddo
-
-C initialize hash table
- call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
-
- itmp = IDEB(71)
- IDEB(71) = -1
-
-C quark index table for mesons
- do i=1,6
- do j=1,6
- id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
- id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
- enddo
- enddo
-
-C quark index table for baryons
- do i=1,6
- do j=1,6
- do k=1,6
- id_b8_list(i,j,k) =
- & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
- id_b10_list(i,j,k) =
- & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
- enddo
- enddo
- enddo
-
- IDEB(71) = itmp
-
-C copy secondary particles
-C (translate PDG-ID to CPC and sort according to CPC)
- ichan = 0
- do i=1,i_tab_max
- if(idec_list(1,i).ne.0) then
- do j=idec_list(2,i),idec_list(3,i)
- ichan = ichan+1
- wg_sec_list(ichan) = wg_chan(j)
- do k=1,3
- if(isec_linear(3*(j-1)+k).ne.0) then
- isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
- else
- isec_list(k,ichan) = 0
- endif
- enddo
- enddo
- endif
- enddo
-
-C add two-pion background (low-mass photon dissociation)
- i = ipho_pdg2id(92)
- ichan = ichan+1
- idec_list(1,i) = 1
- idec_list(2,i) = ichan
- idec_list(3,i) = ichan
- wg_sec_list(ichan) = 1.D0
- isec_list(1,ichan) = ipho_pdg2id(211)
- isec_list(2,ichan) = ipho_pdg2id(-211)
- isec_list(3,ichan) = 0
-
-C min. mass limits for strings: q-qbar
- do i=1,6
- do j=1,6
- AM2P = 1000.D0
- AM2V = 1000.D0
- do k=1,3
-C pseudo-scalar mesons
- i1 = iabs(id_psm_list(i,k))
- if(i1.ne.0) then
- AM1 = xm_list(i1)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(k,3)
- endif
- i2 = iabs(id_psm_list(k,j))
- if(i2.ne.0) then
- AM2 = xm_list(i2)
- else
- AM2 = pho_pmass(k,3)+pho_pmass(j,3)
- endif
- AM2P = MIN(AM2P,AM1+AM2)
-C vector mesons
- i1 = iabs(id_vem_list(i,k))
- if(i1.ne.0) then
- AM1 = xm_list(i1)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(k,3)
- endif
- i2 = iabs(id_vem_list(k,j))
- if(i2.ne.0) then
- AM2 = xm_list(i2)
- else
- AM2 = pho_pmass(k,3)+pho_pmass(j,3)
- endif
- AM2V = MIN(AM2V,AM1+AM2)
- enddo
- xm_psm2_list(i,j) = AM2P
- xm_vem2_list(i,j) = AM2V
- enddo
- enddo
-
-C min. mass limits for strings: qq-q
- do i=1,6
- do j=1,6
- do k=1,6
- AM82 = 1000.D0
- AM102 = 1000.D0
- do l=1,3
-C pseudo-scalar meson
- i1 = iabs(id_psm_list(k,l))
- if(i1.ne.0) then
- AM1 = xm_list(i1)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(k,3)
- endif
-C vector meson
- i2 = iabs(id_vem_list(k,l))
- if(i2.ne.0) then
- AM2 = xm_list(i2)
- else
- AM2 = pho_pmass(i,3)+pho_pmass(k,3)
- endif
-C octet baryon
- AMM = min(AM1,AM2)
- K8 = id_b8_list(i,j,l)
- if(K8.ne.0) then
- AM1 = xm_list(K8)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
- endif
- AM82 = MIN(AM82, AM1 + AMM)
-C decuplet baryon
- K10 = id_b10_list(i,j,l)
- if(K10.ne.0) then
- AM2 = xm_list(K10)
- else
- AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
- endif
- AM102 = MIN(AM102, AM2 + AMM)
- enddo
- xm_b82_list(i,j,k) = AM82
- xm_b102_list(i,j,k) = AM102
- enddo
- enddo
- enddo
-
-C min. mass limits for strings: qq-qbarqbar
- do i=1,6
- do j=1,6
- do ii=1,6
- do jj=1,6
- AM82 = 1000.D0
- AM102 = 1000.D0
- do l=1,3
-C octet baryons
- K8 = id_b8_list(i,j,l)
- if(K8.ne.0) then
- AM1 = xm_list(K8)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
- endif
- L8 = id_b8_list(ii,jj,l)
- if(L8.ne.0) then
- AM2 = xm_list(L8)
- else
- AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
- endif
- AM82 = MIN(AM82, AM1+AM2)
-C decuplet baryons
- K10 = id_b10_list(i,j,l)
- if(K10.ne.0) then
- AM1 = xm_list(K10)
- else
- AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
- endif
- L10 = id_b10_list(ii,jj,l)
- if(L10.ne.0) then
- AM2 = xm_list(L10)
- else
- AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
- endif
- AM102 = MIN(AM102, AM1+AM2)
- enddo
- xm_bb82_list(i,j,ii,jj) = AM82
- xm_bb102_list(i,j,ii,jj) = AM102
- enddo
- enddo
- enddo
- enddo
-
- END
-
-CDECK ID>, PHO_PRESEL
- SUBROUTINE PHO_PRESEL(MODE,IREJ)
-C**********************************************************************
-C
-C user specific function to pre-select events during generation
-C
-C input: MODE 5 electron and photon kinematics
-C 10 process and number of cut Pomerons
-C 15 partons without construction of strings
-C 20 partons assigned to strings
-C 25 after fragmentation, complete final state
-C
-C output: IREJ 0 event accepted
-C 50 event rejected
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- IREJ = 0
-
-* XBJ = GQ2(2)/(GGECM**2+GQ2(2))
-* IF(XBJ.LT.0.002D0) IREJ = 1
-
- END
-
-CDECK ID>, PHO_FIXCOL
- SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
-C**********************************************************************
-C
-C interface to call PHOJET (fixed energy run) with
-C collider kinematics
-C
-C equivalen photon approximation to get photon flux
-C
-C input: NEV number of events to generate
-C THETA azimuthal angle (micro radians)
-C PHI beam crossing angle
-C (with respect to x, in degrees)
-C E1 energy of particle 1 (+z direction, GeV)
-C E2 energy of particle 2 (-z direction, GeV)
-C
-C note: particle types have to be specified before
-C with PHO_SETPAR
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4)
-
-C remnant initialization (only needed for DPMJET)
- ISAVP1 = IFPAP(1)
- ISAVB1 = IFPAB(1)
- IF(IFPAP(1).EQ.81) THEN
- IFPAP(1) = IDEQP(1)
- IFPAB(1) = IDEQB(1)
- ENDIF
- ISAVP2 = IFPAP(2)
- ISAVB2 = IFPAB(2)
- IF(IFPAP(2).EQ.82) THEN
- IFPAP(2) = IDEQP(2)
- IFPAB(2) = IDEQB(2)
- ENDIF
- PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
- PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
- PP1 = SQRT(E1**2-PMASS1**2)
- PP2 = SQRT(E2**2-PMASS2**2)
-C beam crossing angle
- TH = 1.D-6*THETA/2.D0
- PH = PHI*BOG
- P1(1) = PP1*SIN(TH)*COS(PH)
- P1(2) = PP1*SIN(TH)*SIN(PH)
- P1(3) = PP1*COS(TH)
- P1(4) = E1
- P2(1) = PP2*SIN(TH)*COS(PH)
- P2(2) = PP2*SIN(TH)*SIN(PH)
- P2(3) = -PP2*COS(TH)
- P2(4) = E2
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- IFPAP(1) = ISAVP1
- IFPAB(1) = ISAVB1
- IFPAP(2) = ISAVP2
- IFPAB(2) = ISAVB2
- ITRY = 0
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C test of DPMJET interface (default is IPAMDL(13)=0)
- if(IPAMDL(13).gt.0) then
- MODE = IPAMDL(13)
- IPAMDL(13) = 0
- else
- MODE = 1
- endif
-C main generation loop
- DO 50 I=1,NEV
- 55 CONTINUE
- ITRY = ITRY+1
- CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 55
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 50 CONTINUE
-
- IF(NEV.GT.0) THEN
- SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- & '=========================================================',
- & ' ***** simulated cross section: ',SIGMAX,' mb *****',
- & '========================================================='
- CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
- CALL PHO_PHIST(-2,SIGMAX)
- CALL PHO_LHIST(-2,SIGMAX)
- ELSE
- WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
- ENDIF
-
- END
-
-CDECK ID>, PHO_FIXLAB
- SUBROUTINE PHO_FIXLAB(PLAB,NEV)
-C**********************************************************************
-C
-C interface to call PHOJET (fixed energy run) with
-C LAB kinematics (second particle as target)
-C
-C equivalent photon approximation to get photon flux
-C
-C input: NEV number of events to generate
-C PLAB LAB momentum of particle 1
-C
-C note: particle types have to be specified before
-C with PHO_SETPAR
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4)
-
-C remnant initialization (only needed for DPMJET)
- SPCM = PLAB
- ISAVP1 = IFPAP(1)
- ISAVB1 = IFPAB(1)
- IF(IFPAP(1).EQ.81) THEN
- IFPAP(1) = IDEQP(1)
- IFPAB(1) = IDEQB(1)
- ENDIF
- ISAVP2 = IFPAP(2)
- ISAVB2 = IFPAB(2)
- IF(IFPAP(2).EQ.82) THEN
- IFPAP(2) = IDEQP(2)
- IFPAB(2) = IDEQB(2)
- ENDIF
-C get momenta in LAB system
- PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
- PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
- IF(PMASS2.LT.0.1D0) THEN
- WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
- & 'no LAB system possible',IFPAB(1),IFPAB(2)
- ELSE
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = PLAB
- P1(4) = SQRT(PMASS1+PLAB**2)
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = 0.D0
- P2(4) = SQRT(PMASS2)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- IFPAP(1) = ISAVP1
- IFPAB(1) = ISAVB1
- IFPAP(2) = ISAVP2
- IFPAB(2) = ISAVB2
- ITRY = 0
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C event generation loop
- DO 40 I=1,NEV
- 45 CONTINUE
- ITRY = ITRY+1
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 45
- CALL PHO_LHIST(1,HSWGHT(0))
-
- CALL PHO_PHIST(10,HSWGHT(0))
-
- 40 CONTINUE
- IF(NEV.GT.0) THEN
- SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- & '=========================================================',
- & ' ***** simulated cross section: ',SIGMAX,' mb *****',
- & '========================================================='
- CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
- CALL PHO_PHIST(-2,SIGMAX)
- CALL PHO_LHIST(-2,SIGMAX)
- ELSE
- WRITE(LO,'(1X,A,I5)')
- & 'PHO_FIXLAB: no events simulated',NEV
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_GPHERA
- SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) with
-C HERA kinematics, photon as particle 2
-C
-C equivalent photon approximation to get photon flux
-C
-C input: NEVENT number of events to generate
-C EE1 proton energy (LAB system)
-C EE2 electron energy (LAB system)
-C from /POFCUT/:
-C YMIN2 lower limit of Y
-C (energy fraction taken by photon from electron)
-C YMAX2 upper limit of Y
-C Q2MIN2 lower limit of photon virtuality
-C Q2MAX2 upper limit of photon virtuality
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-10,
- & PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4)
-
- WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
-C assign particle momenta according to HERA kinematics
-C proton data
- PROM = PHO_PMASS(2212,1)
- PROM2 = PROM**2
- IDPSRC(1) = 0
- IDBSRC(1) = 0
-C electron data
- ELEM = 0.512D-03
- ELEM2 = ELEM**2
- AMSRC(2) = ELEM
- IDPSRC(2) = 11
- IDBSRC(2) = ipho_pdg2id(11)
-C
- Q2MIN = Q2MIN2
- Q2MAX = Q2MAX2
-C
- XIMAX = LOG(YMAX2)
- XIMIN = LOG(YMIN2)
- XIDEL = XIMAX-XIMIN
-C
- IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
- & WRITE(LO,'(/1X,A,1P2E11.4)')
- & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
- & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
-C
- Max_tab = 50
- DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
- FLUXT = 0.D0
- FLUXL = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
- & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
- DO 100 I=1,Max_tab
- Y = EXP(XIMIN+DELLY*DBLE(I-1))
- Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
- FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
- & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
- FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
- FLUXT = FLUXT + Y*FFT
- FLUXL = FLUXL + Y*FFL
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
- 100 CONTINUE
- FLUXT = FLUXT*DELLY
- FLUXL = FLUXL*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
- & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
-C
- AY = 0.D0
- AY2 = 0.D0
- YY = YMIN2
- Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
- WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
- & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
- IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
-C
-C initialization of PHOJET at upper energy limit
-C proton momentum
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = SQRT(EE1**2-PROM2+DEPS)
- P1(4) = EE1
-C photon momentum
- EGAM = YMAX2*EE2
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -EGAM
- P2(4) = EGAM
-C sum of both photon polarizations
- IGHEL(2) = -1
-C
- CALL PHO_SETPAR(1,2212,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C
-C generation of events, flux calculation
-
- ECMIN2 = ECMIN**2
- ECMAX2 = ECMAX**2
- AY = 0.D0
- AY2 = 0.D0
- Q22MIN = 1.D30
- Q22AVE = 0.D0
- Q22AV2 = 0.D0
- Q22MAX = 0.D0
- AN2MIN = 1.D30
- AN2MAX = 0.D0
- YY2MIN = 1.D30
- YY2MAX = 0.D0
- NITER = NEVENT
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
- 150 CONTINUE
-C sample y
- ITRY = ITRY+1
- 175 CONTINUE
- ITRW = ITRW+1
- YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
- IF(ISWMDL(10).GE.2) THEN
- YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
- ELSE
- YEFF = 1.D0+(1.D0-YY)**2
- ENDIF
- Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
- Q2LOG = LOG(Q2MAX/Q2LOW)
- WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
- IF(WGMAX.LT.WGH) THEN
- WRITE(LO,'(1X,A,3E12.5)')
- & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
- ENDIF
- IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- 185 CONTINUE
- Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
- WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
- ELSE
- Q2 = Q2LOW
- ENDIF
-C
-
-C incoming electron
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE2
- PINI(4,2) = EE2
- PINI(5,2) = 0.D0
-C outgoing electron
- YQ2 = SQRT((1.D0-YY)*Q2)
- Q2E = Q2/(4.D0*EE2)
- E1Y = EE2*(1.D0-YY)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
-C set /POFSRC/
- GYY(2) = YY
- GQ2(2) = Q2
-C polar angle
- PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
-C electron tagger
- IF(PFIN(4,2).GT.EEMIN2) THEN
- IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
- ENDIF
-C azimuthal angle
- PFPHI(2) = ATAN2(COF,SIF)
-C photon momentum
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
-C proton momentum
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = SQRT(EE1**2-PROM2)
- P1(4) = EE1
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
- GGECM = SQRT(GGECM)
-C
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = -SQRT(Q2)
-C photon helicity
- IF(ISWMDL(10).GE.2) THEN
- WGH = YEFF-2.D0*ELEM2*YY**2/Q2
- WGHL = 2.D0*(1-YY)
- IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
- IGHEL(2) = 1
- ELSE
- IGHEL(2) = 0
- ENDIF
- ELSE
- IGHEL(2) = -1
- ENDIF
-C user cuts
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-
-C statistics
- AY = AY+YY
- AY2 = AY2+YY*YY
- YY2MIN = MIN(YY2MIN,YY)
- YY2MAX = MAX(YY2MAX,YY)
- Q22MIN = MIN(Q22MIN,Q2)
- Q22MAX = MAX(Q22MAX,Q2)
- Q22AVE = Q22AVE+Q2
- Q22AV2 = Q22AV2+Q2*Q2
- AN2MIN = MIN(AN2MIN,PFTHE(2))
- AN2MAX = MAX(AN2MAX,PFTHE(2))
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
- WGY = WGY*LOG(YMAX2/YMIN2)
- AY = AY/DBLE(NITER)
- AY2 = AY2/DBLE(NITER)
- DAY = SQRT((AY2-AY**2)/DBLE(NITER))
- Q22AVE = Q22AVE/DBLE(NITER)
- Q22AV2 = Q22AV2/DBLE(NITER)
- Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,3I10)')
- & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
- & YY2MIN,YY2MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
- & Q22AVE,Q22AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
- & Q22MIN,Q22MAX
- WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
- & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGEPEM
- SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-gamma collisions on e+e- collider
-C
-C fully differential equivalent (improved) photon approximation
-C to get photon flux
-C
-C input: EE1 LAB system energy of electron/positron 1
-C EE2 LAB system energy of electron/positron 2
-C NEVENT >0 number of events to generate
-C -1 initialization
-C -2 final call (cross section calculation)
-C from /LEPCUT/:
-C YMIN1 lower limit of Y1
-C (energy fraction taken by photon from electron)
-C YMAX1 upper limit of Y1
-C Q2MIN1 lower limit of photon virtuality
-C Q2MAX1 upper limit of photon virtuality
-C THMIN1 lower limit of scattered electron
-C THMAX1 upper limit of scattered electron
-C YMIN2 lower limit of Y2
-C (energy fraction taken by photon from electron)
-C YMAX2 upper limit of Y2
-C Q2MIN2 lower limit of photon virtuality
-C Q2MAX2 upper limit of photon virtuality
-C THMIN2 lower limit of scattered electron
-C THMAX2 upper limit of scattered electron
-C
-C output: after final call with NEVENT=-2
-C EE1 e+ e- cross section (mb)
-C EE2 gamma-gamma cross section (mb)
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- DOUBLE PRECISION EE1,EE2
- INTEGER NEVENT
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
-C external functions
- DOUBLE PRECISION DT_RNDM
-
-C local variables
- DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
- & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
- & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
- & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
- & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
- & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
- & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
- & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
- & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
-
- INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
- & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
-
- DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
- integer ipho_pdg2id
-
-C initialization of event generation
-
- if(NEVENT.eq.-1) then
-
- DO 10 I=1,4
- IHETRY(I) = 0
- IHEAC1(I) = 0
- IHEAC2(I) = 0
- 10 CONTINUE
-
- WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
-
-C electron data
- ELEM = 0.512D-03
- ELEM2 = ELEM**2
- AMSRC(1) = ELEM
- AMSRC(2) = ELEM
-C lepton numbers
- IDPSRC(1) = 11
- IDPSRC(2) = -11
- IDBSRC(1) = ipho_pdg2id(11)
- IDBSRC(2) = ipho_pdg2id(-11)
-
-C check/update kinematic limitations
-
- Ymi = min(Ymax1,1.D0-ELEM/EE1)
- if(Ymi.lt.Ymax1) then
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
- Ymax1 = YMI
- endif
- Ymi = min(Ymax2,1.D0-ELEM/EE2)
- if(Ymi.lt.Ymax2) then
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
- Ymax2 = YMI
- endif
-
- YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
- IF(YMIN1.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
- YMIN1 = YMI
- ELSE IF(YMIN1.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
- & ' INSTEAD OF',YMIN1
- ENDIF
- YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
- IF(YMIN2.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
- YMIN2 = YMI
- ELSE IF(YMIN2.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
- & ' INSTEAD OF',YMIN2
- ENDIF
-
-C store COS of angular tagging range
- THMIC1 = COS(MAX(0.D0,THMIN1))
- THMAC1 = COS(MIN(THMAX1,PI))
- THMIC2 = COS(MAX(0.D0,THMIN2))
- THMAC2 = COS(MIN(THMAX2,PI))
-
- X1MAX = LOG(YMAX1)
- X1MIN = LOG(YMIN1)
- X1DEL = X1MAX-X1MIN
- X2MAX = LOG(YMAX2)
- X2MIN = LOG(YMIN2)
- X2DEL = X2MAX-X2MIN
-
-C debug: integrated photon flux
-
- if(IDEB(30).ge.1) then
- Max_tab = 50
- FLUXT = 0.D0
- FLUXL = 0.D0
- DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
- IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
- & 'table of photon flux (trans/long side 1)',Max_tab
- do I=1,Max_tab
- Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
- if((1.D0-Y1).gt.1.D-8) then
- Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
- else
- Q2low1 = 2.D0*Q2max1
- endif
- if(Q2low1.lt.Q2max1) then
- FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
- FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
- else
- FFT = 0.D0
- FFL = 0.D0
- endif
- FLUXT = FLUXT + Y1*FFL
- FLUXL = FLUXL + Y1*FFT
- IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
- enddo
- FLUXT = FLUXT*DELLY
- FLUXL = FLUXL*DELLY
- WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
- & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
- endif
-
-C maximum weight
-
- Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
- Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
- Y1 = YMIN1
- Y2 = YMIN2
- IF(ISWMDL(10).GE.2) THEN
-C long. and transversely polarized photons
- WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
- & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
- ELSE
-C transversely polarized photons only
- WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
- & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
- ENDIF
-
-C initialize gamma-gamma event generator
-
-C photon 1
- EGAM = YMAX1*EE1
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = SQRT(EGAM**2-Q2LOW1)
- P1(4) = EGAM
-C photon 2
- EGAM = YMAX2*EE2
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -SQRT(EGAM**2-Q2LOW2)
- P2(4) = EGAM
-C sum of helicities
- IGHEL(1) = -1
- IGHEL(2) = -1
-
-C set min. energy for interpolation tables
- parmdl(19) = min(parmdl(19),ecmin)
-
-C initialize event gneration
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-
-C generation of events, flux calculation
-
- ECMIN2 = ECMIN**2
- ECMAX2 = ECMAX**2
- ECFRAC = ECMIN2/(4.D0*EE1*EE2)
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- Q21MIN = 1.D30
- Q22MIN = 1.D30
- Q21MAX = 0.D0
- Q22MAX = 0.D0
- Q21AVE = 0.D0
- Q22AVE = 0.D0
- Q21AV2 = 0.D0
- Q22AV2 = 0.D0
- AN1MIN = 1.D30
- AN2MIN = 1.D30
- AN1MAX = 0.D0
- AN2MAX = 0.D0
- YY1MIN = 1.D30
- YY2MIN = 1.D30
- YY1MAX = 0.D0
- YY2MAX = 0.D0
- NITER = 0
- ITRY_low = 0
- ITRY_high = 0
- ITRW_low = 0
- ITRW_high = 0
-
-C generate NEVENT events (might be just 1 per call)
-
- else if(NEVENT.gt.0) then
-
- NITER = NITER+NEVENT
-
- DO 200 I=1,NEVENT
-
-C sample y1, y2
- 150 CONTINUE
- ITRY_low = ITRY_low+1
- if(ITRY_low.eq.1000000) then
- ITRY_low = 0
- ITRY_high = ITRY_high+1
- endif
-
- 175 CONTINUE
- ITRW_low = ITRW_low+1
- if(ITRW_low.eq.1000000) then
- ITRW_low = 0
- ITRW_high = ITRW_high+1
- endif
-
- Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
- Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
- IF(Y1*Y2.LT.ECFRAC) GOTO 175
- IF(ISWMDL(10).GE.2) THEN
- YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
- YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
- ELSE
- YEFF1 = 1.D0+(1.D0-Y1)**2
- YEFF2 = 1.D0+(1.D0-Y2)**2
- ENDIF
-
- Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
- Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
- Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
- Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
- WGH = (YEFF1*Q2LOG1
- & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
- & *(YEFF2*Q2LOG2
- & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
- IF(WGMAX.LT.WGH) THEN
- WRITE(LO,'(1X,A,4E12.5)')
- & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
- ENDIF
- IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
-
-C limit on Ecm_gg (app. cut, precise cut applied later)
- GGECM2 = 4.D0*Y1*Y2*EE1*EE2
- if(GGECM2.lt.ECMIN2) goto 175
-
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- 185 CONTINUE
- Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
- WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
- IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
- ELSE
- Q2P1 = Q2LOW1
- ENDIF
-
- IF(IPAMDL(174).EQ.1) THEN
- 186 CONTINUE
- Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
- WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
- IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
- ELSE
- Q2P2 = Q2LOW2
- ENDIF
-
- GYY(1) = Y1
- GQ2(1) = Q2P1
- GYY(2) = Y2
- GQ2(2) = Q2P2
-
-C incoming electron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
- PINI(4,1) = EE1
- PINI(5,1) = ELEM
-C photon 1
- PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
- PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
- & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
- IF(PT2.LT.0.D0) GOTO 175
- PT = SQRT(PT2)
- CALL PHO_SFECFE(SIF1,COF1)
- P1(1) = COF1*PT
- P1(2) = SIF1*PT
- P1(3) = PP
- P1(4) = EE1*Y1
-C outgoing electron 1
- PFIN(1,1) = -P1(1)
- PFIN(2,1) = -P1(2)
- PFIN(3,1) = PINI(3,1)-P1(3)
- PFIN(4,1) = PINI(4,1)-P1(4)
- PFIN(5,1) = ELEM
-C incoming electron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
- PINI(4,2) = EE2
- PINI(5,2) = 0.D0
-C photon 2
- PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
- PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
- & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
- IF(PT2.LT.0.D0) GOTO 175
- PT = SQRT(PT2)
- CALL PHO_SFECFE(SIF2,COF2)
- P2(1) = COF2*PT
- P2(2) = SIF2*PT
- P2(3) = PP
- P2(4) = EE2*Y2
-C outgoing electron 2
- PFIN(1,2) = -P2(1)
- PFIN(2,2) = -P2(2)
- PFIN(3,2) = PINI(3,2)-P2(3)
- PFIN(4,2) = PINI(4,2)-P2(4)
- PFIN(5,2) = ELEM
-
-C precise ECMS cut
-
- GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
- GGECM = SQRT(GGECM2)
-
-C beam lepton detector acceptance
-
-C lepton tagger 1
- CPFTHE = PFIN(3,1)/PFIN(4,1)
- ITG1 = 0
- IF(PFIN(4,1).GE.EEMIN1) THEN
- IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
- ENDIF
-
-C lepton tagger 2
- CPFTHE = PFIN(3,2)/PFIN(4,2)
- ITG2 = 0
- IF(PFIN(4,2).GE.EEMIN2) THEN
- IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
- ENDIF
-
-C beam lepton taggers
-
-C anti-tag
- IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
- IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
-C tag
- IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
- IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
-C single-tag inclusive
- IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
- & GOTO 175
-C single-tag/anti-tag
- IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
- & GOTO 175
-
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = -SQRT(Q2P1)
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = -SQRT(Q2P2)
-
-C photon helicities
- IF(ISWMDL(10).GE.2) THEN
- WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
- WGHL = 2.D0*(1-Y1)
- IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
- IGHEL(1) = 1
- ELSE
- IGHEL(1) = 0
- ENDIF
- WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
- WGHL = 2.D0*(1-Y2)
- IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
- IGHEL(2) = 1
- ELSE
- IGHEL(2) = 0
- ENDIF
- K = 2*IGHEL(1)+IGHEL(2)+1
- IHETRY(K) = IHETRY(K)+1
- ELSE
- IGHEL(1) = -1
- IGHEL(2) = -1
- ENDIF
-
-C user cuts
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-
- WGFX = 1.D0
-C reweight according to LO photon emission diagrams (Budnev et al.)
- IF(IPAMDL(116).GE.1) THEN
- CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
- WGFX = FLXQPM/FLXAPP
- if(WGFX.gt.1.D0) then
- WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
- & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
- & Y1,Y2,Q2P1,Q2P2,GGECM
- endif
- ENDIF
-
-C event generation
-* IVWGHT(1) = 1
-* EVWGHT(1) = MAX(WGFX,1.D0)
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
- IF(ISWMDL(10).GE.2) THEN
- K = 2*IGHEL(1)+IGHEL(2)+1
- IHEAC1(K) = IHEAC1(K)+1
- ENDIF
-
-C reweight according to QPM model (e+e- collider only)
- IF((KHDIR.GT.0).AND.
- & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
- CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
- WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
- IF(DT_RNDM(WG).GT.WG) GOTO 150
- ELSE IF(IPAMDL(116).GE.1) THEN
- IF(DT_RNDM(WG).GT.WGFX) GOTO 150
- ENDIF
-
-C polar angle
- PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
- PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
-C azimuthal angle
- PFPHI(1) = ATAN2(COF1,SIF1)
- PFPHI(2) = ATAN2(COF2,SIF2)
-
-C statistics
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
- Q21MIN = MIN(Q21MIN,Q2P1)
- Q22MIN = MIN(Q22MIN,Q2P2)
- Q21MAX = MAX(Q21MAX,Q2P1)
- Q22MAX = MAX(Q22MAX,Q2P2)
- AN1MIN = MIN(AN1MIN,PFTHE(1))
- AN2MIN = MIN(AN2MIN,PFTHE(2))
- AN1MAX = MAX(AN1MAX,PFTHE(1))
- AN2MAX = MAX(AN2MAX,PFTHE(2))
- YY1MIN = MIN(YY1MIN,Y1)
- YY2MIN = MIN(YY2MIN,Y2)
- YY1MAX = MAX(YY1MAX,Y1)
- YY2MAX = MAX(YY2MAX,Y2)
- Q21AVE = Q21AVE+Q2P1
- Q22AVE = Q22AVE+Q2P2
- Q21AV2 = Q21AV2+Q2P1*Q2P1
- Q22AV2 = Q22AV2+Q2P2*Q2P2
- IF(ISWMDL(10).GE.2) THEN
- K = 2*IGHEL(1)+IGHEL(2)+1
- IHEAC2(K) = IHEAC2(K)+1
- ENDIF
-
-C external histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-
-C final cross section calculation and event generation summary
-
- else if(NEVENT.eq.-2) then
-
-* EVWGHT(1) = 1.D0
-* IVWGHT(1) = 0
- DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
- DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
- WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
- WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
- AY1 = AY1/DBLE(NITER)
- AYS1 = AYS1/DBLE(NITER)
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
- AY2 = AY2/DBLE(NITER)
- AYS2 = AYS2/DBLE(NITER)
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
- Q21AVE = Q21AVE/DBLE(NITER)
- Q21AV2 = Q21AV2/DBLE(NITER)
- Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
- Q22AVE = Q22AVE/DBLE(NITER)
- Q22AV2 = Q22AV2/DBLE(NITER)
- Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
- EE1 = WEIGHT
- EE2 = SIGMAX*DBLE(NITER)/DITRY
-
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- & '=========================================================',
- & ' ***** simulated cross section: ',WEIGHT,' mb *****',
- & '========================================================='
- WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
- & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
- & AY1,DAY1
- WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
- & AY2,DAY2
- WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
- & YY1MIN,YY1MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
- & YY2MIN,YY2MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
- & Q21AVE,Q21AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
- & Q21MIN,Q21MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
- & Q22AVE,Q22AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
- & Q22MIN,Q22MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
- & AN1MIN,AN1MAX
- WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
- & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
-
- IF(ISWMDL(10).GE.2) THEN
- WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
- & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
- & 'tried: ',IHETRY,
- & 'accepted (1): ',IHEAC1,
- & 'accepted (2): ',IHEAC2
- ENDIF
-
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)')
- & 'PHO_GGEPEM: no output of histograms',NITER
- ENDIF
-
- endif
-
- END
-
-CDECK ID>, PHO_WGEPEM
- SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
-C**********************************************************************
-C
-C calculate cross section weights for
-C fully differential equivalent (improved) photon approximation
-C and/or
-C fully differential QPM model with exact one-photon exchange graphs
-C
-C (unpolarized lepton beams)
-C
-C input: IMODE 0 flux calculation only
-C 1 flux folded with QPM cross section
-C /POFSRC/ photon and electron momenta
-C /POPRCS/ process type
-C /POCKIN/ kinematics of hard scattering
-C
-C output: WGHAPP weight of event according to approximation
-C WGHQPM weight of event according to one-photon exchange
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- DOUBLE PRECISION WGHAPP,WGHQPM
- INTEGER IMODE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
- & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
- & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
- & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
- & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
- & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
- DOUBLE PRECISION PHO_ALPHAS,pho_alphae
-
- INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
-
- DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
- DIMENSION HELFLX(6),SIGQPM(6)
-
- WGHAPP = 1.D0
- WGHQPM = 0.D0
-
-C strict pt cutoff after putting partons on mass shell,
-C calculated in gamma-gamma CMS
- if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
- if(PTfin.lt.PTwant) then
- if(ipamdl(121).gt.1) return
- if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
- endif
- endif
-
-C cross section of sampled event (approximate treatment)
-
-C photon flux
- DO 50 K=1,2
- XM2(K) = AMSRC(K)**2
- IF(abs(IGHEL(K)).EQ.1) THEN
- WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
- & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
- ELSE
- WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
- ENDIF
- 50 CONTINUE
-
- W2 = GGECM*GGECM
- IDIR = 0
- WGHQQ = 1.D0
-
-C direct or single-resolved gam-gam interaction
- IF((IMODE.GE.1).AND.
- & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
- IDIR = 1
- WGHQQ = 0.D0
-C determine final state partons
- DO 100 I=3,NHEP
- IF(ISTHEP(I).EQ.25) GOTO 110
- 100 CONTINUE
- WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
- & 'inconsistent process information (MSPR)',MSPR
- CALL PHO_ABORT
- 110 CONTINUE
- IPOS = I
-C final state flavors
- IPFL1 = ABS(IDHEP(IPOS+3))
- IPFL2 = ABS(IDHEP(IPOS+4))
- SH = X1*X2*W2
-C calculate alpha-em
- ALPHA1 = pho_alphae(QQAL)
-C calculate alpha-s
- IF(MSPR.LT.14) THEN
- ALPHA2 = PHO_ALPHAS(QQAL,3)
- ENDIF
-C LO matrix element (8 pi s dsig/dt)
-* QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
- QC2 = Q_ch2(IPFL2)
- IF(IPFL2.EQ.0) THEN
- WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
- & 'invalid hard process - flavor combination',
- & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
- ENDIF
- IF(MSPR.EQ.10) THEN
- WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
- & *8.D0*PI*SH
- ELSE IF(MSPR.EQ.11) THEN
- WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
- & *8.D0*PI*SH
- ELSE IF(MSPR.EQ.12) THEN
- WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
- & *8.D0*PI*SH
- ELSE IF(MSPR.EQ.13) THEN
- WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
- & *8.D0*PI*SH
- ELSE IF(MSPR.EQ.14) THEN
- WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
- & *8.D0*PI*SH
- ENDIF
- ENDIF
-
-C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
- WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
-
-C full leading-order QPM prediction (Budnev et al.)
-
-C full two-gamma flux
-
- P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
- & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
- P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
- & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
- Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
- & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
- P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
- & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
- DO 120 I=1,4
- P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
- P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
- 120 CONTINUE
- XTM1 = 2.D0*P1Q2-Q1Q2
- XTM2 = 2.D0*P2Q1-Q1Q2
- XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
- XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
- YCAP = P1P2**2-XM2(1)*XM2(2)
- CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
-
- RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
- RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
- RHO100 = XTM1**2/XCAP-1.D0
- RHO200 = XTM2**2/XCAP-1.D0
- RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
- RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
- SS = 2.D0*P1P2+XM2(1)+XM2(2)
-
- HELFLX(1) = 4.D0*RHO1PP*RHO2PP
- HELFLX(2) = RHOPM2
- HELFLX(3) = 2.D0*RHO1PP*RHO200
- HELFLX(4) = 2.D0*RHO100*RHO2PP
- HELFLX(5) = RHO100*RHO200
- HELFLX(6) = -RHOP08
-
-C only flux calculation
-
- IF(IDIR.EQ.0) THEN
- IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
- WEIGHT = HELFLX(1)
- ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
- WEIGHT = HELFLX(3)
- ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
- WEIGHT = HELFLX(4)
- ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
- WEIGHT = HELFLX(5)
- ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
- WEIGHT = HELFLX(1)
- ELSE
- WRITE(LO,'(/1X,A,2I3)')
- & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
- WRITE(LO,'(1X,A,I12)')
- & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
- WEIGHT = 0.D0
- ENDIF
-
-C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
- WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
- & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
-
- ELSE
-
-C flux folded with cross section
-C polarized, leading order gam gam --> q qbar cross sections
-
- DO 125 I=1,6
- SIGQPM(I) = 0.D0
- 125 CONTINUE
-C momenta of produced parton pair
- I1 = IPOS+3
- I2 = IPOS+4
- DO 150 K=1,4
- XK1(K) = PHEP(K,I1)
- XK2(K) = PHEP(K,I2)
- 150 CONTINUE
- XQ2 = PHEP(5,I2)**2
-
- IF(MSPR.EQ.14) THEN
-C direct photon-photon interaction
- XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
- & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
- & +(PGAM(3,1)-XK1(3))**2
- XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
- & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
- & +(PGAM(3,1)-XK2(3))**2
- CC = Q1Q2
- AA = XKAP*XKAM-GQ2(1)*GQ2(2)
- BB = CC**2-XKAP*XKAM
- DD = CC**2-GQ2(1)*GQ2(2)
- RR = -XQ2+W2*AA/(4.D0*DD)
- Q1KK = Q1Q2-GQ2(1)
- Q2KK = Q1Q2-GQ2(2)
- FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
-
- ELSE
-C single-resolved photon-hadron interactions
-C Mandelstam variables
- IF(MSPR.LE.11) THEN
- TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
- & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
- UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
- & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
- ELSE
- TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
- & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
- UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
- & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
- ENDIF
- V = TH/SH
- U = UH/SH
- ENDIF
-
- WEIGHT = 0.D0
- IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
- IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
- IF(MSPR.EQ.10) THEN
- Q2 = -GQ2(1)
- SP = SH-XQ2
- TP = UH-XQ2
- ELSE
- Q2 = -GQ2(2)
- SP = SH-XQ2
- TP = TH-XQ2
- ENDIF
- SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
- & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
- & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
- & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
- & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
- & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
- & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
- & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
- WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
- ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
- IF(MSPR.EQ.11) THEN
- Q2 = -GQ2(1)
- ELSE
- Q2 = -GQ2(2)
- ENDIF
- SP = SH
- TP = UH
- SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
- & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
- & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
- & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
- & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
- & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
- & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
- & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
- & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
- & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
- & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
- & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
- & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
- & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
- & (Q2-SP-TP+XQ2)**2)
- WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
- ELSE IF(MSPR.EQ.14) THEN
- SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
- SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
- SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
- & -2.D0*XKAP*XKAM*AA
- SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
- SIGQPM(2) = SWPPMM*FAC
- WEIGHT = HELFLX(1)*SIGQPM(1)
- & +HELFLX(2)*SIGQPM(2)
- ENDIF
- ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
- IF(MSPR.EQ.12) THEN
- Q2 = -GQ2(2)
- SP = SH-XQ2
- TP = TH-XQ2
- SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
- & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
- & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
- & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
- & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
- & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
- & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
- & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
- WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
- ELSE IF(MSPR.EQ.13) THEN
- Q2 = -GQ2(2)
- SP = SH
- TP = TH
- SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
- & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
- & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
- WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
- ELSE IF(MSPR.EQ.14) THEN
- SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
- & -XKAP*XKAM*Q1KK**2)/DD
- SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
- SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
- & *SQRT(GQ2(1)*GQ2(2))/DD
- SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
- & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
- SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
- & *SQRT(GQ2(1)*GQ2(2))/DD
- SIGQPM(3) = SWP0P0*FAC
- SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
- WEIGHT = HELFLX(3)*SIGQPM(3)
- & +HELFLX(6)*SIGQPM(6)/2.D0
- ENDIF
- ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
- IF(MSPR.EQ.10) THEN
- Q2 = -GQ2(1)
- SP = SH-XQ2
- TP = UH-XQ2
- SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
- & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
- & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
- & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
- & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
- & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
- & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
- & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
- WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
- ELSE IF(MSPR.EQ.11) THEN
- Q2 = -GQ2(1)
- SP = SH
- TP = TH
- SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
- & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
- & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
- WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
- ELSE IF(MSPR.EQ.14) THEN
- SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
- & -XKAP*XKAM*Q2KK**2)/DD
- SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
- SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
- & *SQRT(GQ2(1)*GQ2(2))/DD
- SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
- & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
- SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
- & *SQRT(GQ2(1)*GQ2(2))/DD
- SIGQPM(4) = SW0P0P*FAC
- SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
- WEIGHT = HELFLX(4)*SIGQPM(4)
- & +HELFLX(6)*SIGQPM(6)/2.D0
- ENDIF
- ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
- IF(MSPR.EQ.14) THEN
- SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
- SIGQPM(5) = SW0000*FAC
- WEIGHT = HELFLX(5)*SIGQPM(5)
- ENDIF
- ELSE
- WRITE(LO,'(/1X,A,2I3)')
- & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
- WRITE(LO,'(1X,A,I12)')
- & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
- WEIGHT = 0.D0
- ENDIF
-
-C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
-
- WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
- & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGBLSR
- SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
- & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
-C***********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-gamma collisions via laser backscattering
-C
-C input: EE1 lab. system energy of electron/positron 1
-C EE2 lab. system energy of electron/positron 2
-C NEVENT number of events to generate
-C Pl_lam_1/2 product of electron and photon pol.
-C X_1/2 standard X parameter
-C rho ratio of distance to conversion point and
-C transverse beam size
-C A ellipticity of electon beam
-C
-C (see Ginzburg & Kotkin hep-ph/9905462)
-C
-C from /LEPCUT/:
-C YMIN1 lower limit of Y1
-C (energy fraction taken by photon from electron)
-C YMAX1 upper limit of Y1
-C YMIN2 lower limit of Y2
-C (energy fraction taken by photon from electron)
-C YMAX2 upper limit of Y2
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- parameter (N_dim=100)
- dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
- & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
- & Xgrid(96),Wgrid(96)
-
- DIMENSION P1(4),P2(4)
-
- Pi2 = 2.D0*Pi
-
- WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
-
- YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
- YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
- IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
- WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
- & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
- RETURN
- ENDIF
- IDPSRC(1) = 0
- IDBSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(2) = 0
-
-C initialize sampling
-
- Max_tab = 50
- DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
- DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
-
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
- & 'PHO_GGBLSR: table of photon flux ',Max_tab
-
- DO 100 I=1,Max_tab
-
- y1 = YMIN1+DELY1*DBLE(I-1)
- r1 = y1/(X_1*(1.D0-y1))
- X_inp_1(i) = y1
- F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
- & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
-
- y2 = YMIN2+DELY2*DBLE(I-1)
- r2 = y2/(X_2*(1.D0-y2))
- X_inp_2(i) = y2
- F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
- & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
-
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
- & y1,F_inp_1(i),y2,F_inp_2(i)
-
- 100 CONTINUE
-
- call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
- call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
-
-C initialize event generator
-
-C photon 1
- EGAM = YMAX1*EE1
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = EGAM
- P1(4) = EGAM
-C photon 2
- EGAM = YMAX2*EE2
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -EGAM
- P2(4) = EGAM
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-
-C generation of events
-
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- NITER = NEVENT
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
- ITRW = ITRW+1
-
- call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
- call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
-
- g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
- g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
- if(abs(1.D0-A).lt.1.D-3) then
- v = rho**2/4.D0*g_1*g_2
- Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
- else
- Nint = 16
- call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
- A2 = A**2
- fac = rho**2/(4.D0*(1.D0+A2))
- Wght = 0.D0
- do i1=1,Nint
- phi_1 = Xgrid(i1)
- do i2=1,Nint
- phi_2 = Xgrid(i2)
- Wght = Wght
- & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
- & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
- & *Wgrid(i1)*Wgrid(i2)
- enddo
- enddo
- Wght = Wght/Pi2**2
- endif
-
- IF(Wght.GT.1.D0) THEN
- WRITE(LO,'(1X,A,5E11.4)')
- & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
- ENDIF
- IF(DT_RNDM(dum).GT.Wght) GOTO 175
-
- Y1 = X_out_1
- Y2 = X_out_2
-
- Q2P1 = 0.D0
- Q2P2 = 0.D0
- GYY(1) = Y1
- GQ2(1) = Q2P1
- GYY(2) = Y2
- GQ2(2) = Q2P2
-C incoming electron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = EE1
- PINI(4,1) = EE1
- PINI(5,1) = 0.D0
-C outgoing electron 1
- YQ2 = SQRT((1.D0-Y1)*Q2P2)
- Q2E = Q2P1/(4.D0*EE1)
- E1Y = EE1*(1.D0-Y1)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,1) = YQ2*COF
- PFIN(2,1) = YQ2*SIF
- PFIN(3,1) = E1Y-Q2E
- PFIN(4,1) = E1Y+Q2E
- PFIN(5,1) = 0.D0
-C photon 1
- P1(1) = -PFIN(1,1)
- P1(2) = -PFIN(2,1)
- P1(3) = PINI(3,1)-PFIN(3,1)
- P1(4) = PINI(4,1)-PFIN(4,1)
-C incoming electron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE2
- PINI(4,2) = EE2
- PINI(5,2) = 0.D0
-C outgoing electron 2
- YQ2 = SQRT((1.D0-Y2)*Q2P2)
- Q2E = Q2P2/(4.D0*EE2)
- E1Y = EE2*(1.D0-Y2)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
-C photon 2
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
-
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = 0.D0
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = 0.D0
-C photon helicities
- IGHEL(1) = 1
- IGHEL(2) = 1
-C cut given by user
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-
-C statistics
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-
- WGY = DBLE(ITRY)/DBLE(ITRW)
- AY1 = AY1/DBLE(NITER)
- AYS1 = AYS1/DBLE(NITER)
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
- AY2 = AY2/DBLE(NITER)
- AYS2 = AYS2/DBLE(NITER)
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,3I10)')
- & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
- WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
-
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, pho_samp1d
- SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
-C***********************************************************************
-C
-C Monte Carlo sampling from arbitrary 1d distribution
-C (linear interpolation to improve reproduction of initial function)
-C
-C input: Imode -1 initialization
-C 1 sampling (after initialization)
-C X_inp(N_dim) array with x values
-C F_inp(N_dim) array with function values
-C F_int(N_dim) array with integral
-C
-C output: X_out sampled value (Imode=1)
-C
-C (R.E. 10/99)
-C
-C***********************************************************************
- implicit none
- save
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- integer Imode,N_dim
- double precision X_inp,F_inp,F_int,X_out
- dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
-
-C local variables
- integer i
- double precision dum,xi,a,b
-
-C external functions
- double precision DT_RNDM
- external DT_RNDM
-
- if(Imode.eq.-1) then
-
-C initialization
-
- F_int(1) = 0.D0
- do i=2,N_dim
- F_int(i) = F_int(i-1)
- & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
- enddo
-
- else if(Imode.eq.1) then
-
-C sample from previously calculated integral
-
- xi = DT_RNDM(dum)*F_int(N_dim)
-
- do i=2,N_dim
- if(xi.lt.F_int(i)) then
- a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
- b = F_inp(i)-a*X_inp(i)
- xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
- X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
- return
- endif
- enddo
- X_out = X_inp(N_dim)
-
- else
-
-C invalid option Imode
-
- WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
- X_out = 0.D0
-
- endif
-
- END
-
-CDECK ID>, pho_ExpBessI0
- DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
-C**********************************************************************
-C
-C Bessel Function I0 times exponential function from neg. arg.
-C (defined for pos. arguments only)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- AX = ABS(X)
- IF (AX .LT. 3.75D0) THEN
- Y = (X/3.75D0)**2
- pho_ExpBessI0 =
- & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
- & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
- ELSE
- Y = 3.75D0/AX
- pho_ExpBessI0 =
- & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
- & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
- & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
- & +Y*0.392377D-2))))))))
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGBEAM
- SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-gamma collisions via beamstrahlung
-C
-C input: EE LAB system energy of electron/positron
-C YPSI beamstrahlung parameter
-C SIGX,Y transverse bunch dimensions
-C SIGZ longitudinal bunch dimension
-C AEB number of electrons/positrons in a bunch
-C NEVENT number of events to generate
-C from /LEPCUT/:
-C YMIN1 lower limit of Y
-C (energy fraction taken by photon from electron)
-C YMAX1 upper cutoff for Y, necessary to avoid
-C underflows
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-20,
- & PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- PARAMETER (Max_tab=100)
- DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
-
-C
- WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
-C electron data
- RE = 2.818D-12
- ELEM = 0.512D-03
- IDPSRC(1) = 0
- IDBSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(2) = 0
-C table of flux function, log interpolation
- IF(YPSI.LE.0.D0) THEN
- YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
- ENDIF
- WRITE(LO,'(/1X,A,E12.4)')
- & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
- TT = 2.D0/3.D0
- OT = 1.D0/3.D0
-C GAOT = DGAMMA(OT)
- GAOT = 2.6789385347D0
- AKAP = TT/YPSI
- WW = 1.D0/(6.D0*SQRT(AKAP))
- ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
- & *YPSI/SQRT(1.D0+YPSI**TT)
-
- YMIN = YMIN1
- YMAX = MIN(YMAX1,0.9D0)
- TABCU(0) = 0.D0
- TABYL(0) = LOG(YMIN)
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- FLUX = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
- & 'PHO_GGBEAM: table of photon flux',Max_tab
- DO 100 I=1,Max_tab
- Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
- GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
- FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
- & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
- & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
- TABCU(I) = TABCU(I-1)+FF*Y
- TABYL(I) = LOG(Y)
- FLUX = FLUX+Y*FF
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
- 100 CONTINUE
- FLUX = FLUX*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_GGBEAM: integrated flux (one side):',FLUX
-
- EE1 = EE
- EE2 = EE
-C photon 1
- EGAM = YMAX*EE
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = EGAM
- P1(4) = EGAM
-C photon 2
- EGAM = YMAX*EE
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -EGAM
- P2(4) = EGAM
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-
-C generation of events
-
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- NITER = NEVENT
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
- ITRW = ITRW+1
- XI = DT_RNDM(AY1)*TABCU(Max_tab)
- DO 110 K=1,Max_tab
- IF(TABCU(K).GE.XI) THEN
- Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
- Y1 = EXP(Y1)
- GOTO 120
- ENDIF
- 110 CONTINUE
- Y1 = YMAX
- 120 CONTINUE
- XI = DT_RNDM(AY2)*TABCU(Max_tab)
- DO 130 K=1,Max_tab
- IF(TABCU(K).GE.XI) THEN
- Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
- Y2 = EXP(Y2)
- GOTO 140
- ENDIF
- 130 CONTINUE
- Y2 = YMAX
- 140 CONTINUE
-
- Q2P1 = 0.D0
- Q2P2 = 0.D0
- GYY(1) = Y1
- GQ2(1) = Q2P1
- GYY(2) = Y2
- GQ2(2) = Q2P2
-C incoming electron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = EE1
- PINI(4,1) = EE1
- PINI(5,1) = 0.D0
-C outgoing electron 1
- YQ2 = SQRT((1.D0-Y1)*Q2P2)
- Q2E = Q2P1/(4.D0*EE1)
- E1Y = EE1*(1.D0-Y1)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,1) = YQ2*COF
- PFIN(2,1) = YQ2*SIF
- PFIN(3,1) = E1Y-Q2E
- PFIN(4,1) = E1Y+Q2E
- PFIN(5,1) = 0.D0
-C photon 1
- P1(1) = -PFIN(1,1)
- P1(2) = -PFIN(2,1)
- P1(3) = PINI(3,1)-PFIN(3,1)
- P1(4) = PINI(4,1)-PFIN(4,1)
-C incoming electron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE2
- PINI(4,2) = EE2
- PINI(5,2) = 0.D0
-C outgoing electron 2
- YQ2 = SQRT((1.D0-Y2)*Q2P2)
- Q2E = Q2P2/(4.D0*EE2)
- E1Y = EE2*(1.D0-Y2)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
-C photon 2
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
-C
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = 0.D0
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = 0.D0
-C photon helicities
- IGHEL(1) = 1
- IGHEL(2) = 1
-C cut given by user
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
- GGECML = LOG(GGECM)
-
-C statistics
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
- AY1 = AY1/DBLE(NITER)
- AYS1 = AYS1/DBLE(NITER)
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
- AY2 = AY2/DBLE(NITER)
- AYS2 = AYS2/DBLE(NITER)
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,2I10)')
- & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
- WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGHIOF
- SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-gamma collisions via heavy ions (form factor approach)
-C
-C input: EEN LAB system energy per nucleon
-C NA atomic number of ion/hadron
-C NZ charge number of ion/hadron
-C NEVENT number of events to generate
-C from /LEPCUT/:
-C YMIN1,2 lower limit of Y
-C (energy fraction taken by photon from hadron)
-C YMAX1,2 upper cutoff for Y, necessary to avoid
-C underflows
-C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
-C Q2MAX1,2 maximum Q**2 of photons (if necessary,
-C corrected according size of hadron)
-C
-C currently implemented approximation similar to:
-C E.Papageorgiu PhysLettB250(1990)155
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4),BIMP(2,2)
-
-C
- WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
- & '--------------------------------------'
-C hadron size and mass
- FM2GEV = 5.07D0
- HIMASS = DBLE(NA)*0.938D0
- HIMA2 = HIMASS**2
- HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
- ALPHA = DBLE(NZ**2)/137.D0
-C correct Q2MAX1,2 according to hadron size
- Q2MAXH = 2.D0/HIRADI**2
- Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
- Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
- IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
- IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
-C total hadron / heavy ion energy
- EE = EEN*DBLE(NA)
- GAMMA = EE/HIMASS
-C setup /POFSRC/
- GAMSRC(1) = GAMMA
- GAMSRC(2) = GAMMA
- RADSRC(1) = HIRADI
- RADSRC(2) = HIRADI
- AMSRC(1) = HIMASS
- AMSRC(1) = HIMASS
-C kinematic limitations
- YMI = (ECMIN/(2.D0*EE))**2
- IF(YMIN1.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
- YMIN1 = YMI
- ELSE IF(YMIN1.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
- & ' INSTEAD OF',YMIN1
- ENDIF
- IF(YMIN2.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
- YMIN2 = YMI
- ELSE IF(YMIN2.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
- & ' INSTEAD OF',YMIN2
- ENDIF
-C kinematic limitation
- Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
-C debug output
- WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
- WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
- WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
- WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
- & Q2MAX1
- WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
- & Q2MAX2
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
- & YMAX1
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
- & YMAX2
- WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
- & 2.D0*EEN,2.D0*EE
- WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
- IF(Q2LOW1.GE.Q2MAX1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
- CALL PHO_ABORT
- ENDIF
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
- CALL PHO_ABORT
- ENDIF
-C hadron numbers set to 0
- IDPSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(1) = 0
- IDBSRC(2) = 0
-C
- Max_tab = 100
- YMAX = YMAX1
- YMIN = YMIN1
- XMAX = LOG(YMAX)
- XMIN = LOG(YMIN)
- XDEL = XMAX-XMIN
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- DO 100 I=1,Max_tab
- Y1 = EXP(XMIN+DELLY*DBLE(I-1))
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
- IF(Q2LOW1.GE.Q2MAX1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
- YMAX1 = MIN(Y1,YMAX1)
- GOTO 101
- ENDIF
- 100 CONTINUE
- 101 CONTINUE
- YMAX = YMAX2
- YMIN = YMIN2
- XMAX = LOG(YMAX)
- XMIN = LOG(YMIN)
- XDEL = XMAX-XMIN
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- DO 102 I=1,Max_tab
- Y1 = EXP(XMIN+DELLY*DBLE(I-1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
- YMAX2 = MIN(Y1,YMAX2)
- GOTO 103
- ENDIF
- 102 CONTINUE
- 103 CONTINUE
- YMI = (ECMIN/(2.D0*EE))**2/YMAX2
- IF(YMI.GT.YMIN1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
- YMIN1 = YMI
- ENDIF
- YMI = (ECMIN/(2.D0*EE))**2/YMAX1
- IF(YMI.GT.YMIN2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
- YMIN2 = YMI
- ENDIF
-C
- X1MAX = LOG(YMAX1)
- X1MIN = LOG(YMIN1)
- X1DEL = X1MAX-X1MIN
- X2MAX = LOG(YMAX2)
- X2MIN = LOG(YMIN2)
- X2DEL = X2MAX-X2MIN
- DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
- FLUX = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
- & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
- DO 105 I=1,Max_tab
- Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
- FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
- FLUX = FLUX+Y1*FF
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
- 105 CONTINUE
- FLUX = FLUX*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_GGHIOF: integrated flux (one side):',FLUX
-C
- Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
- Y1 = YMIN1
- Y2 = YMIN2
- WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
- & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
-C
-C photon 1
- EGAM = YMAX1*EE
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = EGAM
- P1(4) = EGAM
-C photon 2
- EGAM = YMAX2*EE
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -EGAM
- P2(4) = EGAM
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C
-C generation of events, flux calculation
-
- ECFRAC = ECMIN**2/(4.D0*EE*EE)
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- Q21MIN = 1.D30
- Q22MIN = 1.D30
- Q21MAX = 0.D0
- Q22MAX = 0.D0
- Q21AVE = 0.D0
- Q22AVE = 0.D0
- Q21AV2 = 0.D0
- Q22AV2 = 0.D0
- YY1MIN = 1.D30
- YY2MIN = 1.D30
- YY1MAX = 0.D0
- YY2MAX = 0.D0
- NITER = NEVENT
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
-C sample y1, y2
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
- ITRW = ITRW+1
- Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
- Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
- IF(Y1*Y2.LT.ECFRAC) GOTO 175
-C
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
- IF(Q2LOW1.GE.Q2MAX1) GOTO 175
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
- IF(Q2LOW2.GE.Q2MAX2) GOTO 175
- Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
- Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
- WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
- & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
- IF(WGMAX.LT.WGH) THEN
- WRITE(LO,'(1X,A,4E12.5)')
- & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
- ENDIF
- IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- YEFF = 1.D0+(1.D0-Y1)**2
- 185 CONTINUE
- Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
- WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
- ELSE
- Q2P1 = Q2LOW1
- ENDIF
- IF(IPAMDL(174).EQ.1) THEN
- YEFF = 1.D0+(1.D0-Y2)**2
- 186 CONTINUE
- Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
- WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
- ELSE
- Q2P2 = Q2LOW2
- ENDIF
-C impact parameter
- GAIMP(1) = 1.D0/SQRT(Q2P1)
- GAIMP(2) = 1.D0/SQRT(Q2P2)
-C form factor (squared)
- FF21 = 1.D0
- IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
- FF22 = 1.D0
- IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
- IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
-C do the hadrons overlap?
- IF(ISWMDL(26).GT.0) THEN
- DO 190 K=1,2
- CALL PHO_SFECFE(SIF,COF)
- BIMP(1,K) = SIF*GAIMP(K)
- BIMP(2,K) = COF*GAIMP(K)
- 190 CONTINUE
- BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
- & +(BIMP(2,1)-BIMP(2,2))**2)
- IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
- ENDIF
-C photon data
- GYY(1) = Y1
- GQ2(1) = Q2P1
- GYY(2) = Y2
- GQ2(2) = Q2P2
-C
-
-C incoming hadron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = EE
- PINI(4,1) = EE
- PINI(5,1) = 0.D0
-C outgoing hadron 1
- YQ2 = SQRT((1.D0-Y1)*Q2P1)
- Q2E = Q2P1/(4.D0*EE)
- E1Y = EE*(1.D0-Y1)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,1) = YQ2*COF
- PFIN(2,1) = YQ2*SIF
- PFIN(3,1) = E1Y-Q2E
- PFIN(4,1) = E1Y+Q2E
- PFIN(5,1) = 0.D0
- PFPHI(1) = ATAN2(COF,SIF)
- PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
-C photon 1
- P1(1) = -PFIN(1,1)
- P1(2) = -PFIN(2,1)
- P1(3) = PINI(3,1)-PFIN(3,1)
- P1(4) = PINI(4,1)-PFIN(4,1)
-C incoming hadron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE
- PINI(4,2) = EE
- PINI(5,2) = 0.D0
-C outgoing hadron 2
- YQ2 = SQRT((1.D0-Y2)*Q2P2)
- Q2E = Q2P2/(4.D0*EE)
- E1Y = EE*(1.D0-Y2)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
- PFPHI(2) = ATAN2(COF,SIF)
- PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
-C photon 2
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
-C
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = -SQRT(Q2P1)
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = -SQRT(Q2P2)
-C photon helicities
- IGHEL(1) = 1
- IGHEL(2) = 1
-C cut given by user
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-
-C statistics
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
- Q21MIN = MIN(Q21MIN,Q2P1)
- Q22MIN = MIN(Q22MIN,Q2P2)
- Q21MAX = MAX(Q21MAX,Q2P1)
- Q22MAX = MAX(Q22MAX,Q2P2)
- YY1MIN = MIN(YY1MIN,Y1)
- YY2MIN = MIN(YY2MIN,Y2)
- YY1MAX = MAX(YY1MAX,Y1)
- YY2MAX = MAX(YY2MAX,Y2)
- Q21AVE = Q21AVE+Q2P1
- Q22AVE = Q22AVE+Q2P2
- Q21AV2 = Q21AV2+Q2P1*Q2P1
- Q22AV2 = Q22AV2+Q2P2*Q2P2
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
- WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
- AY1 = AY1/DBLE(NITER)
- AYS1 = AYS1/DBLE(NITER)
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
- AY2 = AY2/DBLE(NITER)
- AYS2 = AYS2/DBLE(NITER)
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
- Q21AVE = Q21AVE/DBLE(NITER)
- Q21AV2 = Q21AV2/DBLE(NITER)
- Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
- Q22AVE = Q22AVE/DBLE(NITER)
- Q22AV2 = Q22AV2/DBLE(NITER)
- Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,3I10)')
- & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
- & AY1,DAY1
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
- & AY2,DAY2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
- & YY1MIN,YY1MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
- & YY2MIN,YY2MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
- & Q21AVE,Q21AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
- & Q21MIN,Q21MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
- & Q22AVE,Q22AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
- & Q22MIN,Q22MAX
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGHIOG
- SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-gamma collisions via heavy ions (geometrical approach)
-C
-C
-C input: EEN LAB system energy per nucleon
-C NA atomic number of ion/hadron
-C NZ charge number of ion/hadron
-C NEVENT number of events to generate
-C from /LEPCUT/:
-C YMIN1,2 lower limit of Y
-C (energy fraction taken by photon from hadron)
-C YMAX1,2 upper cutoff for Y, necessary to avoid
-C underflows
-C
-C currently implemented approximation similar to:
-C
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-20,
- & PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- PARAMETER (Max_tab=100)
- DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
-
-C
- WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
- & '---------------------------------------'
-C hadron size and mass
- FM2GEV = 5.07D0
- HIMASS = DBLE(NA)*0.938D0
- HIMA2 = HIMASS**2
- HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
- ALPHA = DBLE(NZ**2)/137.D0
-C total hadron / heavy ion energy
- EE = EEN*DBLE(NA)
- GAMMA = EE/HIMASS
-C setup /POFSRC/
- GAMSRC(1) = GAMMA
- GAMSRC(2) = GAMMA
- RADSRC(1) = HIRADI
- RADSRC(2) = HIRADI
- AMSRC(1) = HIMASS
- AMSRC(1) = HIMASS
-C kinematic limitations
- YMI = (ECMIN/(2.D0*EE))**2
- IF(YMIN1.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
- YMIN1 = YMI
- ELSE IF(YMIN1.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
- & ' INSTEAD OF',YMIN1
- ENDIF
- IF(YMIN2.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
- YMIN2 = YMI
- ELSE IF(YMIN2.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
- & ' INSTEAD OF',YMIN2
- ENDIF
-C debug output
- WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
- WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
- WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
- WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
- & YMAX1
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
- & YMAX2
- WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
- & 2.D0*EEN,2.D0*EE
- WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
-C hadron numbers set to 0
- IDPSRC(1) = 0
- IDBSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(2) = 0
-C table of flux function, log interpolation
- YMIN = YMIN1
- YMAX = YMAX1
- YMAX = MIN(YMAX,0.9999999D0)
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- TABYL(0) = LOG(YMIN)
- FFMAX = 0.D0
- DO 100 I=1,Max_tab
- Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
- WG = EE*Y
- XI = WG*HIRADI/GAMMA
- FF = ALPHA*PHO_GGFLCL(XI)/Y
- FFMAX = MAX(FF,FFMAX)
- IF(FF.LT.1.D-10*FFMAX) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
- YMAX1 = MIN(Y,YMAX1)
- GOTO 101
- ENDIF
- 100 CONTINUE
- 101 CONTINUE
- YMIN = YMIN2
- YMAX = YMAX2
- YMAX = MIN(YMAX,0.9999999D0)
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- TABYL(0) = LOG(YMIN)
- FFMAX = 0.D0
- DO 102 I=1,Max_tab
- Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
- WG = EE*Y
- XI = WG*HIRADI/GAMMA
- FF = ALPHA*PHO_GGFLCL(XI)/Y
- FFMAX = MAX(FF,FFMAX)
- IF(FF.LT.1.D-10*FFMAX) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
- YMAX2 = MIN(Y,YMAX2)
- GOTO 103
- ENDIF
- 102 CONTINUE
- 103 CONTINUE
- YMI = (ECMIN/(2.D0*EE))**2/YMAX2
- IF(YMI.GT.YMIN1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
- YMIN1 = YMI
- ENDIF
- YMAX1 = MIN(YMAX,YMAX1)
- YMI = (ECMIN/(2.D0*EE))**2/YMAX1
- IF(YMI.GT.YMIN2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
- YMIN2 = YMI
- ENDIF
-C
- YMIN = YMIN1
- YMAX = YMAX1
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- TABCU(0) = 0.D0
- TABYL(0) = LOG(YMIN)
- FLUX = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
- & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
- DO 105 I=1,Max_tab
- Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
- WG = EE*Y
- XI = WG*HIRADI/GAMMA
- FF = ALPHA*PHO_GGFLCL(XI)/Y
- FFMAX = MAX(FF,FFMAX)
- TABCU(I) = TABCU(I-1)+FF*Y
- TABYL(I) = LOG(Y)
- FLUX = FLUX+Y*FF
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
- 105 CONTINUE
- FLUX = FLUX*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_GGHIOG: integrated flux (one side):',FLUX
-C
-C initialization
-C photon 1
- EGAM = YMAX*EE
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = EGAM
- P1(4) = EGAM
-C photon 2
- EGAM = YMAX*EE
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -EGAM
- P2(4) = EGAM
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C
-C generation of events
-
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- YY1MIN = 1.D30
- YY2MIN = 1.D30
- YY1MAX = 0.D0
- YY2MAX = 0.D0
- NITER = NEVENT
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
- ITRW = ITRW+1
- XI = DT_RNDM(AY1)*TABCU(Max_tab)
- DO 110 K=1,Max_tab
- IF(TABCU(K).GE.XI) THEN
- Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
- Y1 = EXP(Y1)
- GOTO 120
- ENDIF
- 110 CONTINUE
- Y1 = YMAX1
- 120 CONTINUE
- XI = DT_RNDM(AY2)*TABCU(Max_tab)
- DO 130 K=1,Max_tab
- IF(TABCU(K).GE.XI) THEN
- Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
- Y2 = EXP(Y2)
- GOTO 140
- ENDIF
- 130 CONTINUE
- Y2 = YMAX2
- 140 CONTINUE
-C setup kinematics
-
- GYY(1) = Y1
- GQ2(1) = 0.D0
- GYY(2) = Y2
- GQ2(2) = 0.D0
-C incoming electron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = EE
- PINI(4,1) = EE
- PINI(5,1) = 0.D0
-C outgoing electron 1
- E1Y = EE*(1.D0-Y1)
- PFIN(1,1) = 0.D0
- PFIN(2,1) = 0.D0
- PFIN(3,1) = E1Y
- PFIN(4,1) = E1Y
- PFIN(5,1) = 0.D0
-C photon 1
- P1(1) = -PFIN(1,1)
- P1(2) = -PFIN(2,1)
- P1(3) = PINI(3,1)-PFIN(3,1)
- P1(4) = PINI(4,1)-PFIN(4,1)
-C incoming electron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -EE
- PINI(4,2) = EE
- PINI(5,2) = 0.D0
-C outgoing electron 2
- E1Y = EE*(1.D0-Y2)
- PFIN(1,2) = 0.D0
- PFIN(2,2) = 0.D0
- PFIN(3,2) = -E1Y
- PFIN(4,2) = E1Y
- PFIN(5,2) = 0.D0
-C photon 2
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = 0.D0
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = 0.D0
-C impact parameter constraints
- XI1 = P1(4)*HIRADI/GAMMA
- XI2 = P2(4)*HIRADI/GAMMA
- FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
- FCORR = PHO_GGFLCR(HIRADI)
- WGX = (FLX-FCORR)/FLX
- IF(DT_RNDM(Y2).GT.WGX) GOTO 175
-C photon helicities
- IGHEL(1) = 1
- IGHEL(2) = 1
-C cut given by user
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-
-C statistics
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
- YY1MIN = MIN(YY1MIN,Y1)
- YY2MIN = MIN(YY2MIN,Y2)
- YY1MAX = MAX(YY1MAX,Y1)
- YY2MAX = MAX(YY2MAX,Y2)
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
- AY1 = AY1/DBLE(NITER)
- AYS1 = AYS1/DBLE(NITER)
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
- AY2 = AY2/DBLE(NITER)
- AYS2 = AYS2/DBLE(NITER)
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,3I12)')
- & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
- & AY1,DAY1
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
- & AY2,DAY2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
- & YY1MIN,YY1MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
- & YY2MIN,YY2MAX
-
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_GGFLCL
- DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
-C*********************************************************************
-C
-C semi-classical photon flux (geometrical model)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
- & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
-
- END
-
-CDECK ID>, PHO_GGFLCR
- DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
-C*********************************************************************
-C
-C semi-classical photon flux correction due to
-C overlap in impact parameter space (geometrical model)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-
- DIMENSION XGAUSS(126),WGAUSS(126)
-
- DATA XGAUSS(1)/ .57735026918962576D0/
- DATA XGAUSS(2)/-.57735026918962576D0/
- DATA WGAUSS(1)/ 1.00000000000000000D0/
- DATA WGAUSS(2)/ 1.00000000000000000D0/
-
- DATA XGAUSS(3)/ .33998104358485627D0/
- DATA XGAUSS(4)/ .86113631159405258D0/
- DATA XGAUSS(5)/-.33998104358485627D0/
- DATA XGAUSS(6)/-.86113631159405258D0/
- DATA WGAUSS(3)/ .65214515486254613D0/
- DATA WGAUSS(4)/ .34785484513745385D0/
- DATA WGAUSS(5)/ .65214515486254613D0/
- DATA WGAUSS(6)/ .34785484513745385D0/
-
- DATA XGAUSS(7)/ .18343464249564981D0/
- DATA XGAUSS(8)/ .52553240991632899D0/
- DATA XGAUSS(9)/ .79666647741362674D0/
- DATA XGAUSS(10)/ .96028985649753623D0/
- DATA XGAUSS(11)/-.18343464249564981D0/
- DATA XGAUSS(12)/-.52553240991632899D0/
- DATA XGAUSS(13)/-.79666647741362674D0/
- DATA XGAUSS(14)/-.96028985649753623D0/
- DATA WGAUSS(7)/ .36268378337836198D0/
- DATA WGAUSS(8)/ .31370664587788727D0/
- DATA WGAUSS(9)/ .22238103445337448D0/
- DATA WGAUSS(10)/ .10122853629037627D0/
- DATA WGAUSS(11)/ .36268378337836198D0/
- DATA WGAUSS(12)/ .31370664587788727D0/
- DATA WGAUSS(13)/ .22238103445337448D0/
- DATA WGAUSS(14)/ .10122853629037627D0/
-
- DATA XGAUSS(15)/ .0950125098376374402D0/
- DATA XGAUSS(16)/ .281603550779258913D0/
- DATA XGAUSS(17)/ .458016777657227386D0/
- DATA XGAUSS(18)/ .617876244402643748D0/
- DATA XGAUSS(19)/ .755404408355003034D0/
- DATA XGAUSS(20)/ .865631202387831744D0/
- DATA XGAUSS(21)/ .944575023073232576D0/
- DATA XGAUSS(22)/ .989400934991649933D0/
- DATA XGAUSS(23)/-.0950125098376374402D0/
- DATA XGAUSS(24)/-.281603550779258913D0/
- DATA XGAUSS(25)/-.458016777657227386D0/
- DATA XGAUSS(26)/-.617876244402643748D0/
- DATA XGAUSS(27)/-.755404408355003034D0/
- DATA XGAUSS(28)/-.865631202387831744D0/
- DATA XGAUSS(29)/-.944575023073232576D0/
- DATA XGAUSS(30)/-.989400934991649933D0/
- DATA WGAUSS(15)/ .189450610455068496D0/
- DATA WGAUSS(16)/ .182603415044923589D0/
- DATA WGAUSS(17)/ .169156519395002538D0/
- DATA WGAUSS(18)/ .149595988816576732D0/
- DATA WGAUSS(19)/ .124628971255533872D0/
- DATA WGAUSS(20)/ .0951585116824927848D0/
- DATA WGAUSS(21)/ .0622535239386478929D0/
- DATA WGAUSS(22)/ .0271524594117540949D0/
- DATA WGAUSS(23)/ .189450610455068496D0/
- DATA WGAUSS(24)/ .182603415044923589D0/
- DATA WGAUSS(25)/ .169156519395002538D0/
- DATA WGAUSS(26)/ .149595988816576732D0/
- DATA WGAUSS(27)/ .124628971255533872D0/
- DATA WGAUSS(28)/ .0951585116824927848D0/
- DATA WGAUSS(29)/ .0622535239386478929D0/
- DATA WGAUSS(30)/ .0271524594117540949D0/
-
- DATA XGAUSS(31)/ .0483076656877383162D0/
- DATA XGAUSS(32)/ .144471961582796493D0/
- DATA XGAUSS(33)/ .239287362252137075D0/
- DATA XGAUSS(34)/ .331868602282127650D0/
- DATA XGAUSS(35)/ .421351276130635345D0/
- DATA XGAUSS(36)/ .506899908932229390D0/
- DATA XGAUSS(37)/ .587715757240762329D0/
- DATA XGAUSS(38)/ .663044266930215201D0/
- DATA XGAUSS(39)/ .732182118740289680D0/
- DATA XGAUSS(40)/ .794483795967942407D0/
- DATA XGAUSS(41)/ .849367613732569970D0/
- DATA XGAUSS(42)/ .896321155766052124D0/
- DATA XGAUSS(43)/ .934906075937739689D0/
- DATA XGAUSS(44)/ .964762255587506430D0/
- DATA XGAUSS(45)/ .985611511545268335D0/
- DATA XGAUSS(46)/ .997263861849481564D0/
- DATA XGAUSS(47)/-.0483076656877383162D0/
- DATA XGAUSS(48)/-.144471961582796493D0/
- DATA XGAUSS(49)/-.239287362252137075D0/
- DATA XGAUSS(50)/-.331868602282127650D0/
- DATA XGAUSS(51)/-.421351276130635345D0/
- DATA XGAUSS(52)/-.506899908932229390D0/
- DATA XGAUSS(53)/-.587715757240762329D0/
- DATA XGAUSS(54)/-.663044266930215201D0/
- DATA XGAUSS(55)/-.732182118740289680D0/
- DATA XGAUSS(56)/-.794483795967942407D0/
- DATA XGAUSS(57)/-.849367613732569970D0/
- DATA XGAUSS(58)/-.896321155766052124D0/
- DATA XGAUSS(59)/-.934906075937739689D0/
- DATA XGAUSS(60)/-.964762255587506430D0/
- DATA XGAUSS(61)/-.985611511545268335D0/
- DATA XGAUSS(62)/-.997263861849481564D0/
- DATA WGAUSS(31)/ .0965400885147278006D0/
- DATA WGAUSS(32)/ .0956387200792748594D0/
- DATA WGAUSS(33)/ .0938443990808045654D0/
- DATA WGAUSS(34)/ .0911738786957638847D0/
- DATA WGAUSS(35)/ .0876520930044038111D0/
- DATA WGAUSS(36)/ .0833119242269467552D0/
- DATA WGAUSS(37)/ .0781938957870703065D0/
- DATA WGAUSS(38)/ .0723457941088485062D0/
- DATA WGAUSS(39)/ .0658222227763618468D0/
- DATA WGAUSS(40)/ .0586840934785355471D0/
- DATA WGAUSS(41)/ .0509980592623761762D0/
- DATA WGAUSS(42)/ .0428358980222266807D0/
- DATA WGAUSS(43)/ .0342738629130214331D0/
- DATA WGAUSS(44)/ .0253920653092620595D0/
- DATA WGAUSS(45)/ .0162743947309056706D0/
- DATA WGAUSS(46)/ .00701861000947009660D0/
- DATA WGAUSS(47)/ .0965400885147278006D0/
- DATA WGAUSS(48)/ .0956387200792748594D0/
- DATA WGAUSS(49)/ .0938443990808045654D0/
- DATA WGAUSS(50)/ .0911738786957638847D0/
- DATA WGAUSS(51)/ .0876520930044038111D0/
- DATA WGAUSS(52)/ .0833119242269467552D0/
- DATA WGAUSS(53)/ .0781938957870703065D0/
- DATA WGAUSS(54)/ .0723457941088485062D0/
- DATA WGAUSS(55)/ .0658222227763618468D0/
- DATA WGAUSS(56)/ .0586840934785355471D0/
- DATA WGAUSS(57)/ .0509980592623761762D0/
- DATA WGAUSS(58)/ .0428358980222266807D0/
- DATA WGAUSS(59)/ .0342738629130214331D0/
- DATA WGAUSS(60)/ .0253920653092620595D0/
- DATA WGAUSS(61)/ .0162743947309056706D0/
- DATA WGAUSS(62)/ .00701861000947009660D0/
-
- DATA XGAUSS(63)/ .02435029266342443250D0/
- DATA XGAUSS(64)/ .0729931217877990394D0/
- DATA XGAUSS(65)/ .121462819296120554D0/
- DATA XGAUSS(66)/ .169644420423992818D0/
- DATA XGAUSS(67)/ .217423643740007084D0/
- DATA XGAUSS(68)/ .264687162208767416D0/
- DATA XGAUSS(69)/ .311322871990210956D0/
- DATA XGAUSS(70)/ .357220158337668116D0/
- DATA XGAUSS(71)/ .402270157963991604D0/
- DATA XGAUSS(72)/ .446366017253464088D0/
- DATA XGAUSS(73)/ .489403145707052957D0/
- DATA XGAUSS(74)/ .531279464019894546D0/
- DATA XGAUSS(75)/ .571895646202634034D0/
- DATA XGAUSS(76)/ .611155355172393250D0/
- DATA XGAUSS(77)/ .648965471254657340D0/
- DATA XGAUSS(78)/ .685236313054233243D0/
- DATA XGAUSS(79)/ .719881850171610827D0/
- DATA XGAUSS(80)/ .752819907260531897D0/
- DATA XGAUSS(81)/ .783972358943341408D0/
- DATA XGAUSS(82)/ .813265315122797560D0/
- DATA XGAUSS(83)/ .840629296252580363D0/
- DATA XGAUSS(84)/ .865999398154092820D0/
- DATA XGAUSS(85)/ .889315445995114106D0/
- DATA XGAUSS(86)/ .910522137078502806D0/
- DATA XGAUSS(87)/ .929569172131939576D0/
- DATA XGAUSS(88)/ .946411374858402816D0/
- DATA XGAUSS(89)/ .961008799652053719D0/
- DATA XGAUSS(90)/ .973326827789910964D0/
- DATA XGAUSS(91)/ .983336253884625957D0/
- DATA XGAUSS(92)/ .991013371476744321D0/
- DATA XGAUSS(93)/ .996340116771955279D0/
- DATA XGAUSS(94)/ .999305041735772139D0/
- DATA XGAUSS(95)/-.02435029266342443250D0/
- DATA XGAUSS(96)/-.0729931217877990394D0/
- DATA XGAUSS(97)/-.121462819296120554D0/
- DATA XGAUSS(98)/-.169644420423992818D0/
- DATA XGAUSS(99)/-.217423643740007084D0/
- DATA XGAUSS(100)/-.264687162208767416D0/
- DATA XGAUSS(101)/-.311322871990210956D0/
- DATA XGAUSS(102)/-.357220158337668116D0/
- DATA XGAUSS(103)/-.402270157963991604D0/
- DATA XGAUSS(104)/-.446366017253464088D0/
- DATA XGAUSS(105)/-.489403145707052957D0/
- DATA XGAUSS(106)/-.531279464019894546D0/
- DATA XGAUSS(107)/-.571895646202634034D0/
- DATA XGAUSS(108)/-.611155355172393250D0/
- DATA XGAUSS(109)/-.648965471254657340D0/
- DATA XGAUSS(110)/-.685236313054233243D0/
- DATA XGAUSS(111)/-.719881850171610827D0/
- DATA XGAUSS(112)/-.752819907260531897D0/
- DATA XGAUSS(113)/-.783972358943341408D0/
- DATA XGAUSS(114)/-.813265315122797560D0/
- DATA XGAUSS(115)/-.840629296252580363D0/
- DATA XGAUSS(116)/-.865999398154092820D0/
- DATA XGAUSS(117)/-.889315445995114106D0/
- DATA XGAUSS(118)/-.910522137078502806D0/
- DATA XGAUSS(119)/-.929569172131939576D0/
- DATA XGAUSS(120)/-.946411374858402816D0/
- DATA XGAUSS(121)/-.961008799652053719D0/
- DATA XGAUSS(122)/-.973326827789910964D0/
- DATA XGAUSS(123)/-.983336253884625957D0/
- DATA XGAUSS(124)/-.991013371476744321D0/
- DATA XGAUSS(125)/-.996340116771955279D0/
- DATA XGAUSS(126)/-.999305041735772139D0/
- DATA WGAUSS(63)/ .0486909570091397204D0/
- DATA WGAUSS(64)/ .0485754674415034269D0/
- DATA WGAUSS(65)/ .0483447622348029572D0/
- DATA WGAUSS(66)/ .0479993885964583077D0/
- DATA WGAUSS(67)/ .0475401657148303087D0/
- DATA WGAUSS(68)/ .0469681828162100173D0/
- DATA WGAUSS(69)/ .0462847965813144172D0/
- DATA WGAUSS(70)/ .0454916279274181445D0/
- DATA WGAUSS(71)/ .0445905581637565631D0/
- DATA WGAUSS(72)/ .0435837245293234534D0/
- DATA WGAUSS(73)/ .0424735151236535890D0/
- DATA WGAUSS(74)/ .0412625632426235286D0/
- DATA WGAUSS(75)/ .0399537411327203414D0/
- DATA WGAUSS(76)/ .0385501531786156291D0/
- DATA WGAUSS(77)/ .0370551285402400460D0/
- DATA WGAUSS(78)/ .0354722132568823838D0/
- DATA WGAUSS(79)/ .0338051618371416094D0/
- DATA WGAUSS(80)/ .0320579283548515535D0/
- DATA WGAUSS(81)/ .0302346570724024789D0/
- DATA WGAUSS(82)/ .0283396726142594832D0/
- DATA WGAUSS(83)/ .0263774697150546587D0/
- DATA WGAUSS(84)/ .0243527025687108733D0/
- DATA WGAUSS(85)/ .0222701738083832542D0/
- DATA WGAUSS(86)/ .0201348231535302094D0/
- DATA WGAUSS(87)/ .0179517157756973431D0/
- DATA WGAUSS(88)/ .0157260304760247193D0/
- DATA WGAUSS(89)/ .0134630478967186426D0/
- DATA WGAUSS(90)/ .0111681394601311288D0/
- DATA WGAUSS(91)/ .00884675982636394772D0/
- DATA WGAUSS(92)/ .00650445796897836286D0/
- DATA WGAUSS(93)/ .00414703326056246764D0/
- DATA WGAUSS(94)/ .00178328072169643295D0/
- DATA WGAUSS(95)/ .0486909570091397204D0/
- DATA WGAUSS(96)/ .0485754674415034269D0/
- DATA WGAUSS(97)/ .0483447622348029572D0/
- DATA WGAUSS(98)/ .0479993885964583077D0/
- DATA WGAUSS(99)/ .0475401657148303087D0/
- DATA WGAUSS(100)/ .0469681828162100173D0/
- DATA WGAUSS(101)/ .0462847965813144172D0/
- DATA WGAUSS(102)/ .0454916279274181445D0/
- DATA WGAUSS(103)/ .0445905581637565631D0/
- DATA WGAUSS(104)/ .0435837245293234534D0/
- DATA WGAUSS(105)/ .0424735151236535890D0/
- DATA WGAUSS(106)/ .0412625632426235286D0/
- DATA WGAUSS(107)/ .0399537411327203414D0/
- DATA WGAUSS(108)/ .0385501531786156291D0/
- DATA WGAUSS(109)/ .0370551285402400460D0/
- DATA WGAUSS(110)/ .0354722132568823838D0/
- DATA WGAUSS(111)/ .0338051618371416094D0/
- DATA WGAUSS(112)/ .0320579283548515535D0/
- DATA WGAUSS(113)/ .0302346570724024789D0/
- DATA WGAUSS(114)/ .0283396726142594832D0/
- DATA WGAUSS(115)/ .0263774697150546587D0/
- DATA WGAUSS(116)/ .0243527025687108733D0/
- DATA WGAUSS(117)/ .0222701738083832542D0/
- DATA WGAUSS(118)/ .0201348231535302094D0/
- DATA WGAUSS(119)/ .0179517157756973431D0/
- DATA WGAUSS(120)/ .0157260304760247193D0/
- DATA WGAUSS(121)/ .0134630478967186426D0/
- DATA WGAUSS(122)/ .0111681394601311288D0/
- DATA WGAUSS(123)/ .00884675982636394772D0/
- DATA WGAUSS(124)/ .00650445796897836286D0/
- DATA WGAUSS(125)/ .00414703326056246764D0/
- DATA WGAUSS(126)/ .00178328072169643295D0/
-
-C integrate first over b1
-C
-C Loop incrementing the boundary
-C
- tmin = 0.D0
- tmax = 0.25D0
- Sum = 0.D0
-
- 50 CONTINUE
-
-C
-C Loop for the Gauss integration
-C
- XINT=0.D0
- DO 100 N=1,6
- XINT2 = XINT
- XINT=0.D0
- DO 200 I=2**N-1,2**(N+1)-2
- t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
- b1 = RADSRC(1) * EXP (t)
- XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
- 200 CONTINUE
- XINT = (tmax-tmin)/2.D0*XINT
- IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
- 100 CONTINUE
- WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
- 300 CONTINUE
-
- Sum = Sum + XINT
- IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
- tmin = tmax
- tmax = tmax + 0.5D0
- GOTO 50
- ENDIF
-
- PHO_GGFLCR = 4.D0*Pi * Sum
-
- END
-
-CDECK ID>, PHO_GGFAUX
- DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
-C*********************************************************************
-C
-C auxiliary function for integration over b2,
-C semi-classical photon flux correction due to
-C overlap in impact parameter space (geometrical model)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-
- DIMENSION XGAUSS(126),WGAUSS(126)
-
- DATA XGAUSS(1)/ .57735026918962576D0/
- DATA XGAUSS(2)/-.57735026918962576D0/
- DATA WGAUSS(1)/ 1.00000000000000000D0/
- DATA WGAUSS(2)/ 1.00000000000000000D0/
-
- DATA XGAUSS(3)/ .33998104358485627D0/
- DATA XGAUSS(4)/ .86113631159405258D0/
- DATA XGAUSS(5)/-.33998104358485627D0/
- DATA XGAUSS(6)/-.86113631159405258D0/
- DATA WGAUSS(3)/ .65214515486254613D0/
- DATA WGAUSS(4)/ .34785484513745385D0/
- DATA WGAUSS(5)/ .65214515486254613D0/
- DATA WGAUSS(6)/ .34785484513745385D0/
-
- DATA XGAUSS(7)/ .18343464249564981D0/
- DATA XGAUSS(8)/ .52553240991632899D0/
- DATA XGAUSS(9)/ .79666647741362674D0/
- DATA XGAUSS(10)/ .96028985649753623D0/
- DATA XGAUSS(11)/-.18343464249564981D0/
- DATA XGAUSS(12)/-.52553240991632899D0/
- DATA XGAUSS(13)/-.79666647741362674D0/
- DATA XGAUSS(14)/-.96028985649753623D0/
- DATA WGAUSS(7)/ .36268378337836198D0/
- DATA WGAUSS(8)/ .31370664587788727D0/
- DATA WGAUSS(9)/ .22238103445337448D0/
- DATA WGAUSS(10)/ .10122853629037627D0/
- DATA WGAUSS(11)/ .36268378337836198D0/
- DATA WGAUSS(12)/ .31370664587788727D0/
- DATA WGAUSS(13)/ .22238103445337448D0/
- DATA WGAUSS(14)/ .10122853629037627D0/
-
- DATA XGAUSS(15)/ .0950125098376374402D0/
- DATA XGAUSS(16)/ .281603550779258913D0/
- DATA XGAUSS(17)/ .458016777657227386D0/
- DATA XGAUSS(18)/ .617876244402643748D0/
- DATA XGAUSS(19)/ .755404408355003034D0/
- DATA XGAUSS(20)/ .865631202387831744D0/
- DATA XGAUSS(21)/ .944575023073232576D0/
- DATA XGAUSS(22)/ .989400934991649933D0/
- DATA XGAUSS(23)/-.0950125098376374402D0/
- DATA XGAUSS(24)/-.281603550779258913D0/
- DATA XGAUSS(25)/-.458016777657227386D0/
- DATA XGAUSS(26)/-.617876244402643748D0/
- DATA XGAUSS(27)/-.755404408355003034D0/
- DATA XGAUSS(28)/-.865631202387831744D0/
- DATA XGAUSS(29)/-.944575023073232576D0/
- DATA XGAUSS(30)/-.989400934991649933D0/
- DATA WGAUSS(15)/ .189450610455068496D0/
- DATA WGAUSS(16)/ .182603415044923589D0/
- DATA WGAUSS(17)/ .169156519395002538D0/
- DATA WGAUSS(18)/ .149595988816576732D0/
- DATA WGAUSS(19)/ .124628971255533872D0/
- DATA WGAUSS(20)/ .0951585116824927848D0/
- DATA WGAUSS(21)/ .0622535239386478929D0/
- DATA WGAUSS(22)/ .0271524594117540949D0/
- DATA WGAUSS(23)/ .189450610455068496D0/
- DATA WGAUSS(24)/ .182603415044923589D0/
- DATA WGAUSS(25)/ .169156519395002538D0/
- DATA WGAUSS(26)/ .149595988816576732D0/
- DATA WGAUSS(27)/ .124628971255533872D0/
- DATA WGAUSS(28)/ .0951585116824927848D0/
- DATA WGAUSS(29)/ .0622535239386478929D0/
- DATA WGAUSS(30)/ .0271524594117540949D0/
-
- DATA XGAUSS(31)/ .0483076656877383162D0/
- DATA XGAUSS(32)/ .144471961582796493D0/
- DATA XGAUSS(33)/ .239287362252137075D0/
- DATA XGAUSS(34)/ .331868602282127650D0/
- DATA XGAUSS(35)/ .421351276130635345D0/
- DATA XGAUSS(36)/ .506899908932229390D0/
- DATA XGAUSS(37)/ .587715757240762329D0/
- DATA XGAUSS(38)/ .663044266930215201D0/
- DATA XGAUSS(39)/ .732182118740289680D0/
- DATA XGAUSS(40)/ .794483795967942407D0/
- DATA XGAUSS(41)/ .849367613732569970D0/
- DATA XGAUSS(42)/ .896321155766052124D0/
- DATA XGAUSS(43)/ .934906075937739689D0/
- DATA XGAUSS(44)/ .964762255587506430D0/
- DATA XGAUSS(45)/ .985611511545268335D0/
- DATA XGAUSS(46)/ .997263861849481564D0/
- DATA XGAUSS(47)/-.0483076656877383162D0/
- DATA XGAUSS(48)/-.144471961582796493D0/
- DATA XGAUSS(49)/-.239287362252137075D0/
- DATA XGAUSS(50)/-.331868602282127650D0/
- DATA XGAUSS(51)/-.421351276130635345D0/
- DATA XGAUSS(52)/-.506899908932229390D0/
- DATA XGAUSS(53)/-.587715757240762329D0/
- DATA XGAUSS(54)/-.663044266930215201D0/
- DATA XGAUSS(55)/-.732182118740289680D0/
- DATA XGAUSS(56)/-.794483795967942407D0/
- DATA XGAUSS(57)/-.849367613732569970D0/
- DATA XGAUSS(58)/-.896321155766052124D0/
- DATA XGAUSS(59)/-.934906075937739689D0/
- DATA XGAUSS(60)/-.964762255587506430D0/
- DATA XGAUSS(61)/-.985611511545268335D0/
- DATA XGAUSS(62)/-.997263861849481564D0/
- DATA WGAUSS(31)/ .0965400885147278006D0/
- DATA WGAUSS(32)/ .0956387200792748594D0/
- DATA WGAUSS(33)/ .0938443990808045654D0/
- DATA WGAUSS(34)/ .0911738786957638847D0/
- DATA WGAUSS(35)/ .0876520930044038111D0/
- DATA WGAUSS(36)/ .0833119242269467552D0/
- DATA WGAUSS(37)/ .0781938957870703065D0/
- DATA WGAUSS(38)/ .0723457941088485062D0/
- DATA WGAUSS(39)/ .0658222227763618468D0/
- DATA WGAUSS(40)/ .0586840934785355471D0/
- DATA WGAUSS(41)/ .0509980592623761762D0/
- DATA WGAUSS(42)/ .0428358980222266807D0/
- DATA WGAUSS(43)/ .0342738629130214331D0/
- DATA WGAUSS(44)/ .0253920653092620595D0/
- DATA WGAUSS(45)/ .0162743947309056706D0/
- DATA WGAUSS(46)/ .00701861000947009660D0/
- DATA WGAUSS(47)/ .0965400885147278006D0/
- DATA WGAUSS(48)/ .0956387200792748594D0/
- DATA WGAUSS(49)/ .0938443990808045654D0/
- DATA WGAUSS(50)/ .0911738786957638847D0/
- DATA WGAUSS(51)/ .0876520930044038111D0/
- DATA WGAUSS(52)/ .0833119242269467552D0/
- DATA WGAUSS(53)/ .0781938957870703065D0/
- DATA WGAUSS(54)/ .0723457941088485062D0/
- DATA WGAUSS(55)/ .0658222227763618468D0/
- DATA WGAUSS(56)/ .0586840934785355471D0/
- DATA WGAUSS(57)/ .0509980592623761762D0/
- DATA WGAUSS(58)/ .0428358980222266807D0/
- DATA WGAUSS(59)/ .0342738629130214331D0/
- DATA WGAUSS(60)/ .0253920653092620595D0/
- DATA WGAUSS(61)/ .0162743947309056706D0/
- DATA WGAUSS(62)/ .00701861000947009660D0/
-
- DATA XGAUSS(63)/ .02435029266342443250D0/
- DATA XGAUSS(64)/ .0729931217877990394D0/
- DATA XGAUSS(65)/ .121462819296120554D0/
- DATA XGAUSS(66)/ .169644420423992818D0/
- DATA XGAUSS(67)/ .217423643740007084D0/
- DATA XGAUSS(68)/ .264687162208767416D0/
- DATA XGAUSS(69)/ .311322871990210956D0/
- DATA XGAUSS(70)/ .357220158337668116D0/
- DATA XGAUSS(71)/ .402270157963991604D0/
- DATA XGAUSS(72)/ .446366017253464088D0/
- DATA XGAUSS(73)/ .489403145707052957D0/
- DATA XGAUSS(74)/ .531279464019894546D0/
- DATA XGAUSS(75)/ .571895646202634034D0/
- DATA XGAUSS(76)/ .611155355172393250D0/
- DATA XGAUSS(77)/ .648965471254657340D0/
- DATA XGAUSS(78)/ .685236313054233243D0/
- DATA XGAUSS(79)/ .719881850171610827D0/
- DATA XGAUSS(80)/ .752819907260531897D0/
- DATA XGAUSS(81)/ .783972358943341408D0/
- DATA XGAUSS(82)/ .813265315122797560D0/
- DATA XGAUSS(83)/ .840629296252580363D0/
- DATA XGAUSS(84)/ .865999398154092820D0/
- DATA XGAUSS(85)/ .889315445995114106D0/
- DATA XGAUSS(86)/ .910522137078502806D0/
- DATA XGAUSS(87)/ .929569172131939576D0/
- DATA XGAUSS(88)/ .946411374858402816D0/
- DATA XGAUSS(89)/ .961008799652053719D0/
- DATA XGAUSS(90)/ .973326827789910964D0/
- DATA XGAUSS(91)/ .983336253884625957D0/
- DATA XGAUSS(92)/ .991013371476744321D0/
- DATA XGAUSS(93)/ .996340116771955279D0/
- DATA XGAUSS(94)/ .999305041735772139D0/
- DATA XGAUSS(95)/-.02435029266342443250D0/
- DATA XGAUSS(96)/-.0729931217877990394D0/
- DATA XGAUSS(97)/-.121462819296120554D0/
- DATA XGAUSS(98)/-.169644420423992818D0/
- DATA XGAUSS(99)/-.217423643740007084D0/
- DATA XGAUSS(100)/-.264687162208767416D0/
- DATA XGAUSS(101)/-.311322871990210956D0/
- DATA XGAUSS(102)/-.357220158337668116D0/
- DATA XGAUSS(103)/-.402270157963991604D0/
- DATA XGAUSS(104)/-.446366017253464088D0/
- DATA XGAUSS(105)/-.489403145707052957D0/
- DATA XGAUSS(106)/-.531279464019894546D0/
- DATA XGAUSS(107)/-.571895646202634034D0/
- DATA XGAUSS(108)/-.611155355172393250D0/
- DATA XGAUSS(109)/-.648965471254657340D0/
- DATA XGAUSS(110)/-.685236313054233243D0/
- DATA XGAUSS(111)/-.719881850171610827D0/
- DATA XGAUSS(112)/-.752819907260531897D0/
- DATA XGAUSS(113)/-.783972358943341408D0/
- DATA XGAUSS(114)/-.813265315122797560D0/
- DATA XGAUSS(115)/-.840629296252580363D0/
- DATA XGAUSS(116)/-.865999398154092820D0/
- DATA XGAUSS(117)/-.889315445995114106D0/
- DATA XGAUSS(118)/-.910522137078502806D0/
- DATA XGAUSS(119)/-.929569172131939576D0/
- DATA XGAUSS(120)/-.946411374858402816D0/
- DATA XGAUSS(121)/-.961008799652053719D0/
- DATA XGAUSS(122)/-.973326827789910964D0/
- DATA XGAUSS(123)/-.983336253884625957D0/
- DATA XGAUSS(124)/-.991013371476744321D0/
- DATA XGAUSS(125)/-.996340116771955279D0/
- DATA XGAUSS(126)/-.999305041735772139D0/
- DATA WGAUSS(63)/ .0486909570091397204D0/
- DATA WGAUSS(64)/ .0485754674415034269D0/
- DATA WGAUSS(65)/ .0483447622348029572D0/
- DATA WGAUSS(66)/ .0479993885964583077D0/
- DATA WGAUSS(67)/ .0475401657148303087D0/
- DATA WGAUSS(68)/ .0469681828162100173D0/
- DATA WGAUSS(69)/ .0462847965813144172D0/
- DATA WGAUSS(70)/ .0454916279274181445D0/
- DATA WGAUSS(71)/ .0445905581637565631D0/
- DATA WGAUSS(72)/ .0435837245293234534D0/
- DATA WGAUSS(73)/ .0424735151236535890D0/
- DATA WGAUSS(74)/ .0412625632426235286D0/
- DATA WGAUSS(75)/ .0399537411327203414D0/
- DATA WGAUSS(76)/ .0385501531786156291D0/
- DATA WGAUSS(77)/ .0370551285402400460D0/
- DATA WGAUSS(78)/ .0354722132568823838D0/
- DATA WGAUSS(79)/ .0338051618371416094D0/
- DATA WGAUSS(80)/ .0320579283548515535D0/
- DATA WGAUSS(81)/ .0302346570724024789D0/
- DATA WGAUSS(82)/ .0283396726142594832D0/
- DATA WGAUSS(83)/ .0263774697150546587D0/
- DATA WGAUSS(84)/ .0243527025687108733D0/
- DATA WGAUSS(85)/ .0222701738083832542D0/
- DATA WGAUSS(86)/ .0201348231535302094D0/
- DATA WGAUSS(87)/ .0179517157756973431D0/
- DATA WGAUSS(88)/ .0157260304760247193D0/
- DATA WGAUSS(89)/ .0134630478967186426D0/
- DATA WGAUSS(90)/ .0111681394601311288D0/
- DATA WGAUSS(91)/ .00884675982636394772D0/
- DATA WGAUSS(92)/ .00650445796897836286D0/
- DATA WGAUSS(93)/ .00414703326056246764D0/
- DATA WGAUSS(94)/ .00178328072169643295D0/
- DATA WGAUSS(95)/ .0486909570091397204D0/
- DATA WGAUSS(96)/ .0485754674415034269D0/
- DATA WGAUSS(97)/ .0483447622348029572D0/
- DATA WGAUSS(98)/ .0479993885964583077D0/
- DATA WGAUSS(99)/ .0475401657148303087D0/
- DATA WGAUSS(100)/ .0469681828162100173D0/
- DATA WGAUSS(101)/ .0462847965813144172D0/
- DATA WGAUSS(102)/ .0454916279274181445D0/
- DATA WGAUSS(103)/ .0445905581637565631D0/
- DATA WGAUSS(104)/ .0435837245293234534D0/
- DATA WGAUSS(105)/ .0424735151236535890D0/
- DATA WGAUSS(106)/ .0412625632426235286D0/
- DATA WGAUSS(107)/ .0399537411327203414D0/
- DATA WGAUSS(108)/ .0385501531786156291D0/
- DATA WGAUSS(109)/ .0370551285402400460D0/
- DATA WGAUSS(110)/ .0354722132568823838D0/
- DATA WGAUSS(111)/ .0338051618371416094D0/
- DATA WGAUSS(112)/ .0320579283548515535D0/
- DATA WGAUSS(113)/ .0302346570724024789D0/
- DATA WGAUSS(114)/ .0283396726142594832D0/
- DATA WGAUSS(115)/ .0263774697150546587D0/
- DATA WGAUSS(116)/ .0243527025687108733D0/
- DATA WGAUSS(117)/ .0222701738083832542D0/
- DATA WGAUSS(118)/ .0201348231535302094D0/
- DATA WGAUSS(119)/ .0179517157756973431D0/
- DATA WGAUSS(120)/ .0157260304760247193D0/
- DATA WGAUSS(121)/ .0134630478967186426D0/
- DATA WGAUSS(122)/ .0111681394601311288D0/
- DATA WGAUSS(123)/ .00884675982636394772D0/
- DATA WGAUSS(124)/ .00650445796897836286D0/
- DATA WGAUSS(125)/ .00414703326056246764D0/
- DATA WGAUSS(126)/ .00178328072169643295D0/
-C
- W1 = PGAM(4,1)
- W2 = PGAM(4,2)
- bmin = b1 - 2.D0*RADSRC(1)
- IF (RADSRC(1) .GT. bmin) THEN
- bmin = RADSRC(1)
- ENDIF
- bmax = b1 + 2.D0 * RADSRC(1)
-
- XINT = 0.D0
- DO 100 N=1,6
- XINT2 = XINT
- XINT = 0.D0
- DO 200 I=2**N-1,2**(N+1)-2
- b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
- XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
- & * PHO_GGFNUC(W2,b2,GAMSRC(2))
- & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
- XINT = XINT +WGAUSS(I) * b2 * XINT3
- 200 CONTINUE
- XINT = (bmax-bmin)/2.D0*XINT
- IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
- 100 CONTINUE
- WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
- 300 CONTINUE
-
- PHO_GGFAUX = XINT
-
- END
-
-CDECK ID>, PHO_GGFNUC
- DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
-C**********************************************************************
-C
-C differential photonnumber for a nucleus (geometrical model)
-C (without form factor)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (PI = 3.14159265359D0)
-
- WGamma = W/Gamma
- Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
-
- PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
-
- END
-
-CDECK ID>, PHO_GHHIOF
- SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-hadron collisions in heavy ion collisions
-C (form factor approach)
-C
-C input: EEN LAB system energy per nucleon
-C NA atomic number of ion/hadron
-C NZ charge number of ion/hadron
-C NEVENT number of events to generate
-C from /LEPCUT/:
-C YMIN1,2 lower limit of Y
-C (energy fraction taken by photon from hadron)
-C YMAX1,2 upper cutoff for Y, necessary to avoid
-C underflows
-C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
-C Q2MAX1,2 maximum Q**2 of photons (if necessary,
-C corrected according size of hadron)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4)
- DIMENSION NITERS(2),ITRW(2)
-
- WRITE(LO,'(2(/1X,A))')
- & 'PHO_GHHIOF: gamma-hadron event generation',
- & '-----------------------------------------'
-C hadron size and mass
- FM2GEV = 5.07D0
- HIMASS = DBLE(NA)*0.938D0
- HIMA2 = HIMASS**2
- HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
- ALPHA = DBLE(NZ**2)/137.D0
- AMP = 0.938D0
- AMP2 = AMP**2
-C correct Q2MAX1,2 according to hadron size
- Q2MAXH = 2.D0/HIRADI**2
- Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
- Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
- IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
- IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
-C total hadron / heavy ion energy
- EE = EEN*DBLE(NA)
- GAMMA = EE/HIMASS
-C setup /POFSRC/
- GAMSRC(1) = GAMMA
- GAMSRC(2) = GAMMA
- RADSRC(1) = HIRADI
- RADSRC(2) = HIRADI
- AMSRC(1) = HIMASS
- AMSRC(2) = HIMASS
-C check cuts on photon-hadron mass
- IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
- YMI = ECMIN
- ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
- ENDIF
-C check kinematic limitations
- YMI = ECMIN**2/(4.D0*EE*EEN)
- IF(YMIN1.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
- YMIN1 = YMI
- ELSE IF(YMIN1.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
- & ' INSTEAD OF',YMIN1
- ENDIF
- IF(YMIN2.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
- YMIN2 = YMI
- ELSE IF(YMIN2.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
- & ' INSTEAD OF',YMIN2
- ENDIF
-C kinematic limitation
- Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
-C debug output
- WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
- WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
- WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
- WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
- & Q2MAX1
- WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
- & Q2MAX2
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
- & YMAX1
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
- & YMAX2
- WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
- & 2.D0*EEN,2.D0*EE
- WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
- & ECMAX
- WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
- & PARMDL(175)
- WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
- IF(Q2LOW1.GE.Q2MAX1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
- CALL PHO_ABORT
- ENDIF
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
- CALL PHO_ABORT
- ENDIF
-C hadron numbers set to 0
- IDPSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(1) = 0
- IDBSRC(2) = 0
-C
- Max_tab = 100
- YMAX = YMAX1
- YMIN = YMIN1
- XMAX = LOG(YMAX)
- XMIN = LOG(YMIN)
- XDEL = XMAX-XMIN
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- DO 100 I=1,Max_tab
- Y1 = EXP(XMIN+DELLY*DBLE(I-1))
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
- IF(Q2LOW1.GE.Q2MAX1) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
- YMAX1 = MIN(Y1,YMAX1)
- GOTO 101
- ENDIF
- 100 CONTINUE
- 101 CONTINUE
- YMAX = YMAX2
- YMIN = YMIN2
- XMAX = LOG(YMAX)
- XMIN = LOG(YMIN)
- XDEL = XMAX-XMIN
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- DO 102 I=1,Max_tab
- Y1 = EXP(XMIN+DELLY*DBLE(I-1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
- YMAX2 = MIN(Y1,YMAX2)
- GOTO 103
- ENDIF
- 102 CONTINUE
- 103 CONTINUE
-C
- X1MAX = LOG(YMAX1)
- X1MIN = LOG(YMIN1)
- X1DEL = X1MAX-X1MIN
- X2MAX = LOG(YMAX2)
- X2MIN = LOG(YMIN2)
- X2DEL = X2MAX-X2MIN
- DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
- FLUX = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
- & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
- DO 105 I=1,Max_tab
- Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
- FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
- FLUX = FLUX+Y1*FF
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
- 105 CONTINUE
- FLUX = FLUX*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_GHHIOF: integrated flux (one side):',FLUX
-C
-C photon
- EGAM = MAX(YMAX1,YMAX2)*EE
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = EGAM
- P1(4) = EGAM
-C hadron
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -SQRT(EEN**2-AMP2)
- P2(4) = EEN
- CALL PHO_SETPAR(1,22,0,0.D0)
- CALL PHO_SETPAR(2,2212,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
-C
- Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
- Y1 = YMIN1
- Y2 = YMIN2
- WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
- WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
-C
- IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
- IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
-C
- FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
- & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
-C
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C
-C generation of events, flux calculation
-
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- Q21MIN = 1.D30
- Q22MIN = 1.D30
- Q21MAX = 0.D0
- Q22MAX = 0.D0
- Q21AVE = 0.D0
- Q22AVE = 0.D0
- Q21AV2 = 0.D0
- Q22AV2 = 0.D0
- YY1MIN = 1.D30
- YY2MIN = 1.D30
- YY1MAX = 0.D0
- YY2MAX = 0.D0
- NITER = NEVENT
- NITERS(1) = 0
- NITERS(2) = 0
- ITRY = 0
- ITRW(1) = 0
- ITRW(2) = 0
- DO 200 I=1,NITER
-C sample y1, y2
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
-C
-C select side of photon emission
- IF(DT_RNDM(AY1).LT.FAC12) THEN
- ITRW(1) = ITRW(1)+1
-C select Y1
- Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
- Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
- IF(Q2LOW1.GE.Q2MAX1) GOTO 175
- Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
- WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
- & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
- IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
- & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
- IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- YEFF = 1.D0+(1.D0-Y1)**2
- 185 CONTINUE
- Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
- WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
- ELSE
- Q2P1 = Q2LOW1
- ENDIF
-C impact parameter
- GAIMP(1) = 1.D0/SQRT(Q2P1)
-C form factor (squared)
- FF2 = 1.D0
- IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
- IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
-C photon data
- GYY(1) = Y1
- GQ2(1) = Q2P1
-
-C
-C incoming hadron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = SQRT(EE**2-AMP2)
- PINI(4,1) = EE
- PINI(5,1) = AMP
-C outgoing hadron 1
- YQ2 = SQRT((1.D0-Y1)*Q2P1)
- Q2E = Q2P1/(4.D0*EE)
- E1Y = EE*(1.D0-Y1)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,1) = YQ2*COF
- PFIN(2,1) = YQ2*SIF
- PFIN(3,1) = E1Y-Q2E
- PFIN(4,1) = E1Y+Q2E
- PFIN(5,1) = 0.D0
- PFPHI(1) = ATAN2(COF,SIF)
- PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
-C incoming hadron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -SQRT(EE**2-AMP2)
- PINI(4,2) = EE
- PINI(5,2) = AMP
-C scattering photon
- P1(1) = -PFIN(1,1)
- P1(2) = -PFIN(2,1)
- P1(3) = PINI(3,1)-PFIN(3,1)
- P1(4) = PINI(4,1)-PFIN(4,1)
-C scattering hadron
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -SQRT(EEN**2-AMP2)
- P2(4) = EEN
- ISIDE = 1
-C
- ELSE
-C
- ITRW(2) = ITRW(2)+1
-C select Y2
- Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
- IF(Q2LOW2.GE.Q2MAX2) GOTO 175
- Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
- WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
- IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
- & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
- IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- YEFF = 1.D0+(1.D0-Y2)**2
- 186 CONTINUE
- Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
- WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
- ELSE
- Q2P2 = Q2LOW2
- ENDIF
-C impact parameter
- GAIMP(2) = 1.D0/SQRT(Q2P2)
-C form factor (squared)
- FF2 = 1.D0
- IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
- IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
-C photon data
- GYY(2) = Y2
- GQ2(2) = Q2P2
-
-C
-C incoming hadron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = SQRT(EE**2-AMP2)
- PINI(4,1) = EE
- PINI(5,1) = AMP
-C incoming hadron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -SQRT(EE**2-AMP2)
- PINI(4,2) = EE
- PINI(5,2) = AMP
-C outgoing hadron 2
- YQ2 = SQRT((1.D0-Y2)*Q2P2)
- Q2E = Q2P2/(4.D0*EE)
- E1Y = EE*(1.D0-Y2)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
- PFPHI(2) = ATAN2(COF,SIF)
- PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
-C scattering hadron
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = SQRT(EEN**2-AMP2)
- P2(4) = EEN
-C scattering photon
- P1(1) = -PFIN(1,2)
- P1(2) = -PFIN(2,2)
- P1(3) = PINI(3,2)-PFIN(3,2)
- P1(4) = PINI(4,2)-PFIN(4,2)
- ISIDE = 2
- ENDIF
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
-C
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = -SQRT(Q2P1)
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = -SQRT(Q2P2)
- CALL PHO_PRESEL(5,IREJ)
-C photon helicities
- IGHEL(1) = 1
- IGHEL(2) = 1
-C user cuts
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-C cut on diffractive mass
- DO 250 K=1,NHEP
- IF(ISTHEP(K).EQ.30) THEN
- GHDIFF = PHEP(1,K)
- IF(GHDIFF.GE.PARMDL(175)) THEN
- GOTO 251
- ELSE
- GOTO 150
- ENDIF
- ENDIF
- 250 CONTINUE
- WRITE(LO,'(/,1X,A)')
- & 'PHO_GHHIOF: no diffractive entry found'
- CALL PHO_PREVNT(-1)
- GOTO 150
- 251 CONTINUE
-C remove quasi-elastically scattered hadron
- DO 260 K=1,NHEP
- IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
- XF = ABS(PHEP(3,K)/EEN)
- IF(XF.LT.PARMDL(72)) GOTO 150
-* ISTHEP(K) = 2
- GOTO 261
- ENDIF
- 260 CONTINUE
- 261 CONTINUE
-C
-C statistics
-
- NITERS(ISIDE) = NITERS(ISIDE)+1
- IF(ISIDE.EQ.1) THEN
-
- AY1 = AY1+Y1
- AYS1 = AYS1+Y1*Y1
- Q21AVE = Q21AVE+Q2P1
- Q21AV2 = Q21AV2+Q2P1*Q2P1
- Q21MIN = MIN(Q21MIN,Q2P1)
- Q21MAX = MAX(Q21MAX,Q2P1)
- YY1MIN = MIN(YY1MIN,Y1)
- YY1MAX = MAX(YY1MAX,Y1)
- ELSE
-
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
- Q22AVE = Q22AVE+Q2P2
- Q22AV2 = Q22AV2+Q2P2*Q2P2
- Q22MIN = MIN(Q22MIN,Q2P2)
- Q22MAX = MAX(Q22MAX,Q2P2)
- YY2MIN = MIN(YY2MIN,Y2)
- YY2MAX = MAX(YY2MAX,Y2)
- ENDIF
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
- WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
- WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
- WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
- AY1 = AY1/DBLE(MAX(NITERS(1),1))
- AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
- DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
- AY2 = AY2/DBLE(MAX(NITERS(2),1))
- AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
- Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
- Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
- Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
- Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
- Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
- Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
- WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
- WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,/3X,6I12)')
- & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
- & NITER,NITERS,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
- & AY1,DAY1
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
- & AY2,DAY2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
- & YY1MIN,YY1MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
- & YY2MIN,YY2MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
- & Q21AVE,Q21AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
- & Q21MIN,Q21MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
- & Q22AVE,Q22AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
- & Q22MIN,Q22MAX
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_GHHIAS
- SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
-C**********************************************************************
-C
-C interface to call PHOJET (variable energy run) for
-C gamma-hadron collisions in heavy ion - hadron
-C collisions (form factor approach)
-C
-C input: EEP LAB system energy of proton (GeV)
-C EEN LAB system energy per nucleon (GeV)
-C NA atomic number of ion/hadron
-C NZ charge number of ion/hadron
-C NEVENT number of events to generate
-C from /LEPCUT/:
-C YMIN2 lower limit of Y
-C (energy fraction taken by photon from hadron)
-C YMAX2 upper cutoff for Y, necessary to avoid
-C underflows
-C Q2MIN2 minimum Q**2 of photons (should be set to 0)
-C Q2MAX2 maximum Q**2 of photons (if necessary,
-C corrected according size of hadron)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PI = 3.14159265359D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C photon flux kinematics and cuts
- DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2
- INTEGER ITAG1,ITAG2
- COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
- & YMIN1,YMAX1,YMIN2,YMAX2,
- & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
- & THMIN1,THMAX1,THMIN2,THMAX2,
- & ITAG1,ITAG2
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION P1(4),P2(4)
-
- WRITE(LO,'(2(/1X,A))')
- & 'PHO_GHHIAS: hadron-gamma event generation',
- & '-----------------------------------------'
-C hadron size and mass
- FM2GEV = 5.07D0
- HIMASS = DBLE(NA)*0.938D0
- HIMA2 = HIMASS**2
- HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
- ALPHA = DBLE(NZ**2)/137.D0
- AMP = 0.938D0
- AMP2 = AMP**2
-C correct Q2MAX2 according to hadron size
- Q2MAXH = 2.D0/HIRADI**2
- Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
- IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
-C total hadron / heavy ion energy
- EE = EEN*DBLE(NA)
- GAMMA = EE/HIMASS
-C setup /POFSRC/
- GAMSRC(2) = GAMMA
- RADSRC(2) = HIRADI
- AMSRC(2) = HIMASS
-C check kinematic limitations
- YMI = ECMIN**2/(4.D0*EE*EEP)
- IF(YMIN2.LT.YMI) THEN
- WRITE(LO,'(/1X,A,2E12.5)')
- & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
- YMIN2 = YMI
- ELSE IF(YMIN2.GT.YMI) THEN
- WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
- & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
- & ' INSTEAD OF',YMIN2
- ENDIF
-C kinematic limitation
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
-C debug output
- WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
- WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
- WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
- WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
- & Q2MAX2
- WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
- & YMAX2
- WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
- & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
- WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
- & ECMAX
- WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
- CALL PHO_ABORT
- ENDIF
-C hadron numbers set to 0
- IDPSRC(1) = 0
- IDPSRC(2) = 0
- IDBSRC(1) = 0
- IDBSRC(2) = 0
-C
- Max_tab = 100
- YMAX = YMAX2
- YMIN = YMIN2
- XMAX = LOG(YMAX)
- XMIN = LOG(YMIN)
- XDEL = XMAX-XMIN
- DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
- DO 102 I=1,Max_tab
- Y1 = EXP(XMIN+DELLY*DBLE(I-1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
- IF(Q2LOW2.GE.Q2MAX2) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
- YMAX2 = MIN(Y1,YMAX2)
- GOTO 103
- ENDIF
- 102 CONTINUE
- 103 CONTINUE
-C
- X2MAX = LOG(YMAX2)
- X2MIN = LOG(YMIN2)
- X2DEL = X2MAX-X2MIN
- DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
- FLUX = 0.D0
- IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
- & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
- DO 105 I=1,Max_tab
- Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
- FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
- FLUX = FLUX+Y2*FF
- IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
- 105 CONTINUE
- FLUX = FLUX*DELLY
- IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_GHHIAS: integrated flux:',FLUX
-C
-C hadron
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = -SQRT(EEP**2-AMP2)
- P1(4) = EEP
-C photon
- EGAM = YMAX2*EE
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = EGAM
- P2(4) = EGAM
- CALL PHO_SETPAR(1,2212,0,0.D0)
- CALL PHO_SETPAR(2,22,0,0.D0)
- CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
-C
- Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
- Y2 = YMIN2
- WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
-C
- CALL PHO_PHIST(-1,SIGMAX)
- CALL PHO_LHIST(-1,SIGMAX)
-C
-C generation of events, flux calculation
-
- AY1 = 0.D0
- AY2 = 0.D0
- AYS1 = 0.D0
- AYS2 = 0.D0
- Q22MIN = 1.D30
- Q22MAX = 0.D0
- Q22AVE = 0.D0
- Q22AV2 = 0.D0
- YY2MIN = 1.D30
- YY2MAX = 0.D0
- NITER = NEVENT
- NITERS = 0
- ITRY = 0
- ITRW = 0
- DO 200 I=1,NITER
-C sample photon flux
- 150 CONTINUE
- ITRY = ITRY+1
- 175 CONTINUE
-C
- ITRW = ITRW+1
-C select Y2
- Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
- Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
- IF(Q2LOW2.GE.Q2MAX2) GOTO 175
- Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
- WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
- & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
- IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
- & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
- IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
-C sample Q2
- IF(IPAMDL(174).EQ.1) THEN
- YEFF = 1.D0+(1.D0-Y2)**2
- 186 CONTINUE
- Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
- WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
- IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
- ELSE
- Q2P2 = Q2LOW2
- ENDIF
-C impact parameter
- GAIMP(2) = 1.D0/SQRT(Q2P2)
-C form factor (squared)
- FF2 = 1.D0
- IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
- IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
-C photon data
- GYY(2) = Y2
- GQ2(2) = Q2P2
-
-C
-C incoming hadron 1
- PINI(1,1) = 0.D0
- PINI(2,1) = 0.D0
- PINI(3,1) = SQRT(EEP**2-AMP2)
- PINI(4,1) = EEP
- PINI(5,1) = AMP
-C incoming hadron 2
- PINI(1,2) = 0.D0
- PINI(2,2) = 0.D0
- PINI(3,2) = -SQRT(EE**2-AMP2)
- PINI(4,2) = EE
- PINI(5,2) = AMP
-C outgoing hadron 2
- YQ2 = SQRT((1.D0-Y2)*Q2P2)
- Q2E = Q2P2/(4.D0*EE)
- E1Y = EE*(1.D0-Y2)
- CALL PHO_SFECFE(SIF,COF)
- PFIN(1,2) = YQ2*COF
- PFIN(2,2) = YQ2*SIF
- PFIN(3,2) = -E1Y+Q2E
- PFIN(4,2) = E1Y+Q2E
- PFIN(5,2) = 0.D0
- PFPHI(2) = ATAN2(COF,SIF)
- PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
-C scattering hadron
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = SQRT(EEP**2-AMP2)
- P1(4) = EEP
- Q2P1 = AMP2
-C scattering photon
- P2(1) = -PFIN(1,2)
- P2(2) = -PFIN(2,2)
- P2(3) = PINI(3,2)-PFIN(3,2)
- P2(4) = PINI(4,2)-PFIN(4,2)
- ISIDE = 2
-C
-C ECMS cut
- GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
- IF(GGECM.LT.0.1D0) GOTO 175
- GGECM = SQRT(GGECM)
- IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
-C
- PGAM(1,1) = P1(1)
- PGAM(2,1) = P1(2)
- PGAM(3,1) = P1(3)
- PGAM(4,1) = P1(4)
- PGAM(5,1) = AMP
- PGAM(1,2) = P2(1)
- PGAM(2,2) = P2(2)
- PGAM(3,2) = P2(3)
- PGAM(4,2) = P2(4)
- PGAM(5,2) = -SQRT(Q2P2)
-C photon helicities
- IGHEL(2) = 1
-C user cuts
- CALL PHO_PRESEL(5,IREJ)
- IF(IREJ.NE.0) GOTO 175
-C event generation
- CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
- IF(IREJ.NE.0) GOTO 150
-C cut on diffractive mass
- DO 250 K=1,NHEP
- IF(ISTHEP(K).EQ.30) THEN
- GHDIFF = PHEP(1,K)
- IF(GHDIFF.GE.PARMDL(175)) THEN
- GOTO 251
- ELSE
- GOTO 150
- ENDIF
- ENDIF
- 250 CONTINUE
- WRITE(LO,'(/,1X,A)')
- & 'PHO_GHHIOF: no diffractive entry found'
- CALL PHO_PREVNT(-1)
- GOTO 150
- 251 CONTINUE
-C remove quasi-elastically scattered hadron
- DO 260 K=1,NHEP
- IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
- XF = ABS(PHEP(3,K)/EEN)
- IF(XF.LT.PARMDL(72)) GOTO 150
-* ISTHEP(K) = 2
- GOTO 261
- ENDIF
- 260 CONTINUE
- 261 CONTINUE
-C
-C statistics
-
- NITERS = NITERS+1
-
- AY2 = AY2+Y2
- AYS2 = AYS2+Y2*Y2
- Q22AVE = Q22AVE+Q2P2
- Q22AV2 = Q22AV2+Q2P2*Q2P2
- Q22MIN = MIN(Q22MIN,Q2P2)
- Q22MAX = MAX(Q22MAX,Q2P2)
- YY2MIN = MIN(YY2MIN,Y2)
- YY2MAX = MAX(YY2MAX,Y2)
-C histograms
- CALL PHO_PHIST(1,HSWGHT(0))
- CALL PHO_LHIST(1,HSWGHT(0))
- 200 CONTINUE
-C
- WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
- WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
- AY2 = AY2/DBLE(MAX(NITERS,1))
- AYS2 = AYS2/DBLE(MAX(NITERS,1))
- DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
- Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
- Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
- Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
- WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
- WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
- WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
-C output of statistics, histograms
- WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
- &'=========================================================',
- &' ***** simulated cross section: ',WEIGHT,' mb *****',
- &'========================================================='
- WRITE(LO,'(//1X,A,/3X,4I12)')
- & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
- & NITER,NITERS,ITRY,ITRW
- WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
- & WGY,WEIGHT
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
- & AY2,DAY2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
- & YY2MIN,YY2MAX
- WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
- & Q22AVE,Q22AV2
- WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
- & Q22MIN,Q22MAX
-C
- CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
- IF(NITER.GT.1) THEN
- CALL PHO_PHIST(-2,WEIGHT)
- CALL PHO_LHIST(-2,WEIGHT)
- ELSE
- WRITE(LO,'(1X,A,I4)')
- & 'PHO_GHHIOF: no output of histograms',NITER
- ENDIF
-
- END
-
-CDECK ID>, PHO_FITPAR
- SUBROUTINE PHO_FITPAR(IOUTP)
-C**********************************************************************
-C
-C read input parameters according to PDFs
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEFA=-99999.D0,
- & DEFB=-100000.D0,
- & THOUS=1.D3)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-
- DIMENSION INUM(3),IFPAS(2)
- CHARACTER*8 CNAME8,PDFNA1,PDFNA2
- CHARACTER*10 CNAM10
-
- PARAMETER ( Max_tab = 22 )
- DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
- REAL XDPtab
- INTEGER IDPtab
-
-C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
- DATA (IDPtab(k, 1),k=1,8) /
- & 2212, 5, 6, 0, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 1),k=1,27) /
- &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
- &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
- &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
- &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
- DATA (IDPtab(k, 2),k=1,8) /
- & 2212, 5, 6, 0, -2212, 5, 6, 0 /
- DATA (XDPtab(k, 2),k=1,27) /
- &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
- &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
- &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
- &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
- DATA (IDPtab(k, 3),k=1,8) /
- & 22, 5, 3, 0, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 3),k=1,27) /
- &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
- &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
- DATA (IDPtab(k, 4),k=1,8) /
- & 22, 5, 3, 0, 22, 5, 3, 0 /
- DATA (XDPtab(k, 4),k=1,27) /
- &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
- &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
- DATA (IDPtab(k, 5),k=1,8) /
- & 22, 5, 4, 4, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 5),k=1,27) /
- &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
- &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
- DATA (IDPtab(k, 6),k=1,8) /
- & 22, 5, 4, 4, 22, 5, 4, 4 /
- DATA (XDPtab(k, 6),k=1,27) /
- &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
- &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
- DATA (IDPtab(k, 7),k=1,8) /
- & 22, 1, 1, 4, 22, 1, 1, 4 /
- DATA (XDPtab(k, 7),k=1,27) /
- &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
- &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
- DATA (IDPtab(k, 8),k=1,8) /
- & 22, 1, 2, 4, 22, 1, 2, 4 /
- DATA (XDPtab(k, 8),k=1,27) /
- &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
- &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
- DATA (IDPtab(k, 9),k=1,8) /
- & 22, 1, 3, 4, 22, 1, 3, 4 /
- DATA (XDPtab(k, 9),k=1,27) /
- &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
- &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
- DATA (IDPtab(k, 10),k=1,8) /
- & 22, 1, 4, 4, 22, 1, 4, 4 /
- DATA (XDPtab(k, 10),k=1,27) /
- &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
- &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 11),k=1,8) /
- & 22, 3, 1, 3, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 11),k=1,27) /
- &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 12),k=1,8) /
- & 22, 3, 1, 2, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 12),k=1,27) /
- &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 22 (LAC )
- DATA (IDPtab(k, 13),k=1,8) /
- & 22, 3, 1, 3, 22, 3, 1, 3 /
- DATA (XDPtab(k, 13),k=1,27) /
- &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
- &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
- DATA (IDPtab(k, 14),k=1,8) /
- & 22, 3, 1, 2, 22, 3, 1, 2 /
- DATA (XDPtab(k, 14),k=1,27) /
- &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
- &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 15),k=1,8) /
- & 22, 3, 2, 3, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 15),k=1,27) /
- &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 16),k=1,8) /
- & 22, 3, 2, 2, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 16),k=1,27) /
- &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 22 (LAC )
- DATA (IDPtab(k, 17),k=1,8) /
- & 22, 3, 2, 3, 22, 3, 2, 3 /
- DATA (XDPtab(k, 17),k=1,27) /
- &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
- &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
- DATA (IDPtab(k, 18),k=1,8) /
- & 22, 3, 2, 2, 22, 3, 2, 2 /
- DATA (XDPtab(k, 18),k=1,27) /
- &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
- &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 19),k=1,8) /
- & 22, 3, 3, 3, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 19),k=1,27) /
- &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
- DATA (IDPtab(k, 20),k=1,8) /
- & 22, 3, 3, 2, 2212, 5, 6, 0 /
- DATA (XDPtab(k, 20),k=1,27) /
- &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
- &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
- &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
-
-C parameter set for 22 (LAC ) 22 (LAC )
- DATA (IDPtab(k, 21),k=1,8) /
- & 22, 3, 3, 3, 22, 3, 3, 3 /
- DATA (XDPtab(k, 21),k=1,27) /
- &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
- &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
-C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
- DATA (IDPtab(k, 22),k=1,8) /
- & 22, 3, 3, 2, 22, 3, 3, 2 /
- DATA (XDPtab(k, 22),k=1,27) /
- &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
- &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
- &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
- &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
- &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
-
- DATA CNAME8 /' '/
- DATA CNAM10 /' '/
- DATA INIT / 0 /
- DATA IFPAS / 0, 0 /
-
- IF((INIT.EQ.1).AND.
- & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
-
- INIT=1
- IFPAS(1) = IFPAP(1)
- IFPAS(2) = IFPAP(2)
-
-C parton distribution functions
- CALL PHO_ACTPDF(IFPAP(1),1)
- CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
- CALL PHO_ACTPDF(IFPAP(2),2)
- CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
-C initialize alpha_s calculation
- DUMMY = PHO_ALPHAS(0.D0,-4)
-
- IF(IDEB(54).GE.0) THEN
- WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
- & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
- WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
- & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
- ENDIF
-
- IFOUND = 0
-
-C load parameter set from internal tables
- I1 = 1
- I2 = 2
- 110 CONTINUE
-
- DO I=1,Max_tab
- IF((IFPAP(I1).EQ.IDPtab(1,I))
- & .AND.(IGRP(I1).EQ.IDPtab(2,I))
- & .AND.(ISET(I1).EQ.IDPtab(3,I))
- & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
- IF((IFPAP(I2).EQ.IDPtab(5,I))
- & .AND.(IGRP(I2).EQ.IDPtab(6,I))
- & .AND.(ISET(I2).EQ.IDPtab(7,I))
- & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A)')
-C & 'PHO_FITPAR: parameter set found in internal table'
- ALPOM = XDPtab(1,I)
- ALPOMP = XDPtab(2,I)
- GP(I1) = XDPtab(3,I)
- GP(I2) = XDPtab(4,I)
- B0POM(I1) = XDPtab(5,I)
- B0POM(I2) = XDPtab(6,I)
- ALREG = XDPtab(7,I)
- ALREGP = XDPtab(8,I)
- GR(I1) = XDPtab(9,I)
- GR(I2) = XDPtab(10,I)
- B0REG(I1) = XDPtab(11,I)
- B0REG(I2) = XDPtab(12,I)
- GPPP = XDPtab(13,I)
- B0PPP = XDPtab(14,I)
- GPPR = XDPtab(15,I)
- B0PPR = XDPtab(16,I)
- VDMFAC(2*I1-1) = XDPtab(17,I)
- VDMFAC(2*I1) = XDPtab(18,I)
- VDMFAC(2*I2-1) = XDPtab(19,I)
- VDMFAC(2*I2) = XDPtab(20,I)
- B0HAR = XDPtab(21,I)
- AKFAC = XDPtab(22,I)
- PHISUP(I1) = XDPtab(23,I)
- PHISUP(I2) = XDPtab(24,I)
- RMASS(I1) = XDPtab(25,I)
- RMASS(I2) = XDPtab(26,I)
- VAR = XDPtab(27,I)
- IFOUND = 1
- GOTO 1200
- ENDIF
- ENDIF
- ENDDO
-
- IF(I1.EQ.1) THEN
- I1 = 2
- I2 = 1
- GOTO 110
- ELSE
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A)')
-C & 'PHO_FITPAR: parameter set not found in internal table'
- ENDIF
-
- 1200 CONTINUE
-
-C get parameters of soft cross sections from fitpar.dat
- IF(IPAMDL(99).GT.IFOUND) THEN
-
- WRITE(LO,'(/1X,A)')
- & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
- OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
-
- 100 CONTINUE
- READ(12,'(A8)',ERR=1020,END=1010) CNAME8
- IF(CNAME8.EQ.'STOP') GOTO 1010
- IF(CNAME8.EQ.'NEXTDATA') THEN
- READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
- & IDPA1,CNAME8,INUM
- IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
- & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
- READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
- & IDPA2,CNAME8,INUM
- IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
- & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
- WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
- READ(12,*) ALPOM,ALPOMP,GP,B0POM
- READ(12,*) ALREG,ALREGP,GR,B0REG
- READ(12,*) GPPP,B0PPP,GPPR,B0PPR
- READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
- READ(12,*) B0HAR
- READ(12,*) AKFAC
- READ(12,*) PHISUP
- READ(12,*) RMASS,VAR
- IFOUND = 1
- GOTO 1100
- ENDIF
- ENDIF
- ENDIF
- GOTO 100
-
- 1020 CONTINUE
- WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
- WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
- 1010 CONTINUE
- WRITE(LO,'(/A)')
- & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
-
- 1100 CONTINUE
- CLOSE(12)
-
- ENDIF
-
-C nothing found
- IF(IFOUND.EQ.0) THEN
- WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
- WRITE(LO,'(3(10X,A,/))')
- & '(copy fitpar.dat into the working directory and/or',
- & ' request the missing parameter set via e-mail from',
- & ' eng@lepton.bartol.udel.edu)'
- STOP
- ENDIF
-
- 1300 CONTINUE
-
-C overwrite parameters with user settings
- IF(PARMDL(301).GT.DEFA) THEN
- ALPOM = PARMDL(301)
- PARMDL(301) = DEFB
- ENDIF
- IF(PARMDL(302).GT.DEFA) THEN
- ALPOMP = PARMDL(302)
- PARMDL(302) = DEFB
- ENDIF
- IF(PARMDL(303).GT.DEFA) THEN
- GP(1) = PARMDL(303)
- PARMDL(303) = DEFB
- ENDIF
- IF(PARMDL(304).GT.DEFA) THEN
- GP(2) = PARMDL(304)
- PARMDL(304) = DEFB
- ENDIF
- IF(PARMDL(305).GT.DEFA) THEN
- B0POM(1) = PARMDL(305)
- PARMDL(305) = DEFB
- ENDIF
- IF(PARMDL(306).GT.DEFA) THEN
- B0POM(2) = PARMDL(306)
- PARMDL(306) = DEFB
- ENDIF
- IF(PARMDL(307).GT.DEFA) THEN
- ALREG = PARMDL(307)
- PARMDL(307) = DEFB
- ENDIF
- IF(PARMDL(308).GT.DEFA) THEN
- ALREGP = PARMDL(308)
- PARMDL(308) = DEFB
- ENDIF
- IF(PARMDL(309).GT.DEFA) THEN
- GR(1) = PARMDL(309)
- PARMDL(309) = DEFB
- ENDIF
- IF(PARMDL(310).GT.DEFA) THEN
- GR(2) = PARMDL(310)
- PARMDL(310) = DEFB
- ENDIF
- IF(PARMDL(311).GT.DEFA) THEN
- B0REG(1) = PARMDL(311)
- PARMDL(311) = DEFB
- ENDIF
- IF(PARMDL(312).GT.DEFA) THEN
- B0REG(2) = PARMDL(312)
- PARMDL(312) = DEFB
- ENDIF
- IF(PARMDL(313).GT.DEFA) THEN
- GPPP = PARMDL(313)
- PARMDL(313) = DEFB
- ENDIF
- IF(PARMDL(314).GT.DEFA) THEN
- B0PPP = PARMDL(314)
- PARMDL(314)= DEFB
- ENDIF
- IF(PARMDL(315).GT.DEFA) THEN
- VDMFAC(1) = PARMDL(315)
- PARMDL(315)= DEFB
- ENDIF
- IF(PARMDL(316).GT.DEFA) THEN
- VDMFAC(2) = PARMDL(316)
- PARMDL(316)= DEFB
- ENDIF
- IF(PARMDL(317).GT.DEFA) THEN
- VDMFAC(3) = PARMDL(317)
- PARMDL(317)= DEFB
- ENDIF
- IF(PARMDL(318).GT.DEFA) THEN
- VDMFAC(4) = PARMDL(318)
- PARMDL(318)= DEFB
- ENDIF
- IF(PARMDL(319).GT.DEFA) THEN
- B0HAR = PARMDL(319)
- PARMDL(319)= DEFB
- ENDIF
- IF(PARMDL(320).GT.DEFA) THEN
- AKFAC = PARMDL(320)
- PARMDL(320)= DEFB
- ENDIF
- IF(PARMDL(321).GT.DEFA) THEN
- PHISUP(1) = PARMDL(321)
- PARMDL(321)= DEFB
- ENDIF
- IF(PARMDL(322).GT.DEFA) THEN
- PHISUP(2) = PARMDL(322)
- PARMDL(322)= DEFB
- ENDIF
- IF(PARMDL(323).GT.DEFA) THEN
- RMASS(1) = PARMDL(323)
- PARMDL(323)= DEFB
- ENDIF
- IF(PARMDL(324).GT.DEFA) THEN
- RMASS(2) = PARMDL(324)
- PARMDL(324)= DEFB
- ENDIF
- IF(PARMDL(325).GT.DEFA) THEN
- VAR = PARMDL(325)
- PARMDL(325)= DEFB
- ENDIF
- IF(PARMDL(327).GT.DEFA) THEN
- GPPR = PARMDL(327)
- PARMDL(327)= DEFB
- ENDIF
- IF(PARMDL(328).GT.DEFA) THEN
- B0PPR = PARMDL(328)
- PARMDL(328)= DEFB
- ENDIF
-
- VDMQ2F(1) = VDMFAC(1)
- VDMQ2F(2) = VDMFAC(2)
- VDMQ2F(3) = VDMFAC(3)
- VDMQ2F(4) = VDMFAC(4)
-
-C output of parameter set
-C *** Commented by Chiara
-C IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
-C WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
-C & ' -------------------------'
-C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
-C & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
-C & B0POM
-C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
-C & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
-C & B0REG
-C WRITE(LO,'(4(A,F7.3))')
-C & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
-C WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
-C WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
-C WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
-C WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
-C WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
-C WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
-C ENDIF
-
- CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
-
- END
-
-CDECK ID>, PHO_BORNCS
- SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
-C*********************************************************************
-C
-C calculation of Born graph cross sections and slopes
-C
-C input: IP particle combination
-C IFHARD -1 calculate hard Born graph cross section
-C 0 take hard Born graph cross section
-C from interpolation table if available
-C 1 assume that correct hard cross
-C sections are already stored in /POSBRN/
-C XM1,XM2,XM3,XM4 masses of external lines
-C /GLOCMS/ energy and PT cut-off
-C /POPREG/ soft and hard parameters
-C /POSBRN/ input cross sections
-C /POZBRN/ scaled input values
-C IFHARD 0 calculate hard input cross sections
-C 1 assume hard input cross sections exist
-C
-C output: ZPOM scaled pomeron cross section
-C ZIGR scaled reggeon cross section
-C ZIGHR scaled hard resolved cross section
-C ZIGHD scaled hard direct cross section
-C ZIGT1 scaled triple-Pomeron cross section
-C ZIGT2 scaled triple-Pomeron cross section
-C ZIGL scaled loop-Pomeron cross section
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(ITWO=2,
- & ITHREE=3,
- & IFOUR=4,
- & IFIVE=5,
- & FIVE=5.D0,
- & THOUS=1.D3,
- & EPS=0.01D0,
- & DEPS=1.D-30)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C interpolation tables for hard cross section and MC selection weights
- INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
- PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
- INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
- DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
- & HQ2a_tab,HQ2b_tab,HEcm_tab
- COMMON /POHTAB/
- & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
- & HEcm_tab(1:Max_tab_E,0:4),
- & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
-C Born graph cross sections and slopes
- INTEGER Max_pro_3
- PARAMETER ( Max_pro_3 = 16 )
- COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
- & SIGD1,SIGD2,DSIGH
- COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
- & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
-C scaled cross sections and slopes
- COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
- & ZIGD1,ZIGD2,
- & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
- COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
- & ZIGDP(4),ZIGD1(2),ZIGD2(2),
- & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
- & BD1(2),BD2(2)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-
- COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
- & BPOM1,BPOM2,BREG1,BREG2,B0HARD
- DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
- DIMENSION BT14(2),BT24(2),BD4(4)
- DIMENSION DSPT(0:Max_pro_2)
-
- DATA XMPOM / 0.766D0 /
- DATA CZERO /(0.D0,0.D0)/
-
- CDABS(SS) = ABS(SS)
- DCMPLX(X,Y) = CMPLX(X,Y)
-
-C debug output
- IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
- & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
-C scales
- CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
-C
-C calculate hard input cross sections (output in mb)
- IF(IFHARD.NE.1) THEN
- IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
-C double-log interpolation
- CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
- DO 60 M=0,Max_pro_2
- DSIGH(M) = HSig(M)
- DSPT(M) = Hdpt(M)
- 60 CONTINUE
- ELSE
-C new calculation
- CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
- CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
- ENDIF
-C
-C save values to calculate soft pt distribution
- IF(IP.EQ.1) THEN
- VDMQ2F(1) = VDMFAC(1)
- VDMQ2F(2) = VDMFAC(2)
- VDMQ2F(3) = VDMFAC(3)
- VDMQ2F(4) = VDMFAC(4)
- ELSE IF(IP.EQ.2) THEN
- VDMQ2F(1) = VDMFAC(1)
- VDMQ2F(2) = VDMFAC(2)
- VDMQ2F(3) = 1.D0
- VDMQ2F(4) = 0.D0
- ELSE IF(IP.EQ.3) THEN
- VDMQ2F(1) = VDMFAC(3)
- VDMQ2F(2) = VDMFAC(4)
- VDMQ2F(3) = 1.D0
- VDMQ2F(4) = 0.D0
- ELSE
- VDMQ2F(1) = 1.D0
- VDMQ2F(2) = 0.D0
- VDMQ2F(3) = 1.D0
- VDMQ2F(4) = 0.D0
- ENDIF
-C VDM factors
- AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
- AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
- AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
- AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
- ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
- & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
- ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
- ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
- ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
- VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
- & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
- DSIGHP = DSPT(9)/VFAC
- SIGH = DSIGH(9)/VFAC
-C extract real part
- IF(IPAMDL(1).EQ.0) THEN
- DO 50 I=0,Max_pro_2
- DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
- 50 CONTINUE
- ENDIF
-C write out results
- IF(IDEB(48).GE.15) THEN
- WRITE(LO,'(/1X,A,1P,2E11.3)')
- & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
- DO 200 I=0,Max_pro_2
- WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
- 200 CONTINUE
- ENDIF
- ENDIF
-
-C DPMJET interface: subtract anomalous part
- IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
- & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
-
- SCALE = CDABS(DSIGH(15))
- IF(SCALE.LT.DEPS) THEN
- SIGHD=CZERO
- ELSE
- SIGHD=DSIGH(15)
- ENDIF
- SCALE = CDABS(DSIGH(9))
- IF(SCALE.LT.DEPS) THEN
- SIGHR=CZERO
- ELSE
- SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
- ENDIF
-
-C calculate soft input cross sections (output in mb)
- SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
- IF(IPAMDL(1).EQ.1) THEN
-C pomeron signature
- SP=SS*DCMPLX(0.D0,-1.D0)
-C reggeon signature
- SR=SS*DCMPLX(0.D0,1.D0)
- ELSE
- SP=SS
- SR=SS
- ENDIF
-C coupling constants (mb**1/2)
-C particle dependent slopes (GeV**-2)
- IF(IP.EQ.1) THEN
- GP1 = GP(1)
- GP2 = GP(2)
- GR1 = GR(1)
- GR2 = GR(2)
- B0POM1 = B0POM(1)
- B0POM2 = B0POM(2)
- B0REG1 = B0REG(1)
- B0REG2 = B0REG(2)
- B0HARD = B0HAR
- RMASS1 = RMASS(1)
- RMASS2 = RMASS(2)
- ELSE IF(IP.EQ.2) THEN
- GP1 = GP(1)
- GP2 = PARMDL(77)
- GR1 = GR(1)
- GR2 = PARMDL(77)*GPPR/GPPP
- B0POM1 = B0POM(1)
- B0POM2 = B0PPP
- B0REG1 = B0REG(1)
- B0REG2 = B0PPR
- B0HARD = B0POM1+B0POM2
- RMASS1 = RMASS(1)
- RMASS2 = XMPOM
- ELSE IF(IP.EQ.3) THEN
- GP1 = GP(2)
- GP2 = PARMDL(77)
- GR1 = GR(2)
- GR2 = PARMDL(77)*GPPR/GPPP
- B0POM1 = B0POM(2)
- B0POM2 = B0PPP
- B0REG1 = B0REG(2)
- B0REG2 = B0PPR
- B0HARD = B0POM1+B0POM2
- RMASS1 = RMASS(2)
- RMASS2 = XMPOM
- ELSE IF(IP.EQ.4) THEN
- GP1 = PARMDL(77)
- GP2 = GP1
- GR1 = PARMDL(77)*GPPR/GPPP
- GR2 = GR1
- B0POM1 = B0PPP
- B0POM2 = B0PPP
- B0REG1 = B0PPR
- B0REG2 = B0PPR
- B0HARD = B0POM1+B0POM2
- RMASS1 = XMPOM
- RMASS2 = XMPOM
- ELSE
- WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
- CALL PHO_ABORT
- ENDIF
- GP1 = GP1*SCALE1
- GP2 = GP2*SCALE2
- GR1 = GR1*SCALE1
- GR2 = GR2*SCALE2
-C input slope parameters (GeV**-2)
- BPOM1 = B0POM1*SCALB1
- BPOM2 = B0POM2*SCALB2
- BREG1 = B0REG1*SCALB1
- BREG2 = B0REG2*SCALB2
-C effective slopes
- XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
- SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
- BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
- BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
- IF(IPAMDL(9).EQ.0) THEN
- BHAR = B0HARD
- BHAD = B0HARD
- ELSE IF(IPAMDL(9).EQ.1) THEN
- BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
- BHAD = BHAR
- ELSE IF(IPAMDL(9).EQ.2) THEN
- BHAR = BPOM1+BPOM2
- BHAD = BHAR
- ELSE
- BHAR = BPOM
- BHAD = BPOM
- ENDIF
-C input cross section pomeron
- SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
- SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
-C save value to calculate soft pt distribution
- SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
-
-C higher order graphs
- VIRT1 = PVIRTP(1)
- VIRT2 = PVIRTP(2)
-C bare/renormalized intercept for enhanced graphs
- IF(IPAMDL(8).EQ.0) THEN
- DELTAP = ALPOM-1.D0
- ELSE
- DELTAP = PARMDL(48)-1.D0
- ENDIF
- SD = ECMP**2
- BP1 = 2.D0*BPOM1
- BP2 = 2.D0*BPOM2
-C input cross section high-mass double diffraction
- CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
- & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
- SIGL = DCMPLX(SIGTR,0.D0)
- BLOO = DCMPLX(BTR,0.D0)
-C
-C input cross section high mass diffraction particle 1
-C first possibility
- CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- SCALB1 = (SCB1(1)+SCB1(2))/2.D0
- SCALB2 = (SCB2(1)+SCB2(2))/2.D0
- BP1 = 2.D0*BPOM1*SCALB1
- BP2 = 2.D0*BPOM2*SCALB2
-C input cross section high mass diffraction
- CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
- & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
- SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
- BTR1(1) = DCMPLX(BTR,0.D0)
-C second possibility: high-low mass double diffraction
- CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- SCALB1 = (SCB1(1)+SCB1(2))/2.D0
- SCALB2 = (SCB2(1)+SCB2(2))/2.D0
- BP1 = 2.D0*BPOM1*SCALB1
- BP2 = 2.D0*BPOM2*SCALB2
-C input cross section high mass diffraction
- CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
- & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
- SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
- BTR1(2) = DCMPLX(BTR,0.D0)
-C
-C input cross section high mass diffraction particle 2
-C first possibility
- CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- SCALB1 = (SCB1(1)+SCB1(2))/2.D0
- SCALB2 = (SCB2(1)+SCB2(2))/2.D0
- BP1 = 2.D0*BPOM1*SCALB1
- BP2 = 2.D0*BPOM2*SCALB2
-C input cross section high mass diffraction
- CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
- & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
- SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
- BTR2(1) = DCMPLX(BTR,0.D0)
-C second possibility: high-low mass double diffraction
- CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- SCALB1 = (SCB1(1)+SCB1(2))/2.D0
- SCALB2 = (SCB2(1)+SCB2(2))/2.D0
- BP1 = 2.D0*BPOM1*SCALB1
- BP2 = 2.D0*BPOM2*SCALB2
-C input cross section high mass diffraction
- CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
- & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
- SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
- BTR2(2) = DCMPLX(BTR,0.D0)
-C
-C input cross section for loop-pomeron
-C first possibility
- CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
- & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
- CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
- & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
- SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
- SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
- BP1 = BPOM1*SCALB1
- BP2 = BPOM2*SCALB2
- CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
- & SIGTX,BTX)
- SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
- BDP(1) = DCMPLX(BTX,0.D0)
-C second possibility
- CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
- & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
- CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
- & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
- SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
- SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
- BP1 = BPOM1*SCALB1
- BP2 = BPOM2*SCALB2
- CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
- & SIGTX,BTX)
- SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
- BDP(2) = DCMPLX(BTX,0.D0)
-C third possibility
- CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
- & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
- CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
- & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
- SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
- SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
- BP1 = BPOM1*SCALB1
- BP2 = BPOM2*SCALB2
- CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
- & SIGTX,BTX)
- SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
- BDP(3) = DCMPLX(BTX,0.D0)
-C fourth possibility
- CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
- & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
- CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
- & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
- CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
- & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
- CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
- & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
- SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
- SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
- BP1 = BPOM1*SCALB1
- BP2 = BPOM2*SCALB2
- CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
- & SIGTX,BTX)
- SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
- BDP(4) = DCMPLX(BTX,0.D0)
-C
-C input cross section for YY-iterated triple-pomeron
-C .....
-C
-C write out input cross sections
- IF(IDEB(48).GE.5) THEN
- WRITE(LO,'(2(/1X,A))')
- & 'Born graph input cross sections and slopes',
- & '------------------------------------------'
- WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
- WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
- & XM1,XM2,XM3,XM4
- WRITE(LO,'(A)') ' input cross sections (millibarn):'
- WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
- WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
- WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
- WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
- WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
- WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
- WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
- WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
- WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
- WRITE(LO,'(A)') ' input slopes (GeV**-2)'
- WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
- WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
- WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
- WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
- WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
- WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
- WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
- WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
- WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
- WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
- WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
- WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
- WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
- WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
- ENDIF
-C
- BPOM = BPOM*GEV2MB
- BREG = BREG*GEV2MB
- BHAR = BHAR*GEV2MB
- BHAD = BHAD*GEV2MB
- BTR1(1) = BTR1(1)*GEV2MB
- BTR1(2) = BTR1(2)*GEV2MB
- BTR2(1) = BTR2(1)*GEV2MB
- BTR2(2) = BTR2(2)*GEV2MB
- BLOO = BLOO*GEV2MB
-C
- BP4 =BPOM*4.D0
- BR4 =BREG*4.D0
- BHR4=BHAR*4.D0
- BHD4=BHAD*4.D0
- BT14(1)=BTR1(1)*4.D0
- BT14(2)=BTR1(2)*4.D0
- BT24(1)=BTR2(1)*4.D0
- BT24(2)=BTR2(2)*4.D0
- BL4 =BLOO*4.D0
-C
- ZIGP = SIGP/(PI2*BP4)
- ZIGR = SIGR/(PI2*BR4)
- ZIGHR = SIGHR/(PI2*BHR4)
- ZIGHD = SIGHD/(PI2*BHD4)
- ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
- ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
- ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
- ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
- ZIGL = SIGL/(PI2*BL4)
- DO 20 I=1,4
- BDP(I) = BDP(I)*GEV2MB
- BD4(I) = BDP(I)*4.D0
- ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
- 20 CONTINUE
-C
- IF(IDEB(48).GE.10) THEN
- WRITE(LO,'(A)') ' normalized input values:'
- WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
- WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
- WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
- WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
- WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
- WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
- WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
- WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
- WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
- WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
- WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
- WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
- WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
- ENDIF
- END
-
-CDECK ID>, PHO_SCALES
- SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
-C**********************************************************************
-C
-C calculation of scale factors
-C (mass dependent couplings and slopes)
-C
-C input: XM1..XM4 external masses
-C
-C output: SCG1,SCG2 scales of coupling constants
-C SCB1,SCB2 scales of coupling slope parameter
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-3 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C scale factors for couplings
- ECMMIN = 2.D0
-* ECMTP = 6.D0
- ECMTP = 1.D0
- IF(ABS(XM1-XM3).GT.EPS) THEN
- IF(ECMP.LT.ECMTP) THEN
- SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
- ELSE
- SCG1 = PHISUP(1)
- ENDIF
- ELSE
- SCG1 = 1.D0
- ENDIF
- IF(ABS(XM2-XM4).GT.EPS) THEN
- IF(ECMP.LT.ECMTP) THEN
- SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
- ELSE
- SCG2 = PHISUP(2)
- ENDIF
- ELSE
- SCG2 = 1.D0
- ENDIF
-C
-C scale factors for slope parameters
- IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
- SCB1 = 1.D0
- SCB2 = 1.D0
- ELSE IF(ISWMDL(1).EQ.2) THEN
-C rational
- SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
- SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
- ELSE IF(ISWMDL(1).GE.3) THEN
-C symmetric gaussian
- SCB1 = VAR*(XM1-XM3)**2
- IF(SCB1.LT.25.D0) THEN
- SCB1 = EXP(-SCB1)
- ELSE
- SCB1 = 0.D0
- ENDIF
- SCB2 = VAR*(XM2-XM4)**2
- IF(SCB2.LT.25.D0) THEN
- SCB2 = EXP(-SCB2)
- ELSE
- SCB2 = 0.D0
- ENDIF
- ELSE
- WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
- & ISWMDL(1)
- CALL PHO_ABORT
- ENDIF
-C debug output
- IF(IDEB(65).GE.10) THEN
- WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
- & XM1,XM2,XM3,XM4
- WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
- & SCB1,SCB2,SCG1,SCG2
- ENDIF
- END
-
-CDECK ID>, PHO_EIKON
- SUBROUTINE PHO_EIKON(IP,IFHARD,B)
-C*********************************************************************
-C
-C calculation of unitarized amplitudes
-C
-C input: IP particle combination
-C IFHARD -1 ignore previously calculated Born
-C cross sections
-C 0 calculate hard Born cross sections or
-C take them from interpolation table
-C (if available)
-C 1 take hard cross sections from /POSBRN/
-C B impact parameter (mb**(1/2))
-C /POSBRN/ input cross sections
-C /GLOCMS/ cm energy
-C /POPREG/ soft and hard parameters
-C
-C output: /POINT4/
-C AMPEL purely elastic amplitude
-C AMPVM quasi-elastically vectormeson prod.
-C AMLMSD(2) amplitudes of low mass sing. diffr.
-C AMHMSD(2) amplitudes of high mass sing. diffr.
-C AMLMDD amplitude of low mass double diffr.
-C AMHMDD amplitude of high mass double diffr.
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(ITWO=2,
- & ITHREE=3,
- & IFOUR=4,
- & IFIVE=5,
- & ISIX=6,
- & FIVE=5.D0,
- & THOUS=1.D3,
- & EXPMAX=70.D0,
- & DEPS=1.D-20)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C complex Born graph amplitudes used for unitarization
- COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
- & AMHMDD,AMPDP
- COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
- & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C Born graph cross sections and slopes
- INTEGER Max_pro_3
- PARAMETER ( Max_pro_3 = 16 )
- COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
- & SIGD1,SIGD2,DSIGH
- COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
- & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
-C scaled cross sections and slopes
- COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
- & ZIGD1,ZIGD2,
- & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
- COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
- & ZIGDP(4),ZIGD1(2),ZIGD2(2),
- & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
- & BD1(2),BD2(2)
-C Born graph cross sections after applying diffraction model
- DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
- & SBOLPO,SBODPO
- COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
- & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
- & SBODPO(0:4,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C unitarized amplitudes for different diffraction channels
- DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
- & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
- & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
- & ZXL,BXL
- COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
- & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
- & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
- & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
- & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
- & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
- & ZXL(4,4),BXL(4,4)
-
- COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
- & AUXL,AMPR,AMPO,AMPP,AMPQ
-
- DIMENSION PVOLD(2)
-
- DATA ELAST / 0.D0 /
- DATA IPOLD / -1 /
- DATA PVOLD / -1.D0, -1.D0 /
- DATA XMPOM / 0.766D0 /
- DATA XMVDM / 0.766D0 /
-
- DCMPLX(X,Y) = CMPLX(X,Y)
-
-C calculation of scaled cross sections and slopes
-
-C test for redundant calculation
- IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
- & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
-C effective particle masses, VDM assumption
- XMASS1 = PMASS(1)
- XMASS2 = PMASS(2)
- RMASS1 = RMASS(1)
- RMASS2 = RMASS(2)
- IF(IFPAP(1).EQ.22) THEN
- XMASS1 = XMVDM
- ELSE IF(IFPAP(1).EQ.990) THEN
- XMASS1 = XMPOM
- ENDIF
- IF(IFPAP(2).EQ.22) THEN
- XMASS2 = XMVDM
- ELSE IF(IFPAP(2).EQ.990) THEN
- XMASS2 = XMPOM
- ENDIF
-C different particle combinations
- IF(IP.EQ.3) THEN
- XMASS1 = XMASS2
- RMASS1 = RMASS2
- ELSE IF(IP.EQ.4) THEN
- XMASS1 = XMPOM
- RMASS1 = XMASS1
- ENDIF
- IF(IP.GT.1) THEN
- XMASS2 = XMPOM
- RMASS2 = XMASS2
- ENDIF
-C update pomeron CM system
- PMASSP(1) = XMASS1
- PMASSP(2) = XMASS2
- ECMP = ECM
-
- CZERO = DCMPLX(0.D0,0.D0)
- CONE = DCMPLX(1.D0,0.D0)
- ELAST = ECM
- PVOLD(1) = PVIRT(1)
- PVOLD(2) = PVIRT(2)
- IPOLD = IP
-
-C purely elastic scattering
- CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
- ZXP(1,1) = ZIGP
- BXP(1,1) = BPOM
- ZXR(1,1) = ZIGR
- BXR(1,1) = BREG
- ZXH(1,1) = ZIGHR
- BXH(1,1) = BHAR
- ZXD(1,1) = ZIGHD
- BXD(1,1) = BHAD
- ZXT1A(1,1) = ZIGT1(1)
- BXT1A(1,1) = BTR1(1)
- ZXT1B(1,1) = ZIGT1(2)
- BXT1B(1,1) = BTR1(2)
- ZXT2A(1,1) = ZIGT2(1)
- BXT2A(1,1) = BTR2(1)
- ZXT2B(1,1) = ZIGT2(2)
- BXT2B(1,1) = BTR2(2)
- ZXL(1,1) = ZIGL
- BXL(1,1) = BLOO
- ZXDPE(1,1) = ZIGDP(1)
- BXDPE(1,1) = BDP(1)
- ZXDPA(1,1) = ZIGDP(2)
- BXDPA(1,1) = BDP(2)
- ZXDPB(1,1) = ZIGDP(3)
- BXDPB(1,1) = BDP(3)
- ZXDPD(1,1) = ZIGDP(4)
- BXDPD(1,1) = BDP(4)
- SBOPOM(1) = SIGP
- SBOREG(1) = SIGR
- SBOHAR(1) = SIGHR
- SBOHAD(1) = SIGHD
- SBOTR1(1,1) = SIGT1(1)
- SBOTR1(1,2) = SIGT1(2)
- SBOTR2(1,1) = SIGT2(1)
- SBOTR2(1,2) = SIGT2(2)
- SBOLPO(1) = SIGL
- SBODPO(1,1) = SIGDP(1)
- SBODPO(1,2) = SIGDP(2)
- SBODPO(1,3) = SIGDP(3)
- SBODPO(1,4) = SIGDP(4)
-
-C low mass single diffractive scattering 1
- CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
- ZXP(1,2) = ZIGP
- BXP(1,2) = BPOM
- ZXR(1,2) = ZIGR
- BXR(1,2) = BREG
- ZXH(1,2) = ZIGHR
- BXH(1,2) = BHAR
- ZXD(1,2) = ZIGHD
- BXD(1,2) = BHAD
- ZXT1A(1,2) = ZIGT1(1)
- BXT1A(1,2) = BTR1(1)
- ZXT1B(1,2) = ZIGT1(2)
- BXT1B(1,2) = BTR1(2)
- ZXT2A(1,2) = ZIGT2(1)
- BXT2A(1,2) = BTR2(1)
- ZXT2B(1,2) = ZIGT2(2)
- BXT2B(1,2) = BTR2(2)
- ZXL(1,2) = ZIGL
- BXL(1,2) = BLOO
- ZXDPE(1,2) = ZIGDP(1)
- BXDPE(1,2) = BDP(1)
- ZXDPA(1,2) = ZIGDP(2)
- BXDPA(1,2) = BDP(2)
- ZXDPB(1,2) = ZIGDP(3)
- BXDPB(1,2) = BDP(3)
- ZXDPD(1,2) = ZIGDP(4)
- BXDPD(1,2) = BDP(4)
- SBOPOM(2) = SIGP
- SBOREG(2) = SIGR
- SBOHAR(2) = SIGHR
- SBOHAD(2) = 0.D0
- SBOTR1(2,1) = SIGT1(1)
- SBOTR1(2,2) = SIGT1(2)
- SBOTR2(2,1) = SIGT2(1)
- SBOTR2(2,2) = SIGT2(2)
- SBOLPO(2) = SIGL
- SBODPO(2,1) = SIGDP(1)
- SBODPO(2,2) = SIGDP(2)
- SBODPO(2,3) = SIGDP(3)
- SBODPO(2,4) = SIGDP(4)
-
-C low mass single diffractive scattering 2
- CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
- ZXP(1,3) = ZIGP
- BXP(1,3) = BPOM
- ZXR(1,3) = ZIGR
- BXR(1,3) = BREG
- ZXH(1,3) = ZIGHR
- BXH(1,3) = BHAR
- ZXD(1,3) = ZIGHD
- BXD(1,3) = BHAD
- ZXT1A(1,3) = ZIGT1(1)
- BXT1A(1,3) = BTR1(1)
- ZXT1B(1,3) = ZIGT1(2)
- BXT1B(1,3) = BTR1(2)
- ZXT2A(1,3) = ZIGT2(1)
- BXT2A(1,3) = BTR2(1)
- ZXT2B(1,3) = ZIGT2(2)
- BXT2B(1,3) = BTR2(2)
- ZXL(1,3) = ZIGL
- BXL(1,3) = BLOO
- ZXDPE(1,3) = ZIGDP(1)
- BXDPE(1,3) = BDP(1)
- ZXDPA(1,3) = ZIGDP(2)
- BXDPA(1,3) = BDP(2)
- ZXDPB(1,3) = ZIGDP(3)
- BXDPB(1,3) = BDP(3)
- ZXDPD(1,3) = ZIGDP(4)
- BXDPD(1,3) = BDP(4)
- SBOPOM(3) = SIGP
- SBOREG(3) = SIGR
- SBOHAR(3) = SIGHR
- SBOHAD(3) = 0.D0
- SBOTR1(3,1) = SIGT1(1)
- SBOTR1(3,2) = SIGT1(2)
- SBOTR2(3,1) = SIGT2(1)
- SBOTR2(3,2) = SIGT2(2)
- SBOLPO(3) = SIGL
- SBODPO(3,1) = SIGDP(1)
- SBODPO(3,2) = SIGDP(2)
- SBODPO(3,3) = SIGDP(3)
- SBODPO(3,4) = SIGDP(4)
-
-C low mass double diffractive scattering
- CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
- ZXP(1,4) = ZIGP
- BXP(1,4) = BPOM
- ZXR(1,4) = ZIGR
- BXR(1,4) = BREG
- ZXH(1,4) = ZIGHR
- BXH(1,4) = BHAR
- ZXD(1,4) = ZIGHD
- BXD(1,4) = BHAD
- ZXT1A(1,4) = ZIGT1(1)
- BXT1A(1,4) = BTR1(1)
- ZXT1B(1,4) = ZIGT1(2)
- BXT1B(1,4) = BTR1(2)
- ZXT2A(1,4) = ZIGT2(1)
- BXT2A(1,4) = BTR2(1)
- ZXT2B(1,4) = ZIGT2(2)
- BXT2B(1,4) = BTR2(2)
- ZXL(1,4) = ZIGL
- BXL(1,4) = BLOO
- ZXDPE(1,4) = ZIGDP(1)
- BXDPE(1,4) = BDP(1)
- ZXDPA(1,4) = ZIGDP(2)
- BXDPA(1,4) = BDP(2)
- ZXDPB(1,4) = ZIGDP(3)
- BXDPB(1,4) = BDP(3)
- ZXDPD(1,4) = ZIGDP(4)
- BXDPD(1,4) = BDP(4)
- SBOPOM(4) = SIGP
- SBOREG(4) = SIGR
- SBOHAR(4) = SIGHR
- SBOHAD(4) = 0.D0
- SBOTR1(4,1) = SIGT1(1)
- SBOTR1(4,2) = SIGT1(2)
- SBOTR2(4,1) = SIGT2(1)
- SBOTR2(4,2) = SIGT2(2)
- SBOLPO(4) = SIGL
- SBODPO(4,1) = SIGDP(1)
- SBODPO(4,2) = SIGDP(2)
- SBODPO(4,3) = SIGDP(3)
- SBODPO(4,4) = SIGDP(4)
-
-C calculate Born graph cross sections
- SBOPOM(0) = 0.D0
- SBOREG(0) = 0.D0
- SBOHAR(0) = 0.D0
- SBOHAD(0) = 0.D0
- SBOTR1(0,1) = 0.D0
- SBOTR1(0,2) = 0.D0
- SBOTR2(0,1) = 0.D0
- SBOTR2(0,2) = 0.D0
- SBOLPO(0) = 0.D0
- SBODPO(0,1) = 0.D0
- SBODPO(0,2) = 0.D0
- SBODPO(0,3) = 0.D0
- SBODPO(0,4) = 0.D0
- DO 150 I=1,4
- SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
- SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
- SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
- SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
- SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
- SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
- SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
- SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
- SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
- SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
- SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
- SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
- SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
- 150 CONTINUE
-
- SIGPOM = SBOPOM(0)
- SIGREG = SBOREG(0)
- SIGTR1(1) = SBOTR1(0,1)
- SIGTR1(2) = SBOTR1(0,2)
- SIGTR2(1) = SBOTR2(0,1)
- SIGTR2(2) = SBOTR2(0,2)
- SIGLOO = SBOLPO(0)
- SIGDPO(1) = SBODPO(0,1)
- SIGDPO(2) = SBODPO(0,2)
- SIGDPO(3) = SBODPO(0,3)
- SIGDPO(4) = SBODPO(0,4)
- SIGHAR = SBOHAR(0)
- SIGDIR = SBOHAD(0)
- ENDIF
-
- B24=DCMPLX(B**2,0.D0)/4.D0
-
- AMPEL = CZERO
- AMPR = CZERO
- AMPO = CZERO
- AMPP = CZERO
- AMPQ = CZERO
- AMLMSD(1) = CZERO
- AMLMSD(2) = CZERO
- AMHMSD(1) = CZERO
- AMHMSD(2) = CZERO
- AMLMDD = CZERO
- AMHMDD = CZERO
-
-C different models
-
- IF(ISWMDL(1).LT.3) THEN
-C pomeron
- AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
-C reggeon
- AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
-C hard resolved processes
- AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
-C hard direct processes
- AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
-C triple-Pomeron: baryon high mass diffraction
- AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
- & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
-C triple-Pomeron: photon/meson high mass diffraction
- AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
- & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
-C loop-Pomeron
- AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
- ENDIF
-
- IF(ISWMDL(1).EQ.0) THEN
- AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
- & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
- & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
- & )
- AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
- & +AUXT1+AUXT2+AUXL))
- AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
- & +AUXT1+AUXT2+AUXL))
- AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
- & +AUXT1+AUXT2+AUXL))
- AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
- & +AUXT1+AUXT2+AUXL))
-
- ELSE IF(ISWMDL(1).EQ.1) THEN
- AMPR = 0.5D0*SQRT(VDMQ2F(1))*
- & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
- AMPO = 0.5D0*SQRT(VDMQ2F(2))*
- & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
- AMPP = 0.5D0*SQRT(VDMQ2F(3))*
- & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
- AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
- & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
- AMPEL = SQRT(VDMQ2F(1))*AMPR
- & + SQRT(VDMQ2F(2))*AMPO
- & + SQRT(VDMQ2F(3))*AMPP
- & + SQRT(VDMQ2F(4))*AMPQ
- & + AUXD/2.D0
-
-C simple analytic two channel model (version A)
- ELSE IF(ISWMDL(1).EQ.3) THEN
- CALL PHO_CHAN2A(B)
-
- ELSE
- WRITE(LO,'(1X,A,I2)')
- & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
- STOP
- ENDIF
-
- END
-
-CDECK ID>, PHO_DSIGDT
- SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
-C*********************************************************************
-C
-C calculation of unitarized amplitude
-C and differential cross section
-C
-C input: EE cm energy (GeV)
-C XTA(1,*) t values (GeV**2)
-C NFILL entries in t table
-C
-C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
-C XTA(3,*) DSIG/DT g p --> rho0 h/V
-C XTA(4,*) DSIG/DT g p --> omega0 h/V
-C XTA(5,*) DSIG/DT g p --> phi h/V
-C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(ITWO=2,
- & ITHREE=3,
- & THOUS=1.D3,
- & DEPS=1.D-20)
-
- DIMENSION XTA(6,NFILL)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C complex Born graph amplitudes used for unitarization
- COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
- & AMHMDD,AMPDP
- COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
- & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
-
- COMPLEX*16 XT,AMP,CZERO
- DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
- CHARACTER*12 FNA
-
- CDABS(AMPEL) = ABS(AMPEL)
- DCMPLX(X,Y) = CMPLX(X,Y)
-
- CZERO=DCMPLX(0.D0,0.D0)
-
- ETMP = ECM
- ECM = EE
-
- IF(NFILL.GT.100) THEN
- WRITE(LO,'(1X,A,I4)')
- & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
- STOP
- ENDIF
-C
- DO 100 K=1,NFILL
- DO 150 L=1,5
- XT(L,K)=CZERO
- 150 CONTINUE
- 100 CONTINUE
-C
-C impact parameter integration
-C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
- BMAX=10.D0
- CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
- IAMP = 5
- IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
- I1 = 1
- I2 = 0
- ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
- I1 = 0
- I2 = 1
- ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
- I1 = 1
- I2 = 1
- ELSE
- I1 = 0
- I2 = 0
- IAMP = 1
- ENDIF
- J1 = I1*2
- K1 = I1*3
- L1 = I1*4
- J2 = I2*2
- K2 = I2*3
- L2 = I2*4
-C
- DO 200 I=1,NGAUSO
- WG=WGHT(I)*XPNT(I)
-C calculate amplitudes
- IF(I.EQ.1) THEN
- CALL PHO_EIKON(1,-1,XPNT(I))
- ELSE
- CALL PHO_EIKON(1,1,XPNT(I))
- ENDIF
- AMP(1) = AMPEL
- AMP(2) = AMPVM(I1,I2)
- AMP(3) = AMPVM(J1,J2)
- AMP(4) = AMPVM(K1,K2)
- AMP(5) = AMPVM(L1,L2)
-C
- DO 400 J=1,NFILL
- XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
- FAC = PHO_BESSJ0(XX)*WG
- DO 500 K=1,IAMP
- XT(1,J)=XT(1,J)+AMP(K)*FAC
- 500 CONTINUE
- 400 CONTINUE
- 200 CONTINUE
-C
-C change units to mb/GeV**2
- FAC = 4.D0*PI/GEV2MB
- FNA = '(mb/GeV**2) '
- IF(I1+I2.EQ.1) THEN
- FAC = FAC*THOUS
- FNA = '(mub/GeV**2)'
- ELSE IF(I1+I2.EQ.2) THEN
- FAC = FAC*THOUS*THOUS
- FNA = '(nb/GeV**2) '
- ENDIF
- IF(IDEB(56).GE.5) THEN
- WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
- & FNA,'------------------------------------------'
- ENDIF
- DO 600 J=1,NFILL
- DO 700 K=1,IAMP
- XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
- 700 CONTINUE
- IF(IDEB(56).GE.5) THEN
- WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
- ENDIF
- 600 CONTINUE
-
- ECM = ETMP
- END
-
-CDECK ID>, PHO_XSECT
- SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
-C*********************************************************************
-C
-C calculation of physical cross sections
-C
-C input: IP particle combination
-C IFHARD -1 reset Born graph cross section tables
-C 0 calculate hard cross sections or take them
-C from interpolation table (if available)
-C 1 assume that hard cross sections are already
-C calculated and stored in /POSBRN/
-C EE cms energy (GeV)
-C
-C output: /POSBRN/ input cross sections
-C /POZBRN/ scaled input cross values
-C /POCSEC/ physical cross sections and slopes
-C
-C slopes in GeV**-2, cross sections in mb
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(ONEM=-1.D0,
- & THOUS=1.D3,
- & DEPS=1.D-20)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C Born graph cross sections and slopes
- INTEGER Max_pro_3
- PARAMETER ( Max_pro_3 = 16 )
- COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
- & SIGD1,SIGD2,DSIGH
- COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
- & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-
- CHARACTER*15 PHO_PNAME
-
-C complex Born graph amplitudes used for unitarization
- COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
- & AMHMDD,AMPDP
- COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
- & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
-
- DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
- CHARACTER*8 VMESA(0:4),VMESB(0:4)
- DATA VMESA / 'vmeson ','rho ','omega ','phi ',
- & 'pi+pi- ' /
- DATA VMESB / 'vmeson ','rho ','omega ','phi ',
- & 'pi+pi- ' /
-
- CDABS(AMPEL) = ABS(AMPEL)
-
- ETMP = ECM
- IF(EE.LT.0.D0) GOTO 500
- ECM = EE
-
-C impact parameter integration
-C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
- BMAX=10.D0
- CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
- SIGTOT = 0.D0
- SIGINE = 0.D0
- SIGELA = 0.D0
- SIGNDF = 0.D0
- SIGLSD(1) = 0.D0
- SIGLSD(2) = 0.D0
- SIGLDD = 0.D0
- SIGHSD(1) = 0.D0
- SIGHSD(2) = 0.D0
- SIGHDD = 0.D0
- SIGCDF(0) = 0.D0
- SIG1SO = 0.D0
- SIG1HA = 0.D0
- SLEL1 = 0.D0
- SLEL2 = 0.D0
- DO 50 I=1,4
- SIGCDF(I) = 0.D0
- DO 55 K=1,4
- SIGVM(I,K) = 0.D0
- SLVM1(I,K) = 0.D0
- SLVM2(I,K) = 0.D0
- 55 CONTINUE
- 50 CONTINUE
-
- DO 100 I=1,NGAUSO
- B2 = XPNT(I)**2
- WG = WGHT(I)*XPNT(I)
- WGB = B2*WG
-
-C calculate impact parameter amplitude, results in /POINT4/
- IF(I.EQ.1) THEN
- CALL PHO_EIKON(IP,IFHARD,XPNT(I))
- ELSE
- CALL PHO_EIKON(IP,1,XPNT(I))
- ENDIF
-
- SIGTOT = SIGTOT + DREAL(AMPEL)*WG
- SIGELA = SIGELA + CDABS(AMPEL)**2*WG
- SLEL1 = SLEL1 + AMPEL*WGB
- SLEL2 = SLEL2 + AMPEL*WG
-
- DO 110 J=1,4
- DO 120 K=1,4
- SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
- SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
- SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
- 120 CONTINUE
- SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
- 110 CONTINUE
-
- SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
- SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
- SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
- SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
- SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
- SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
- SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
- SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
-
- 100 CONTINUE
-
- SIGDIR = DREAL(SIGHD)
- FAC = 4.D0*PI2
- SIGTOT = SIGTOT*FAC
- SIGELA = SIGELA*FAC
- FACSL = 0.5D0/GEV2MB
- SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
-
- IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
- DO 130 I=1,4
- DO 140 J=1,4
- SIGVM(I,J) = SIGVM(I,J)*FAC
- SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
- 140 CONTINUE
- 130 CONTINUE
- SIGVM(0,0) = 0.D0
- DO 150 I=1,4
- SIGVM(0,I) = 0.D0
- SIGVM(I,0) = 0.D0
- DO 160 J=1,4
- SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
- SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
- 160 CONTINUE
- SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
- 150 CONTINUE
- ENDIF
-
-C diffractive cross sections
-
- SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
- SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
- SIGLDD = SIGLDD *FAC*PARMDL(42)
- SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
- SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
- SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
- & *FAC*PARMDL(42)
-
-C double pomeron scattering
-
- SIGCDF(0) = 0.D0
- DO 170 I=1,4
- SIGCDF(I) = SIGCDF(I)*FAC
- SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
- 170 CONTINUE
-
- SIG1SO = SIG1SO *FAC
- SIG1HA = SIG1HA *FAC
-
- SIGINE = SIGTOT - SIGELA
-
-C user-forced change of diffractive cross section
-
- IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
-
-C use optional explicit parametrization for single-diffraction
-
- SIGSD1 = SIGLSD(1)+SIGHSD(1)
- SIGSD2 = SIGLSD(2)+SIGHSD(2)
- SS = EE*EE
- XI_MIN = 1.5D0/SS
- XI_MAX = PARMDL(45)**2
- CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
- & SIG_SD1,SIG_SD2,SIG_DD)
- SIG_SD1 = SIG_SD1*PARMDL(40)
- SIG_SD2 = SIG_SD2*PARMDL(41)
-
-**sr
-C DEL_SD1 = SIG_SD1-SIGSD1
- DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
-**
-
- FAC = SIGLSD(1)/SIGSD1
- SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
- SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
-
-C DEL_SD2 = SIG_SD2-SIGSD2
- DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
-
- FAC = SIGLSD(2)/SIGSD2
- SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
- SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
-
- IF(ISWMDL(30).GE.2) THEN
-
-C use explicit parametrization also for double diffraction diss.
- SIGDD = SIGLDD+SIGHDD
- SIG_DD = SIG_DD*PARMDL(42)
- DEL_DD = SIG_DD-SIGDD
- FAC = SIGLDD/SIGDD
- SIGLDD = SIGLDD+FAC*DEL_DD
- SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
- SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
-
- ELSE
-
-C rescale double diffraction cross sections
- SIGLDD = SIGLDD *PARMDL(42)
- SIGHDD = SIGHDD *PARMDL(42)
- SIGCOR = DEL_SD1 + DEL_SD2
- & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
-
- ENDIF
-
- ELSE
-
-C rescale unitarized cross sections for diffraction dissociation
-
- SIGLSD(1) = SIGLSD(1)*PARMDL(40)
- SIGHSD(1) = SIGHSD(1)*PARMDL(40)
- SIGLSD(2) = SIGLSD(2)*PARMDL(41)
- SIGHSD(2) = SIGHSD(2)*PARMDL(41)
- SIGLDD = SIGLDD *PARMDL(42)
- SIGHDD = SIGHDD *PARMDL(42)
- SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
- & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
- & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
-
- ENDIF
-
-C non-diffractive inelastic cross section
-
- SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
- & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
- & -SIGLDD-SIGHDD
-
-C specify elastic scattering channel
-
- 500 CONTINUE
- IF(IFPAP(1).NE.22) THEN
- VMESA(1) = PHO_PNAME(IFPAB(1),0)
- ELSE
- VMESA(1) = 'rho '
- ENDIF
- IF(IFPAP(2).NE.22) THEN
- VMESB(1) = PHO_PNAME(IFPAB(2),0)
- ELSE
- VMESB(1) = 'rho '
- ENDIF
-
-C write out physical cross sections
-
- IF(IDEB(57).GE.5) THEN
- WRITE(LO,'(/1X,A,I3,/1X,A)')
- & 'PHO_XSECT: cross sections (mb) for combination',IP,
- & '----------------------------------------------'
- WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
- WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
- WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
- WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
- WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
- & SIGLSD(1)+SIGHSD(1)
- IF(IDEB(57).GE.7) THEN
- WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
- WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
- ENDIF
- WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
- & SIGLSD(2)+SIGHSD(2)
- IF(IDEB(57).GE.7) THEN
- WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
- WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
- ENDIF
- WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
- IF(IDEB(57).GE.7) THEN
- WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
- WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
- ENDIF
- WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
- IF(IDEB(57).GE.7) THEN
- WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
- WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
- WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
- WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
- ENDIF
- WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
- DO 200 I=1,4
- DO 210 J=1,4
- IF(SIGVM(I,J).GT.DEPS) THEN
- WRITE(LO,'(1X,3A)') 'q-elastic production of ',
- & VMESA(I),VMESB(J)
- WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
- IF((I.NE.0).AND.(J.NE.0))
- & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
- ENDIF
- 210 CONTINUE
- 200 CONTINUE
- IF(IDEB(57).GE.7) THEN
- WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
- WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
- WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
- WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
- WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
- WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
- WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
- & DREAL(DSIGH(15))
- ENDIF
- ENDIF
-
- ECM = ETMP
-
- END
-
-CDECK ID>, PHO_IMPAMP
- SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
-C*********************************************************************
-C
-C calculation of physical impact parameter amplitude
-C
-C input: EE cm energy (GeV)
-C BMIN lower bound in B
-C BMAX upper bound in B
-C NSTEP number of values (linear)
-C
-C output: values written to output unit
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(ONEM=-1.D0,
- & THOUS=1.D3,
- & DEPS=1.D-20)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C complex Born graph amplitudes used for unitarization
- COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
- & AMHMDD,AMPDP
- COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
- & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
-
- ECM=EE
- BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
-C
- WRITE(LO,'(3(/,1X,A))')
- & 'impact parameter amplitudes:',
- & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
- & '-------------------------------------------------------------'
-C
- BB = BMIN
- DO 100 I=1,NSTEP
-C calculate impact parameter amplitudes
- IF(I.EQ.1) THEN
- CALL PHO_EIKON(1,-1,BMIN)
- ELSE
- CALL PHO_EIKON(1,1,BB)
- ENDIF
- WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
- & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
- & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
- BB = BB+BSTEP
- 100 CONTINUE
-
- END
-
-CDECK ID>, PHO_PRBDIS
- SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
-C*********************************************************************
-C
-C calculation of multi interactions probabilities
-C
-C input: IP particle combination to scatter
-C ECM CMS energy
-C IE index for weight storing
-C /PROBAB/
-C IMAX max. number of soft pomeron interactions
-C KMAX max. number of hard pomeron interactions
-C
-C output: /PROBAB/
-C PROB field of probabilities
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS=1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C Born graph cross sections and slopes
- INTEGER Max_pro_3
- PARAMETER ( Max_pro_3 = 16 )
- COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
- & SIGD1,SIGD2,DSIGH
- COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
- & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C Born graph cross sections after applying diffraction model
- DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
- & SBOLPO,SBODPO
- COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
- & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
- & SBODPO(0:4,4)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C cut probability distribution
- INTEGER IEETA1,IIMAX,KKMAX
- PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
- INTEGER IEEMAX,IMAX,KMAX
- REAL PROB
- DOUBLE PRECISION EPTAB
- COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
- & IEEMAX,IMAX,KMAX
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-C average number of cut soft and hard ladders (obsolete)
- DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
- COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C unitarized amplitudes for different diffraction channels
- DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
- & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
- & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
- & ZXL,BXL
- COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
- & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
- & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
- & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
- & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
- & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
- & ZXL(4,4),BXL(4,4)
-
-C local variables
- DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
- PARAMETER (ICHMAX=40)
- DIMENSION CHIFAC(4,4),AMPCOF(4)
- DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
- DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
-
-C combinatorical factors
- DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
- & 1.D0,-1.D0, 1.D0,-1.D0,
- & 1.D0,-1.D0,-1.D0, 1.D0,
- & 1.D0, 1.D0, 1.D0, 1.D0 /
-
- DATA FACLOG / .000000000000000D+00,
- & .000000000000000D+00, .693147180559945D+00,
- & .109861228866811D+01, .138629436111989D+01,
- & .160943791243410D+01, .179175946922805D+01,
- & .194591014905531D+01, .207944154167984D+01,
- & .219722457733622D+01, .230258509299405D+01,
- & .239789527279837D+01, .248490664978800D+01,
- & .256494935746154D+01, .263905732961526D+01,
- & .270805020110221D+01, .277258872223978D+01,
- & .283321334405622D+01, .289037175789616D+01,
- & .294443897916644D+01, .299573227355399D+01,
- & .304452243772342D+01, .309104245335832D+01,
- & .313549421592915D+01, .317805383034795D+01,
- & .321887582486820D+01, .325809653802148D+01,
- & .329583686600433D+01, .333220451017520D+01,
- & .336729582998647D+01, .340119738166216D+01 /
-
- DATA ELAST / 0.D0 /
- DATA IPLAST / 0 /
-
-C test for redundant calculation: skip cs calculation
- IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
- ELAST = ECM
- IPLAST = IP
- CALL PHO_XSECT(IP,0,ELAST)
- ISIMAX = IE
- SIGECM(IP,IE) = ECM
- SIGTAB(IP,1,IE) = SIGTOT
- SIGTAB(IP,2,IE) = SIGELA
- J = 2
- DO 5 I=0,4
- DO 6 K=0,4
- J = J+1
- SIGTAB(IP,J,IE) = SIGVM(I,K)
- 6 CONTINUE
- 5 CONTINUE
- SIGTAB(IP,28,IE) = SIGINE
- SIGTAB(IP,29,IE) = SIGDIR
- SIGTAB(IP,30,IE) = SIGLSD(1)
- SIGTAB(IP,31,IE) = SIGLSD(2)
- SIGTAB(IP,32,IE) = SIGHSD(1)
- SIGTAB(IP,33,IE) = SIGHSD(2)
- SIGTAB(IP,34,IE) = SIGLDD
- SIGTAB(IP,35,IE) = SIGHDD
- SIGTAB(IP,36,IE) = SIGCDF(0)
- SIGTAB(IP,37,IE) = SIG1SO
- SIGTAB(IP,38,IE) = SIG1HA
- SIGTAB(IP,39,IE) = SLOEL
- J = 39
- DO 7 I=1,4
- DO 8 K=1,4
- J = J+1
- SIGTAB(IP,J,IE) = SLOVM(I,K)
- 8 CONTINUE
- 7 CONTINUE
- SIGTAB(IP,56,IE) = SIGPOM
- SIGTAB(IP,57,IE) = SIGREG
- SIGTAB(IP,58,IE) = SIGHAR
- SIGTAB(IP,59,IE) = SIGDIR
- SIGTAB(IP,60,IE) = SIGTR1(1)
- SIGTAB(IP,61,IE) = SIGTR1(2)
- SIGTAB(IP,62,IE) = SIGTR2(1)
- SIGTAB(IP,63,IE) = SIGTR2(2)
- SIGTAB(IP,64,IE) = SIGLOO
- SIGTAB(IP,65,IE) = SIGDPO(1)
- SIGTAB(IP,66,IE) = SIGDPO(2)
- SIGTAB(IP,67,IE) = SIGDPO(3)
- SIGTAB(IP,68,IE) = SIGDPO(4)
-
-C consistency check
- SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
- & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
- & -SIGLDD-SIGHDD
-
- IF(SIGNDF.LE.0.D0) THEN
- WRITE(LO,'(//1X,A,/)')
- & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
- WRITE(LO,'(1X,A,I3,1P,2E12.4)')
- & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
- WRITE(LO,'(4X,A,/1P,8E10.3)')
- &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
- & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
- & SIGLSD(2),SIGLDD
- STOP
- ENDIF
-
- IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
- print LO,'------------------------------------------------'
- print LO,'IP,ECM:',IP,ECM
- print LO,'SIGTOT:',SIGTOT
- print LO,'SIGELA:',SIGELA
- print LO,'SIGVM :',SIGVM(0,0)
- print LO,'SIGCDF:',SIGCDF(0)
- print LO,'SIGDIR:',SIGDIR
- print LO,'SIGLSD:',SIGLSD
- print LO,'SIGHSD:',SIGHSD
- print LO,'SIGLDD:',SIGLDD
- print LO,'SIGHDD:',SIGHDD
- print LO,'SIGNDF:',SIGNDF
-
- print LO,'SIGPOM:',SIGPOM
- print LO,'SIGREG:',SIGREG
- print LO,'SIGHAR:',SIGHAR
- print LO,'SIGDIR:',SIGDIR
- print LO,'SIGTR1:',SIGTR1
- print LO,'SIGTR2:',SIGTR2
- print LO,'SIGLOO:',SIGLOO
- print LO,'SIGDPO:',SIGDPO
- print LO,'SIG1SO:',SIG1SO
- print LO,'SIG1HA:',SIG1HA
- ENDIF
-
- SIGTAB(IP,77,IE) = PTCUT(IP)
- SIGTAB(IP,78,IE) = SIGNDF
-
- AUXFAC = PI2/SIGNDF
- IF(ISWMDL(1).EQ.3) THEN
- DO 133 I=1,4
- AMPCOF(I) = 0.D0
- DO 135 K=1,4
- AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
- 135 CONTINUE
- AMPCOF(I) = AMPCOF(I)*AUXFAC
- 133 CONTINUE
- ENDIF
-C
-* BMAX=5.D0*SQRT(DBLE(BPOM))
- BMAX=10.D0
- EPTAB(IP,IE) = ECM
- CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
-C
- ENDIF
-C
- DO 160 K=0,KMAX
- DO 170 I=0,IMAX
- PROB(IP,IE,I,K) = 0.D0
- 170 CONTINUE
- 160 CONTINUE
- DO 120 I=1,ICHMAX
- PCHAIN(1,I) = 0.D0
- PCHAIN(2,I) = 0.D0
- 120 CONTINUE
-C
-C main cross section loop
-C**********************************************************
- DO 5000 IB=1,NGAUSO
- B24=XPNT(IB)**2/4.D0
- FAC = XPNT(IB)*WGHT(IB)
-C
- IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
-C
-C amplitude construction
- DO 525 I=1,4
- AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
- & +ZXR(1,I)*EXP(-B24/BXR(1,I))
- AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
- AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
- & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
- & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
- & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
- & -ZXL(1,I)*EXP(-B24/BXL(1,I))
- AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
- & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
- & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
- & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
- AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
- AB(2,I) = AB(2,I)
- AB(3,I) = 0.D0
- AB(4,I) = 0.D0
-*
- 525 CONTINUE
-C
- DO 460 I=1,4
- DO 500 K=1,4
- ABSUM2(I,K) = 0.D0
- DO 550 L=1,4
- ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
- 550 CONTINUE
- ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
- 500 CONTINUE
- 460 CONTINUE
- DO 600 I=1,4
- CHI2(I) = 0.D0
- DO 650 K=1,4
- CHI2(I) = CHI2(I) + ABSUM2(K,I)
- 650 CONTINUE
- 600 CONTINUE
-C sums instead of products
- DO 660 I=1,4
- DO 670 KD=1,4
- DTMP = ABS(ABSUM2(I,KD))
- IF(DTMP.LT.1.D-30) THEN
- ABSUM2(I,KD) = -50.D0
- ELSE
- ABSUM2(I,KD) = LOG(DTMP)
- ENDIF
- 670 CONTINUE
- 660 CONTINUE
-
- IF(MAX(IMAX,KMAX).GT.30) THEN
- WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
- & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
- CALL PHO_ABORT
- ENDIF
-
- DO 700 KD=1,4
- DO 750 I=1,4
- ABSTMP(I) = ABSUM2(I,KD)
- 750 CONTINUE
-C recursive sum
- CHITMP(1) = -ABSUM2(1,KD)
- DO 800 I=0,IMAX
- CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
- CHITMP(2) = -ABSTMP(2)
- DO 810 K=0,KMAX
- CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
-C calculation of elastic part
- DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
- IF(DTMP.LT.-30.D0) THEN
- DTMP = 0.D0
- ELSE
- DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
- ENDIF
- PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
- 810 CONTINUE
- 800 CONTINUE
- 700 CONTINUE
- PROB(IP,IE,0,0) = 0.D0
-C
-C**********************************************************
- ELSE
- WRITE(LO,'(1X,A,I3)')
- & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
- STOP
- ENDIF
- 5000 CONTINUE
-
-C debug output
- IF(IDEB(55).GE.15) THEN
- WRITE(LO,'(/,1X,A,I3,E11.4)')
- & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
- & IP,ECM
- DO 905 I=0,MIN(IMAX,5)
- DO 915 K=0,MIN(KMAX,5)
- IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
- & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
- 915 CONTINUE
- 905 CONTINUE
- ENDIF
-C string probability (uncorrected)
- IF(IDEB(55).GE.5) THEN
- DO 955 I=0,IMAX
- DO 965 K=0,KMAX
- INDX = 2*I+2*K
- IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
- PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
- ENDIF
- 965 CONTINUE
- 955 CONTINUE
- WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
- & 'list of selected probabilities (uncorr,ECM)',ECM
- WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
- DO 183 I=0,IIMAX
- IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
- & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
- & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
- 183 CONTINUE
- ENDIF
-C substract high-mass single and double diffraction
- PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
- & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
- PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
-C
-C probability check
- CHKSUM = 0.D0
- PRONEG = 0.D0
- AVERI = 0.D0
- AVERK = 0.D0
- AVERL = 0.D0
- AVERM = 0.D0
- AVERN = 0.D0
- SIGMI = 0.D0
- SIGMK = 0.D0
- SIGML = 0.D0
- SIGMM = 0.D0
- DO 1001 I=0,IMAX
- PSOFT(I) = 0.D0
- 1001 CONTINUE
- DO 1002 K=0,KMAX
- PHARD(K) = 0.D0
- 1002 CONTINUE
- DO 1000 K=0,KMAX
- DO 1010 I=0,IMAX
- TMP = PROB(IP,IE,I,K)
- IF(TMP.LT.0.D0) THEN
- IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
- WRITE(LO,'(1X,A,4I4,E14.4)')
- & 'PHO_PRBDIS: neg.probability:',
- & IP,IE,I,K,PROB(IP,IE,I,K)
- ENDIF
- PRONEG = PRONEG+TMP
- TMP = 0.D0
- ENDIF
- CHKSUM = CHKSUM+TMP
- AVERI = AVERI+DBLE(I)*TMP
- AVERK = AVERK+DBLE(K)*TMP
- SIGMI = SIGMI+DBLE(I**2)*TMP
- SIGMK = SIGMK+DBLE(K**2)*TMP
- PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
- PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
- PROB(IP,IE,I,K) = CHKSUM
- 1010 CONTINUE
- 1000 CONTINUE
-C
- IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
- & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
-C cut probabilites output
- IF(IDEB(55).GE.5) THEN
- WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
- DO 185 I=1,ICHMAX
- IF(ABS(PCHAIN(1,I)).GT.1.D-10)
- & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
- 185 CONTINUE
- ENDIF
-C rescaling necessary
- IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
- FAC = 1.D0/CHKSUM
- IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
- & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
- DO 40 K=0,KMAX
- DO 50 I=0,IMAX
- PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
- 50 CONTINUE
- 40 CONTINUE
- AVERI = AVERI*FAC
- AVERK = AVERK*FAC
- AVERL = AVERL*FAC
- AVERM = AVERM*FAC
- SIGMI = SIGMI*FAC**2
- SIGMK = SIGMK*FAC**2
- SIGML = SIGML*FAC**2
- SIGMM = SIGMM*FAC**2
- ENDIF
-C
-C probability to find Reggeon/Pomeron
- PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
- AVERJ = -PROB(IP,IE,0,0)*AVERI
- AVERII = AVERI-AVERJ
-C
- SIGTAB(IP,74,IE) = AVERII
- SIGTAB(IP,75,IE) = AVERK
- SIGTAB(IP,76,IE) = AVERJ
-C
- SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
- SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
-C
- IF(IDEB(55).GE.1) THEN
-
-C average interaction probabilities
- WRITE(LO,'(/1X,A,/1X,A)')
- & 'PHO_PRBDIS: expected interaction statistics',
- & '-------------------------------------------'
- WRITE(LO,'(1X,A,E12.4,2I3)')
- & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
- WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
- & IMAX,KMAX
- WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
- & 'averaged number of cuts per event (eff. cs):',SIGNDF,
- & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
- & AVERII,AVERK,AVERJ,AVERL,AVERM,
- & AVERI+AVERK+AVERL+AVERM
- WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
- & 'standard deviation ( sqrt(sigma) ):',
- & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
- & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
- & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
- WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
- DO I=0,MIN(IMAX,KMAX)
- WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
- & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
- ENDDO
-
-C cross check of probability distribution and inclusive cross section
- PSsum_1 = 0.D0
- PSsum_2 = 0.D0
- PHsum_1 = 0.D0
- PHsum_2 = 0.D0
- do i=1,IMAX
- PSsum_1 = PSsum_1+PSOFT(i)*FAC
- PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
- enddo
- do k=1,KMAX
- PHsum_1 = PHsum_1+PHARD(k)
- PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
- enddo
- WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
- & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_SAMPRO
- SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
-C***********************************************************************
-C
-C routine to sample kind of process
-C
-C input: IP particle combination
-C IFP1/2 PDG number of particle 1/2
-C ECM c.m. energy (GeV)
-C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
-C SPROB suppression factor for processes 1-7
-C due to rapidity gap survival probability
-C IPROC mode
-C -2 output of statistics
-C -1 initialization
-C 0 sampling of process
-C
-C output: IPROC kind of interaction process:
-C 1 non-diffractive resolved process
-C 2 elastic scattering
-C 3 quasi-elastic rho/omega/phi production
-C 4 central diffraction
-C 5 single diffraction according to IDIFF1
-C 6 single diffraction according to IDIFF2
-C 7 double diffraction
-C 8 single-resolved / direct processes
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- INTEGER IP,IFP1,IFP2,IPROC
- DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
- DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
- DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
-
- INTEGER I,K,KMAX
- DOUBLE PRECISION DT_RNDM
- DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
-
- IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
- & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
- & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
-
- IF(IPROC.GE.0) THEN
-
-C interpolate cross sections
- CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
-
-C cross check
- IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
- WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
- & 'PHO_SAMPRO: inconsistent gap survival probability',
- & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
- & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
- ENDIF
-
-C calculate cumulative probabilities
- IF(ISWMDL(1).EQ.3) THEN
- IF(ISWMDL(2).GE.1) THEN
- SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
- SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
- SIGDDI = SIGLDD+SIGHDD
- SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
- & - SIGSDI(1)-SIGSDI(2)-SIGDDI
- XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
- XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
- XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
- XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
- XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
- XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
- XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
- XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
- ELSE
- SIGHR = 0.D0
- IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
- SIGHD = 0.D0
- IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
- XPROB(1) = SIGHR/(SIGHR+SIGHD)
- XPROB(2) = XPROB(1)
- XPROB(3) = XPROB(1)
- XPROB(4) = XPROB(1)
- XPROB(5) = XPROB(1)
- XPROB(6) = XPROB(1)
- XPROB(7) = XPROB(1)
- XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
- ENDIF
-
- IF(IDEB(11).GE.15) THEN
- WRITE(LO,'(1X,A,I3)')
- & 'PHO_SAMPRO: partial cross sections for IP',IP
- WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
- DO 240 I=2,8
- WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
- 240 CONTINUE
- ENDIF
-
- ELSE
- WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
- & ISWMDL(1)
- CALL PHO_ABORT
- ENDIF
-
- IF(XPROB(8).LT.1.D-20) THEN
- IF(IDEB(11).GE.2)
- & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
- & 'activated processes have vanishing cross section sum',
- & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
- IPROC = 0
- RETURN
- ENDIF
-
-C sample process
- XI = DT_RNDM(XI)*XPROB(8)
- DO 100 I=1,8
- IF(XI.LE.XPROB(I)) GOTO 110
- 100 CONTINUE
- 110 CONTINUE
- IPROC = MIN(I,8)
-
- CALLS(IP) = CALLS(IP)+1.D0
- PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
- ECMSUM(IP) = ECMSUM(IP)+ECM
- IF(ISWMDL(2).GE.1) THEN
- SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
- ELSE
- SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
- ENDIF
-
-C debug output
- IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
- & 'PHO_SAMPRO: IP,CALL,PROC-ID',
- & IP,INT(CALLS(IP)+0.1D0),IPROC
-
-C statistics initialization
- ELSE IF(IPROC.EQ.-1) THEN
- DO 260 K=1,4
- DO 250 I=1,8
- PRO(I,K) = 0.D0
- 250 CONTINUE
- CALLS(K) = 0.D0
- SIGSUM(K) = 0.D0
- ECMSUM(K) = 0.D0
- 260 CONTINUE
-
-C write out statistics
- ELSE IF(IPROC.EQ.-2) THEN
- KMAX = 4
- IF(ISWMDL(2).EQ.0) KMAX=1
- DO 270 K=1,KMAX
- IF(CALLS(K).GT.0.5D0) THEN
- SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
- ECMSUM(K) = ECMSUM(K)/CALLS(K)
- IF(IDEB(11).GE.0) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
-C & 'PHO_SAMPRO: internal process statistics ',
-C & '(IP,<Ecm>)',K,ECMSUM(K),
-C & '---------------------------------------'
-C WRITE(LO,'(8X,A)')
-C & ' process sampled cross section'
-C IF(ISWMDL(2).GE.1) THEN
-C WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
-C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
-C & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
-C & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
-C & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
-C & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
-C & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
-C & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
-C & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
-C & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
-C ELSE
-C WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
-C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
-C & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
-C & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
-C ENDIF
- ENDIF
- ENDIF
- 270 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_SAMPRB
- SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
-C********************************************************************
-C
-C routine to sample number of cut graphs of different kind
-C
-C input: IP scattering particle combination
-C ECMI CMS energy
-C IP -1 initialization
-C -2 output of statistics
-C others sampling of cuts
-C
-C output: ISAM number of soft Pomerons cut
-C JSAM number of soft Reggeons cut
-C KSAM number of hard Pomerons cut
-C
-C PHO_PRBDIS has to be called before
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C cut probability distribution
- INTEGER IEETA1,IIMAX,KKMAX
- PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
- INTEGER IEEMAX,IMAX,KMAX
- REAL PROB
- DOUBLE PRECISION EPTAB
- COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
- & IEEMAX,IMAX,KMAX
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-
- DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
-
-C sample number of interactions
- IF(IP.GE.0) THEN
- ITER = 0
- ECMX = ECMI
- ECMC = ECMI
- KLIM = 1
- IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
- IF(IPAMDL(16).EQ.0) ECMC = SECM
- KLIM = 0
- ENDIF
-
-C sample up to kinematic limits only
- IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
- IF(IMAX1.LT.1) THEN
- IF(IPAMDL(2).EQ.1) THEN
-C reggeon allowed
- ISAM = 0
- JSAM = 1
- KSAM = 0
- AVERB(3,IP) = AVERB(3,IP)+1.D0
- ELSE
-C only pomeron even at very low energies
- ISAM = 1
- JSAM = 0
- KSAM = 0
- AVERB(1,IP) = AVERB(1,IP)+1.D0
- ENDIF
- AVERB(0,IP) = AVERB(0,IP)+1.D0
- GOTO 150
- ENDIF
-C find interpolation factors
- IF(ECMX.LE.EPTAB(IP,1)) THEN
- I1 = 1
- I2 = 1
- ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
- DO 50 I=2,IEEMAX
- IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
- 50 CONTINUE
- 200 CONTINUE
- I1 = I-1
- I2 = I
- ELSE
- WRITE(LO,'(/1X,A,2E12.3)')
- & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
- CALL PHO_PREVNT(-1)
- I1 = IEEMAX
- I2 = IEEMAX
- ENDIF
- FAC2 = 0.D0
- IF(I1.NE.I2)
- & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
- FAC1=1.D0-FAC2
-C reggeon probability
- PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
-C calculate soft suppression factor
- IF(IP.EQ.1) FSUPP = PARMDL(35)**2
- & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
-C
- 10 CONTINUE
- ITER = ITER+1
- XI = DT_RNDM(FAC2)
- DO 260 KSAM=0,KMAX
- DO 270 ISAM=0,IMAX
- PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
- & +PROB(IP,I2,ISAM,KSAM)*FAC2
- IF(PRO.GT.XI) GOTO 100
- 270 CONTINUE
- 260 CONTINUE
- ISAM = MIN(IMAX,ISAM)
- KSAM = MIN(KMAX,KSAM)
-
- 100 CONTINUE
-
- IF(ITER.GT.100) THEN
-
- ISAM = 0
- JSAM = 1
- KSAM = 0
- IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
- & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
-
- ELSE
-
-C reggeon contribution
- JSAM = 0
- IF(IPAMDL(2).EQ.1) THEN
- DO 90 I=1,ISAM
- IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
- 90 CONTINUE
- ISAM = ISAM-JSAM
- ENDIF
-C statistics of bare cuts
- IF(ITER.EQ.1) THEN
- AVERB(0,IP) = AVERB(0,IP)+1.D0
- AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
- AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
- AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
- ENDIF
-C limitation given by field dimensions
- IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
-
- IF(IP.EQ.1) THEN
-
-C reweight according to virtualities and PDF treatment
- IF(IPAMDL(115).GE.1) THEN
- IF(KSAM.EQ.0) THEN
- IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
- ENDIF
- ENDIF
-
-C reduce number of cuts according to photon virtualities
- IF(IPAMDL(114).GE.1) THEN
- 110 CONTINUE
- I = ISAM+JSAM
- WGX = FSUPP**I
- IF(DT_RNDM(WGX).GT.WGX) THEN
- IF(ISAM+JSAM+KSAM.GT.1) THEN
- IF(JSAM.GT.0) THEN
- JSAM = JSAM-1
- GOTO 110
- ELSE IF(ISAM.GT.0) THEN
- ISAM = ISAM-1
- GOTO 110
- ENDIF
- ENDIF
- ENDIF
- ENDIF
-
- ENDIF
-
-C phase space limitation
- 120 CONTINUE
- XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
- & +DBLE(2*KSAM)*PTCUT(IP)
- PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
- IF(DT_RNDM(XM).GT.PACC) THEN
- IF(ISAM+JSAM+KSAM.GT.1) THEN
- IF(JSAM.GT.0) THEN
- JSAM = JSAM-1
- GOTO 120
- ELSE IF(ISAM.GT.0) THEN
- ISAM = ISAM-1
- GOTO 120
- ELSE IF(KSAM.GT.KLIM) THEN
- KSAM = KSAM-1
- GOTO 120
- ENDIF
- ENDIF
- ENDIF
-
- ENDIF
-
- ISAM = ISAM+JSAM/2
- JSAM = MOD(JSAM,2)
-C collect statistics
- 150 CONTINUE
- ECMS1(IP) = ECMS1(IP)+ECMX
- ECMS2(IP) = ECMS2(IP)+ECMC
-
- AVERC(0,IP) = AVERC(0,IP)+1.D0
- AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
- AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
- AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
-C
- IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
- & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
-C
-C initialize statistics
- ELSE IF(IP.EQ.-1) THEN
- DO 60 I=1,4
- ECMS1(I) = 0.D0
- ECMS2(I) = 0.D0
- DO 65 K=0,3
- AVERB(K,I) = 0.D0
- AVERC(K,I) = 0.D0
- 65 CONTINUE
-
- 60 CONTINUE
- RETURN
-C
-C write out statistics
- ELSE IF(IP.EQ.-2) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
-C & '----------------------------------'
- DO 70 I=1,4
- IF(AVERB(0,I).LT.2.D0) GOTO 75
-C WRITE(LO,'(1X,A,I3,1P,2E13.3)')
-C & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
-C & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
-C WRITE(LO,'(5X,A)')
-C & 'average number of s-pom,h-pom,reg cuts (bare)'
-C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
-C & (AVERB(K,I)/AVERB(0,I),K=1,3)
-C WRITE(LO,'(5X,A)')
-C & 'average (with energy/virtuality corrections)'
-C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
-C & (AVERC(K,I)/AVERC(0,I),K=1,3)
-
- 75 CONTINUE
- 70 CONTINUE
- RETURN
- ENDIF
- END
-
-CDECK ID>, PHO_TRIREG
- SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
- & SIGTR,BTR)
-C**********************************************************************
-C
-C calculation of triple-Pomeron total cross section
-C according to Gribov's Regge theory
-C
-C input: S squared cms energy
-C GA coupling constant to diffractive line
-C AA slope related to GA (GeV**-2)
-C GB coupling constant to elastic line
-C BB slope related to GB (GeV**-2)
-C DELTA effective pomeron delta (intercept-1)
-C ALPHAP slope of pomeron trajectory (GeV**-2)
-C GPPP triple-Pomeron coupling
-C BPPP slope related to B0PPP (GeV**-2)
-C VIR2A virtuality of particle a (GeV**2)
-C note: units of all coupling constants are mb**1/2
-C
-C output: SIGTR total triple-Pomeron cross section
-C BTR effective triple-Pomeron slope
-C (differs from diffractive slope!)
-C
-C uses E_i (Exponential-Integral function)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (EPS =0.0001D0)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
-C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
- SIGU = 2.5
-C integration cut-off Sigma_L (min. squared mass of diff. blob)
- SIGL = 5.+VIR2A
-C debug output
- IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
- & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
- & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
-C
- IF(S.LT.5.D0) THEN
- SIGTR = 0.D0
- BTR = BPPP+BB
- RETURN
- ENDIF
-C change units of ALPHAP to mb
- ALSCA = ALPHAP*GEV2MB
-C
-C cross section
- PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
- & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
- PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
- PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
-C
- SIGTR=PART1*(PART2-PART3)
-C
-C slope
- PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
- & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
- PART2 = LOG(PART1)
- PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
- BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
- BTR = BTR-PART1
-C
- IF(SIGTR.LT.EPS) SIGTR = 0.D0
- IF(BTR.LT.BB) BTR = BB
-C
- IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
- & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
- END
-
-CDECK ID>, PHO_LOOREG
- SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
- & VIR2A,VIR2B,SIGLO,BLO)
-C**********************************************************************
-C
-C calculation of loop-Pomeron total cross section
-C according to Gribov's Regge theory
-C
-C input: S squared cms energy
-C GA coupling constant to diffractive line
-C AA slope related to GA (GeV**-2)
-C GB coupling constant to elastic line
-C BB slope related to GB (GeV**-2)
-C DELTA effective pomeron delta (intercept-1)
-C ALPHAP slope of pomeron trajectory (GeV**-2)
-C GPPP triple-Pomeron coupling
-C BPPP slope related to B0PPP (GeV**-2)
-C VIR2A virtuality of particle a (GeV**2)
-C VIR2B virtuality of particle b (GeV**2)
-C note: units of all coupling constants are mb**1/2
-C
-C output: SIGLO total loop-Pomeron cross section
-C BLO effective loop-Pomeron slope
-C (differs from double diffractive slope!)
-C
-C uses E_i (Exponential-Integral function)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (EPS =0.0001D0)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
-C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
- SIGU = 2.5
-C integration cut-off Sigma_L (min. squared mass of diff. blob)
- SIGL = 5.+VIR2A+VIR2B
-C debug output
- IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
- & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
- & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
-C
- IF(S.LT.5.D0) THEN
- SIGLO = 0.D0
- BLO = 2.D0*BPPP
- RETURN
- ENDIF
-
-C
-C change units of ALPHAP to mb
- ALSCA = ALPHAP*GEV2MB
-C
-C cross section
- PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
- & EXP(-DELTA*BPPP/ALPHAP)
- PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
- PARTB=BPPP/ALPHAP+LOG(SIGU)
- SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
- & -PHO_EXPINT(PARTB*DELTA))
- & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
- & )
-C
-C slope
- PART1 = LOG(ABS(PARTA/PARTB))
- & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
- PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
- BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
- BLO = BLO-PART1
-C
- IF(SIGLO.LT.EPS) SIGLO = 0.D0
- IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
-C
- IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
- & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
- END
-
-CDECK ID>, PHO_TRXPOM
- SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
- & GPPP,BPPP,SIGDP,BDP)
-C**********************************************************************
-C
-C calculation of total cross section of two tripe-Pomeron
-C graphs in X configuration according to Gribov's Reggeon field
-C theory
-C
-C input: S squared cms energy
-C GA coupling constant to elastic line 1
-C AA slope related to GA (GeV**-2)
-C GB coupling constant to elastic line 2
-C BB slope related to GB (GeV**-2)
-C DELTA effective pomeron delta (intercept-1)
-C ALPHAP slope of pomeron trajectory (GeV**-2)
-C BPPP triple-Pomeron coupling
-C BTR slope related to B0PPP (GeV**-2)
-C note: units of all coupling constants are mb**1/2
-C
-C output: SIGDP total cross section for double-Pomeron
-C scattering
-C BDP effective double-Pomeron slope
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (EPS =0.0001D0)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DIMENSION XWGH1(96),XPOS1(96)
-
-C lower integration cut-off Sigma_L
- SIGL = PARMDL(71)**2
-C upper integration cut-off Sigma_U
- C = 1.D0-1.D0/PARMDL(70)**2
- C = MAX(PARMDL(72),C)
- SIGU = (1.D0-C)**2*S
-C integration precision
- NGAUS1=16
-C
-C debug output
- IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
- & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
- & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
-C
- IF(SIGU.LE.SIGL) THEN
- SIGDP = 0.D0
- BDP = AA+BB
- RETURN
- ENDIF
-C
-C cross section
-C
- XIL = LOG(SIGL)
- XIU = LOG(SIGU)
- XI = LOG(S)
- FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
- ALPHA2 = 2.D0*ALPHAP
- ALOC = LOG(1.D0/(1.D0-C))
- CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
- XSUM = 0.D0
- DO 100 I1=1,NGAUS1
- AMXSQ = EXP(XPOS1(I1))
- ALOSMX = LOG(S/AMXSQ)
- ALCSMX = LOG((1.D0-C)*S/AMXSQ)
- W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
- W = MAX(0.D0,W)
- WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
-C supercritical part
- WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
- XSUM = XSUM + W*XWGH1(I1)/WN*WSC
- 100 CONTINUE
- SIGDP = XSUM*FAC
-C
-C slope
- BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
-C
- IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
- & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
- END
-
-CDECK ID>, PHO_CHAN2A
- SUBROUTINE PHO_CHAN2A(BB)
-C***********************************************************************
-C
-C simple two channel model to realize low mass diffraction
-C (version A, iteration of triple- and loop-Pomeron)
-C
-C input: BB impact parameter (mb**1/2)
-C
-C output: /POINT4/
-C AMPEL elastic amplitude
-C AMPVM(4,4) q-elastic VM production
-C AMLMSD(2) low mass single diffraction amplitude
-C AMHMSD(2) high mass single diffraction amplitude
-C AMLMDD low mass double diffraction amplitude
-C AMHMDD high mass double diffraction amplitude
-C AMPDP(4) central diffraction amplitude
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (DEPS = 1.D-5,
- & EIGHT = 8.D0)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C complex Born graph amplitudes used for unitarization
- COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
- & AMHMDD,AMPDP
- COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
- & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
-C unitarized amplitudes for different diffraction channels
- DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
- & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
- & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
- & ZXL,BXL
- COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
- & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
- & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
- & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
- & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
- & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
- & ZXL(4,4),BXL(4,4)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-
-C local variables
- DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
- & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
- & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
- DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
-
-C combinatorical factors
- DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
- & 1.D0,-1.D0, 1.D0,-1.D0,
- & 1.D0,-1.D0,-1.D0, 1.D0,
- & 1.D0, 1.D0, 1.D0, 1.D0 /
- DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
- & 1.D0,-1.D0,-1.D0, 1.D0,
- & -1.D0, 1.D0,-1.D0, 1.D0,
- & -1.D0,-1.D0, 1.D0, 1.D0 /
- DATA IELTAB / 1, 2, 3, 4,
- & 2, 1, 4, 3,
- & 3, 4, 1, 2,
- & 4, 3, 2, 1 /
-
- IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
- & 'PHO_CHAN2A: impact parameter B',BB
-
- B24 = BB**2/4.D0
- DO 25 I=1,4
- AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
- & +ZXR(1,I)*EXP(-B24/BXR(1,I))
- AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
- AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
- AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
- AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
- & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
- & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
- AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
- AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
- AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
- AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
- 25 CONTINUE
-
- DO 50 I=1,4
- ABSUM(I) = 0.D0
- DO 75 II=9,1,-1
- ABSUM(I) = ABSUM(I) + AB(II,I)
- 75 CONTINUE
- 50 CONTINUE
- IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
- & 'PHO_CHAN2A: ABSUM',ABSUM
-
- DO 100 I=1,4
- CHI(I) = 0.D0
- CHDS(I) = 0.D0
- CHDH(I) = 0.D0
- CHDA(I) = 0.D0
- CHDB(I) = 0.D0
- CHDD(I) = 0.D0
- CHDPE(I) = 0.D0
- CHDPA(I) = 0.D0
- CHDPB(I) = 0.D0
- CHDPD(I) = 0.D0
- AMPELA(I,0) = 0.D0
- AMPELA(I,9) = 0.D0
- DO 200 K=1,4
- AMPELA(I,K) = 0.D0
- AMPELA(I,K+4) = 0.D0
- AMPVM(I,K) = 0.D0
- CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
- CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
- CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
- CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
- CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
- CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
- CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
- CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
- CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
- CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
- 200 CONTINUE
- IF(CHI(I).LT.-DEPS) THEN
- IF(IDEB(86).GE.0) THEN
- WRITE(LO,'(1X,A,I3,2E12.3)')
- & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
- WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
- ENDIF
- ENDIF
- IF(ABS(CHI(I)).GT.200.D0) THEN
- EX1CHI(I) = 0.D0
- EX2CHI(I) = 0.D0
- ELSE
- TMP = EXP(-CHI(I))
- EX1CHI(I) = TMP
- EX2CHI(I) = TMP*TMP
- ENDIF
- 100 CONTINUE
- IF(IDEB(86).GE.20) THEN
- WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
- ENDIF
-
- AMPELA(1,0) = 4.D0
- DO 300 K=1,4
- DO 400 J=1,4
- CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
- AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
- AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
- AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
- AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
- AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
- AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
- AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
- AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
- AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
- AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
- 400 CONTINUE
- 300 CONTINUE
-
- IF(IDEB(86).GE.25) THEN
- DO 305 I=1,9
- WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
- & (AMPELA(K,1),K=1,4)
- 305 CONTINUE
- ENDIF
-
-C VDM factors --> amplitudes
-C low mass excitations
- DO 500 I=1,4
- AMPCHA(I) = 0.D0
- DO 600 K=1,4
- AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
- 600 CONTINUE
- 500 CONTINUE
- AMPVME = AMPCHA(1)/EIGHT
- AMLMSD(1) = AMPCHA(2)/EIGHT
- AMLMSD(2) = AMPCHA(3)/EIGHT
- AMLMDD = AMPCHA(4)/EIGHT
-C elastic part, high mass diffraction
- AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
- AMPSOF = 0.D0
- AMPHAR = 0.D0
- AMHMSD(1) = 0.D0
- AMHMSD(2) = 0.D0
- AMHMDD = 0.D0
- AMPDP(1) = 0.D0
- AMPDP(2) = 0.D0
- AMPDP(3) = 0.D0
- AMPDP(4) = 0.D0
- DO 450 I=1,4
- AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
- AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
- AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
- AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
- AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
- AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
- AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
- AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
- AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
- AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
- 450 CONTINUE
- AMPSOF = AMPSOF/16.D0
- AMPHAR = AMPHAR/16.D0
- AMHMSD(1) = AMHMSD(1)/16.D0
- AMHMSD(2) = AMHMSD(2)/16.D0
- AMHMDD = AMHMDD/16.D0
- AMPDP(1) = AMPDP(1)/16.D0
- AMPDP(2) = AMPDP(2)/16.D0
- AMPDP(3) = AMPDP(3)/16.D0
- AMPDP(4) = AMPDP(4)/16.D0
- IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
- IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
- IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
- IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
- IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
- IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
- IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
-
-C vector-meson production, weight factors
- IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
- IF(IFPAP(1).EQ.22) THEN
- IF(IFPAP(2).EQ.22) THEN
- DO 10 I=1,4
- DO 15 J=1,4
- AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
- 15 CONTINUE
- 10 CONTINUE
- ELSE
- AMPVM(1,1) = PARMDL(10)*AMPVME
- AMPVM(2,1) = PARMDL(11)*AMPVME
- AMPVM(3,1) = PARMDL(12)*AMPVME
- AMPVM(4,1) = PARMDL(13)*AMPVME
- ENDIF
- ELSE IF(IFPAP(2).EQ.22) THEN
- AMPVM(1,1) = PARMDL(10)*AMPVME
- AMPVM(1,2) = PARMDL(11)*AMPVME
- AMPVM(1,3) = PARMDL(12)*AMPVME
- AMPVM(1,4) = PARMDL(13)*AMPVME
- ENDIF
- ENDIF
-C debug output
- IF(IDEB(86).GE.5) THEN
- WRITE(LO,'(/,1X,A)')
- & 'PHO_CHAN2A: impact parameter amplitudes'
- WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
- WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
- WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
- WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
- WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
- WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
- WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
- WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
- WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
- WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
- WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
- ENDIF
-
- END
-
-CDECK ID>, PHO_EVENT
- SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
-C********************************************************************
-C
-C main subroutine to manage simulation processes
-C
-C input: NEV -1 initialization
-C 1 generation of events
-C 2 generation of events without rejection
-C due to energy dependent cross section
-C 3 generation of events without rejection
-C using initialization energy
-C -2 output of event generation statistics
-C P1(4) momentum of particle 1 (internal TARGET)
-C P2(4) momentum of particle 2 (internal PROJECTILE)
-C FAC used for initialization:
-C contains cross section the events corresponds to
-C during generation: current cross section
-C
-C output: IREJ 0: event accepted
-C 1: event rejected
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY = 1.D-10 )
-
- DIMENSION P1(4),P2(4)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-
- DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
-
- IREJ = 0
-
-C initializations
- IF(NEV.EQ.-1) THEN
- WRITE(LO,'(/3(/1X,A))')
- & '=======================================================',
- & ' ------- initialization of event generation --------',
- & '======================================================='
- CALL PHO_SETMDL(0,0,-2)
-C amplitude parameters
- CALL PHO_FITPAR(1)
-
- CALL PHO_REJSTA(-1)
-C initialize MC package
- CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
- CALL PHO_MCINI
- CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
- & 0.D0,-1)
- CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
-
-C cross section
- FAC = SIGGEN(4)
- DO 20 I=1,10
- IPRSAM(I) = 0
- IPRACC(I) = 0
- IENACC(I) = 0
- 20 CONTINUE
- ISPS = 0
- ISPA = 0
- ISRS = 0
- ISRA = 0
- IHPS = 0
- IHPA = 0
- ISTS = 0
- ISTA = 0
- ISLS = 0
- ISLA = 0
- IDIS = 0
- IDIA = 0
- IDPS = 0
- IDPA = 0
- IDNS(1) = 0
- IDNS(2) = 0
- IDNS(3) = 0
- IDNS(4) = 0
- IDNA(1) = 0
- IDNA(2) = 0
- IDNA(3) = 0
- IDNA(4) = 0
- KACCEP = 0
- KEVENT = 0
- KEVGEN = 0
- ECMSUM = 0.D0
- ELSE IF(NEV.GT.0) THEN
-C
-C -------------- begin event generation ---------------
-C
- IPAMDL(13) = 0
- IF(NEV.EQ.3) IPAMDL(13) = 1
- KEVENT = KEVENT+1
-C enable debugging
- CALL PHO_TRACE(0,0,0)
- IF(IDEB(68).GE.2) THEN
- IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
- & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
- ENDIF
- CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
-C cross section calculation
- FAC = SIGGEN(3)
- IF(NEV.EQ.1) THEN
- IF(IVWGHT(1).EQ.1) THEN
- WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
- ELSE
- WG = SIGGEN(3)/SIGGEN(4)
- ENDIF
- IF(DT_RNDM(FAC).GT.WG) THEN
- IREJ = 1
- IF(IDEB(68).GE.6) THEN
- WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
- & 'PHO_EVENT: rejection due to cross section',
- & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
- & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- ENDIF
- KEVGEN = KEVGEN+1
- SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
- HSWGHT(0) = MAX(1.D0,WG)
-
- ITRY1 = 0
- 50 CONTINUE
- ITRY1 = ITRY1+1
- IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
-
-C sample process
- IPROCE = 0
- CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
- & 1.D0,IPROCE)
- IF(IPROCE.EQ.0) THEN
- IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
- & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
- IREJ = 50
- RETURN
- ENDIF
-C sampling statistics
- IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
-
- ITRY2 = 0
- 60 CONTINUE
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
-C sample number of cut graphs according to IPROCE and
-C generate parton configurations+strings
- CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
-C collect statistics
- ISPS = ISPS+KSPOM
- IHPS = IHPS+KHPOM
- ISRS = ISRS+KSREG
- ISTS = ISTS+KSTRG+KHTRG
- ISLS = ISLS+KSLOO+KHLOO
- IDIS = IDIS+MIN(KHDIR,1)
- IDPS = IDPS+KHDPO+KSDPO
- IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
- & IDNS(KHDIR) = IDNS(KHDIR)+1
-C rejection?
- IF(IREJ.NE.0) THEN
- IF(IDEB(68).GE.4) THEN
- WRITE(LO,'(/1X,A,2I5)')
- & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
- RETURN
- ENDIF
- IFAIL(1) = IFAIL(1)+1
- IF(ITRY1.GT.5) RETURN
- IF(IREJ.GE.5) THEN
- IF(ISWMDL(2).EQ.0) RETURN
- GOTO 50
- ENDIF
- IF(ITRY2.LT.5) GOTO 60
- GOTO 50
- ENDIF
-C fragmentation of strings
-
-C FSR and string fragmentation is done separately by DPMJET routines
-C CALL PHO_STRFRA(IREJ)
-
-C rejection?
- IF(IREJ.NE.0) THEN
- IFAIL(23) = IFAIL(23)+1
- IF(IDEB(68).GE.4) THEN
- WRITE(LO,'(/1X,A,2I5)')
- & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- GOTO 50
- ENDIF
-C check of conservation of quantum numbers
- IF(IDEB(68).GE.-5) THEN
- CALL PHO_CHECK(-1,IREJ)
- IF(IREJ.NE.0) GOTO 50
- ENDIF
-C event now completely processed and accepted
-C acceptance statistics
- IPRACC(IPROCE) = IPRACC(IPROCE)+1
- ISPA = ISPA+KSPOM
- IHPA = IHPA+KHPOM
- ISRA = ISRA+KSREG
- ISTA = ISTA+(KSTRG+KHTRG)
- ISLA = ISLA+(KSLOO+KHLOO)
- IDIA = IDIA+MIN(KHDIR,1)
- IDPA = IDPA+KHDPO+KSDPO
- IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
- & IDNA(KHDIR) = IDNA(KHDIR)+1
- DO 55 I=1,IPOIX2
- IENACC(IPORES(I)) = IENACC(IPORES(I))+1
- 55 CONTINUE
- KACCEP = KACCEP+1
-
-C debug output (partial / full event listing)
- if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
- & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
- IF(IDEB(67).GE.10) THEN
- IF(IDEB(67).LE.15) THEN
- CALL PHO_PREVNT(-1)
- ELSE IF(IDEB(67).LE.20) THEN
- CALL PHO_PREVNT(0)
- ELSE IF(IDEB(67).LE.25) THEN
- CALL PHO_PREVNT(1)
- ELSE
- CALL PHO_PREVNT(2)
- ENDIF
- ENDIF
-C
-C effective weight
- DO 65 I=1,10
- IF(IPOWGC(I).GT.0) THEN
- HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
- ENDIF
- 65 CONTINUE
- IF(IVWGHT(1).EQ.1) THEN
- WG = HSWGHT(0)
- IF(WG.GT.1.01D0) THEN
- IF(EVWGHT(1).LT.1.01D0) THEN
- WRITE(LO,'(1X,A,2I12,1PE12.3)')
- & 'PHO_EVENT: cross section weight > 1',
- & KEVENT,KACCEP,WG
- WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
- & SIGGEN(3),SIGGEN(4),EVWGHT(1)
- ENDIF
- EVWGHT(1) = HSWGHT(0)
- HSWGHT(0) = 1.D0
- ELSE
- EVWGHT(1) = 1.D0
- ENDIF
- ENDIF
-
-C effective cross section
- SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
- ECMSUM = ECMSUM+ECM
- SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
- ELSE IF(NEV.EQ.-2) THEN
-
-C ---------------- end of event generation ----------------------
-
-* --- Commented by Chiara
-* WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
-* & '====================================================',
-* & ' --------- summary of event generation ----------',
-* & '====================================================',
-* & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
-* & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
-
-C write out statistics
- IF(KACCEP.GT.0) THEN
-
- FAC1 = SIGGEN(4)/DBLE(KEVENT)
- FAC2 = FAC/DBLE(KACCEP)
-* WRITE(LO,'(/1X,A,/1X,A)')
-* & 'PHO_EVENT: generated and accepted events',
-* & '----------------------------------------'
-* WRITE(LO,'(3X,A)')
-* & 'process, sampled, accepted, cross section (internal/external)'
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
-* & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
-* & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
-* & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
-* & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
-* & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
-* & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
-* & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
-* & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
-* & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
-* & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
-* & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
-* & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
-* & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
-* & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
-* & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
-* & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
-* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
-* & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
-C *** commented by Chiara
-C IF(ISWMDL(14).GT.0) THEN
-C WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
-C & ISWMDL(14)
-C WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
-C WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
-C WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
-C WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
-C WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
-C ENDIF
-* WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
-* & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
-
- CALL PHO_REJSTA(-2)
- CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
- & 0.D0,-2)
- CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
-C statistics of hard scattering processes
-* WRITE(LO,'(2(/1X,A))')
-* & 'PHO_EVENT: statistics of hard scattering processes',
-* & '--------------------------------------------------'
-* DO 43 K=1,4
-* IF(MH_tried(0,K).GT.0) THEN
-* WRITE(LO,'(/5X,A,I3)')
-* & 'process (accepted,x-section internal/external) for IP:',K
-* DO 47 M=0,Max_pro_2
-* WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
-* & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
-* & DBLE(MH_acc_2(M,K))*FAC2
-* 47 CONTINUE
-* ENDIF
-* 43 CONTINUE
-
- ELSE
- WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
- ENDIF
-* WRITE(LO,'(/3(/1X,A)/)')
-* & '======================================================',
-* & ' ------- end of event generation summary --------',
-* & '======================================================'
- ELSE
- WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
- ENDIF
-
- END
-
-CDECK ID>, PHO_PARTON
- SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
-C********************************************************************
-C
-C calculation of complete parton configuration
-C
-C input: IPROC process ID 1 nondiffractive
-C 2 elastic
-C 3 quasi-ela. rho,omega,phi prod.
-C 4 double Pomeron
-C 5 single diff 1
-C 6 single diff 2
-C 7 double diff diss.
-C 8 single-resolved / direct photon
-C JM1,2 index of mother particles in /POEVT1/
-C
-C
-C output: complete parton configuration in /POEVT1/
-C IREJ 1 failure
-C 0 success
-C 50 rejection due to user cutoffs
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION P1(4),P2(4)
-
- PARAMETER ( TINY = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- IREJ = 0
-C clear event statistics
- KSPOM = 0
- KHPOM = 0
- KSREG = 0
- KHDIR = 0
- KSTRG = 0
- KHTRG = 0
- KSLOO = 0
- KHLOO = 0
- KHARD = 0
- KSOFT = 0
- KSDPO = 0
- KHDPO = 0
-
-C-------------------------------------------------------------------
-C nondiffractive resolved processes
-
- IF(IPROC.EQ.1) THEN
-C sample number of interactions
- 555 CONTINUE
- IINT = 0
- IP = 1
-C generate only hard events
- IF(ISWMDL(2).EQ.0) THEN
- MHPOM = 1
- MSPOM = 0
- MSREG = 0
- MHDIR = 0
- HSWGHT(1) = 1.D0
- ELSE
-C minimum bias events
- IPOWGC(1) = 0
- 10 CONTINUE
- CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
- IPOWGC(1) = IPOWGC(1)+1
- MINT = 0
- MHDIR = 0
- MSTRG = 0
- MSLOO = 0
-C
-C resolved soft processes: pomeron and reggeon
- MSPOM = IINT
- MSREG = JINT
-C resolved hard process: hard pomeron
- MHPOM = KINT
-C resolved absorptive corrections
- MPTRI = 0
- MPLOO = 0
-C restrictions given by user
- IF(MSPOM.LT.ISWCUT(1)) GOTO 10
- IF(MSREG.LT.ISWCUT(2)) GOTO 10
- IF(MHPOM.LT.ISWCUT(3)) GOTO 10
- HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
-C ----------------------------
- IF(ISWMDL(15).EQ.0) THEN
- MHPOM = 0
- IF(MSREG.GT.0) THEN
- MSPOM = 0
- MSREG = 1
- ELSE
- MSPOM = 1
- MSREG = 0
- ENDIF
- ELSE IF(ISWMDL(15).EQ.1) THEN
- IF(MHPOM.GT.0) THEN
- MHPOM = 1
- MSPOM = 0
- MSREG = 0
- ELSE IF(MSPOM.GT.0) THEN
- MSPOM = 1
- MSREG = 0
- ELSE
- MSREG = 1
- ENDIF
- ELSE IF(ISWMDL(15).EQ.2) THEN
- MHPOM = MIN(1,MHPOM)
- ELSE IF(ISWMDL(15).EQ.3) THEN
- MSPOM = MIN(1,MSPOM)
- ENDIF
- ENDIF
-C ----------------------------
-
-C statistics
- ISPS = ISPS+MSPOM
- IHPS = IHPS+MHPOM
- ISRS = ISRS+MSREG
- ISTS = ISTS+MSTRG
- ISLS = ISLS+MSLOO
-
- IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
- & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
- & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
-
- ITRY2 = 0
- 50 CONTINUE
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
- KSPOM = MSPOM
- KSREG = MSREG
- KHPOM = MHPOM
- KHDIR = MHDIR
- KSTRG = MPTRI
- KSLOO = MPLOO
-
- CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- IF(MHPOM.GT.0) THEN
- IDNODF = 3
- ELSE IF(MSPOM.GT.0) THEN
- IDNODF = 2
- ELSE
- IDNODF = 1
- ENDIF
-C check of quantum numbers of parton configurations
- IF(IDEB(3).GE.0) THEN
- CALL PHO_CHECK(1,IREJ)
- IF(IREJ.NE.0) GOTO 50
- ENDIF
-C sample strings to prepare fragmentation
- CALL PHO_STRING(1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IFAIL(30) = IFAIL(30)+1
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- IF(ITRY2.LT.20) GOTO 50
- IF(IDEB(3).GE.1) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-
-C statistics
- ISPA = ISPA+KSPOM
- IHPA = IHPA+KHPOM
- ISRA = ISRA+KSREG
- ISTA = ISTA+KSTRG
- ISLA = ISLA+KSLOO
-
-C-------------------------------------------------------------------
-C elastic scattering / quasi-elastic rho/omega/phi production
-
- ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
- IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
- & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
-
-C DPMJET call with special projectile / target: transform into CMS
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(1,JM1,JM2)
-
- CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
-
- IF(IREJ.NE.0) THEN
-C DPMJET call with special projectile / target: clean up
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(-2,JM1,JM2)
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-
-C DPMJET call with special projectile / target: transform back
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(2,JM1,JM2)
-
-C prepare possible decays
- CALL PHO_STRING(1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IFAIL(30) = IFAIL(30)+1
- RETURN
- ENDIF
-
-C---------------------------------------------------------------------
-C double Pomeron scattering
-
- ELSE IF(IPROC.EQ.4) THEN
- MSOFT = 0
- MHARD = 0
- IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
- & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
- IDPS = IDPS+1
- ITRY2 = 0
- 60 CONTINUE
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
-C
- CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-C check of quantum numbers of parton configurations
- IF(IDEB(3).GE.0) THEN
- CALL PHO_CHECK(1,IREJ)
- IF(IREJ.NE.0) GOTO 60
- ENDIF
-C sample strings to prepare fragmentation
- CALL PHO_STRING(1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IFAIL(30) = IFAIL(30)+1
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- IF(ITRY2.LT.10) GOTO 60
- WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
- CALL PHO_PREVNT(-1)
- RETURN
- ENDIF
- IDPA = IDPA+1
-
-C-----------------------------------------------------------------------
-C single / double diffraction dissociation
-
- ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
- MSOFT = 0
- MHARD = 0
- IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
- & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
- IF(IPROC.EQ.5) ID1S = ID1S+1
- IF(IPROC.EQ.6) ID2S = ID2S+1
- IF(IPROC.EQ.7) ID3S = ID3S+1
- ITRY2 = 0
- 70 CONTINUE
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
- IPAR1 = 1
- IPAR2 = 1
- IF(IPROC.EQ.5) IPAR2 = 0
- IF(IPROC.EQ.6) IPAR1 = 0
-C calculate rapidity gap survival probability
- SPROB = 1.D0
- IF(ECM.GT.10.D0) THEN
- IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
- IF(SIGTR1(1).LT.1.D-10) THEN
- SPROB = 1.D0
- ELSE
- SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
- ENDIF
- ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
- IF(SIGTR2(1).LT.1.D-10) THEN
- SPROB = 1.D0
- ELSE
- SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
- ENDIF
- ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
- IF(SIGLOO.LT.1.D-10) THEN
- SPROB = 1.D0
- ELSE
- SPROB = SIGHDD/SIGLOO
- ENDIF
- ENDIF
- ENDIF
-
-**sr
-* temporary patch, r.e. 8.6.99
- SPROB = 1.D0
-**
-
-C DPMJET call with special projectile / target: transform into CMS
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(1,JM1,JM2)
-
- CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
-
- IF(IREJ.NE.0) THEN
-C DPMJET call with special projectile / target: clean up
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(-2,JM1,JM2)
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-
-C DPMJET call with special projectile / target: transform back
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
- & CALL PHO_DFWRAP(2,JM1,JM2)
-
-C check of quantum numbers of parton configurations
- IF(IDEB(3).GE.0) THEN
- CALL PHO_CHECK(1,IREJ)
- IF(IREJ.NE.0) GOTO 70
- ENDIF
-C sample strings to prepare fragmentation
- CALL PHO_STRING(1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IFAIL(30) = IFAIL(30)+1
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- IF(ITRY2.LT.10) GOTO 70
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection',ITRY2
- CALL PHO_PREVNT(-1)
- RETURN
- ENDIF
- IF(IPROC.EQ.5) ID1A = ID1A+1
- IF(IPROC.EQ.6) ID2A = ID2A+1
- IF(IPROC.EQ.7) ID3A = ID3A+1
-
-C-----------------------------------------------------------------------
-C single / double direct processes
-
- ELSE IF(IPROC.EQ.8) THEN
- MSREG = 0
- MSPOM = 0
- MHPOM = 0
- MHDIR = 1
- IF(IDEB(3).GE.5) THEN
- WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
- ENDIF
- IDIS = IDIS+MHDIR
- ITRY2 = 0
- 80 CONTINUE
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
- KSPOM = MSPOM
- KSREG = MSREG
- KHPOM = MHPOM
- KHDIR = 4
-
- CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- IDNODF = 4
-C check of quantum numbers of parton configurations
- IF(IDEB(3).GE.0) THEN
- CALL PHO_CHECK(1,IREJ)
- IF(IREJ.NE.0) GOTO 80
- ENDIF
-C sample strings to prepare fragmentation
- CALL PHO_STRING(1,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IREJ.EQ.50) RETURN
- IFAIL(30) = IFAIL(30)+1
- IF(IDEB(3).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
- CALL PHO_PREVNT(-1)
- ENDIF
- IF(ITRY2.LT.10) GOTO 80
- WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
- CALL PHO_PREVNT(-1)
- RETURN
- ENDIF
- IF(IPROC.EQ.5) ID1A = ID1A+1
- IF(IPROC.EQ.6) ID2A = ID2A+1
- IF(IPROC.EQ.7) ID3A = ID3A+1
- IDIA = IDIA+MHDIR
-
-C-----------------------------------------------------------------------
-C initialize control statistics
-
- ELSE IF(IPROC.EQ.-1) THEN
- CALL PHO_SAMPRB(ECM,-1,0,0,0)
- CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
- CALL PHO_SEAFLA(-1,0,0,DUM)
- IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
- & CALL PHO_QELAST(-1,1,2,0)
- ISPS = 0
- ISPA = 0
- ISRS = 0
- ISRA = 0
- IHPS = 0
- IHPA = 0
- ISTS = 0
- ISTA = 0
- ISLS = 0
- ISLA = 0
- ID1S = 0
- ID1A = 0
- ID2S = 0
- ID2A = 0
- ID3S = 0
- ID3A = 0
- IDPS = 0
- IDPA = 0
- IDIS = 0
- IDIA = 0
- CALL PHO_STRING(-1,IREJ)
- CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
- RETURN
-
-C-----------------------------------------------------------------------
-C produce statistics summary
-
- ELSE IF(IPROC.EQ.-2) THEN
- IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
-C IF(IDEB(3).GE.0) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A,/1X,A)')
-C & 'PHO_PARTON: internal statistics on parton configurations',
-C & '--------------------------------------------------------'
-C WRITE(LO,'(5X,A)') 'process sampled accepted'
-C WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
-C WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
-C WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
-C WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
-C WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
-C WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
-C WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
-C WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
-C WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
-C WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
-C ENDIF
- CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
- IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
- & CALL PHO_QELAST(-2,1,2,0)
- CALL PHO_STRING(-2,IREJ)
- CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
- CALL PHO_SEAFLA(-2,0,0,DUM)
- RETURN
- ELSE
- WRITE(LO,'(1X,A,I2)')
- & 'PARTON:ERROR: unknown process ID ',IPROC
- STOP
- ENDIF
-
- END
-
-CDECK ID>, PHO_MCINI
- SUBROUTINE PHO_MCINI
-C********************************************************************
-C
-C initialization of MC event generation
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PIMASS = 0.13D0,
- & TINY = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C interpolation tables for hard cross section and MC selection weights
- INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
- PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
- INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
- DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
- & HQ2a_tab,HQ2b_tab,HEcm_tab
- COMMON /POHTAB/
- & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
- & HEcm_tab(1:Max_tab_E,0:4),
- & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C cut probability distribution
- INTEGER IEETA1,IIMAX,KKMAX
- PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
- INTEGER IEEMAX,IMAX,KMAX
- REAL PROB
- DOUBLE PRECISION EPTAB
- COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
- & IEEMAX,IMAX,KMAX
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-
- CHARACTER*15 PHO_PNAME
- DIMENSION ECMF(4)
-
- DATA XMPOM / 0.766D0 /
-
-C initialize fragmentation
- CALL PHO_FRAINI(ISWMDL(6))
-
-C reset interpolation tables
- DO 50 I=1,4
- DO 60 J=1,10
- DO 70 K=1,70
- SIGTAB(I,K,J) = 0.D0
- 70 CONTINUE
- SIGECM(I,J) = 0.D0
- 60 CONTINUE
- 50 CONTINUE
-
-C max. number of allowed colors (large N expansion)
- IC1 = 0
- IC2 = 10000
- CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
-
-C lower energy limit of initialization
- ETABLO = PARMDL(19)
- IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
-
-C *** Commented by Chiara
-C WRITE(LO,'(/,1X,A,2F12.1)')
-C & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
-C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
-C & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
-C & PMASS(1),PVIRT(1)
-C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
-C & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
-C & PMASS(2),PVIRT(2)
-
-C cuts on probabilities of multiple interactions
- IMAX = MIN(IPAMDL(32),IIMAX)
- KMAX = MIN(IPAMDL(33),KKMAX)
- AH = 2.D0*PTCUT(1)/ECM
- IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
- KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
-
-C hard interpolation table
- ECMF(1) = ECM
- ECMF(2) = 0.9D0*ECMF(1)
- ECMF(3) = ECMF(2)
- ECMF(4) = ECMF(2)
- do k=1,4
- IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
- IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
- IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
- IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
- enddo
-
-C initialization of hard scattering for all channels and cutoffs
- IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
- I0 = 4
- IF(ISWMDL(2).EQ.0) I0 = 1
- DO 110 I=I0,1,-1
- CALL PHO_HARMCI(I,ECMF(I))
- 110 CONTINUE
-
-C dimension of interpolation table of cut probabilities
- IEEMAX = MIN(IPAMDL(31),IEETA1)
- IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
- IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
- IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
- ISIMAX = IEEMAX
-
-C calculate probability distribution
- I0 = 4
- IFT1 = IFPAP(1)
- IFT2 = IFPAP(2)
- XMT1 = PMASS(1)
- XMT2 = PMASS(2)
- XVT1 = PVIRT(1)
- XVT2 = PVIRT(2)
- IF(ISWMDL(2).EQ.0) I0 = 1
- DO 150 IP=I0,1,-1
- ECMPRO = ECMF(IP)*1.001D0
- IF(IP.EQ.4) THEN
- IFPAP(1) = 990
- IFPAP(2) = 990
- PMASS(1) = XMPOM
- PMASS(2) = XMPOM
- PVIRT(1) = 0.D0
- PVIRT(2) = 0.D0
- ELSE IF(IP.EQ.3) THEN
- IFPAP(1) = IFT2
- IFPAP(2) = 990
- PMASS(1) = XMT2
- PMASS(2) = XMPOM
- PVIRT(1) = XVT2
- PVIRT(2) = 0.D0
- ELSE IF(IP.EQ.2) THEN
- IFPAP(1) = IFT1
- IFPAP(2) = 990
- PMASS(1) = XMT1
- PMASS(2) = XMPOM
- PVIRT(1) = XVT1
- PVIRT(2) = 0.D0
- ELSE
- IFPAP(1) = IFT1
- IFPAP(2) = IFT2
- PMASS(1) = XMT1
- PMASS(2) = XMT2
- PVIRT(1) = XVT1
- PVIRT(2) = XVT2
- ENDIF
- IF(IEEMAX.GT.1) THEN
- IF(IP.EQ.1) THEN
- ELMIN = LOG(ETABLO)
- ELSE
- ELMIN = LOG(2.5D0)
- ENDIF
- EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
- DO 100 I=1,IEEMAX
- ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
- CALL PHO_PRBDIS(IP,ECMPRO,I)
- 100 CONTINUE
- ELSE
- CALL PHO_PRBDIS(IP,ECMPRO,1)
- ENDIF
-
-C debug output of cross section tables
- IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
- IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
-* --- Commented by Chiara
-* WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
-* &'Table of total cross sections (mb) for particle combination',IP,
-* &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
-* &'-------------------------------------------------------------'
-* DO 200 I=1,IEEMAX
-* WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
-* & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
-* & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
-* & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
-* & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
-* 200 CONTINUE
- 201 CONTINUE
- IF(IDEB(62).GE.2) THEN
- WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
- &'Table of partial x-sections (mb) for particle combination',IP,
- &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
- &'--------------------------------------------------------------'
- DO 205 I=1,IEEMAX
- WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
- & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
- & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
- 205 CONTINUE
- ENDIF
- IF(IDEB(62).GE.2) THEN
- WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
- &'Table of born graph x-sections (mb) for particle combination',IP,
- &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
- &'-------------------------------------------------------------'
- DO 210 I=1,IEEMAX
- WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
- & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
- & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
- & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
- & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
- & +SIGTAB(IP,68,I)
- 210 CONTINUE
- WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
- &'Table of unitarized x-sections (mb) for particle combination',IP,
- &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
- &'-------------------------------------------------------------'
- DO 215 I=1,IEEMAX
- WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
- & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
- & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
- 215 CONTINUE
- ENDIF
- IF(IDEB(62).GE.1) THEN
- WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
- &'Table of expected average number of cuts in non-diff events:',
- &' for max. number of cuts soft/hard:',IMAX,KMAX,
- &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
- &'---------------------------------------------'
- DO 220 I=1,IEEMAX
- WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
- & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
- & SIGTAB(IP,76,I)
- 220 CONTINUE
- IF(IP.EQ.1) THEN
- WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
- & 'Table of rapidity gap survival probability (high-mass diff.):',
- & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
- & '---------------------------------------------------'
- DO 230 I=1,IEEMAX
- IF(SIGECM(IP,I).GT.10.D0) THEN
- SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
- & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
- SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
- & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
- SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
- & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
- & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
- SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
- & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
- WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
- & SPRSD1,SPRSD2,SPRDD,SPRCDF
- ENDIF
- 230 CONTINUE
- ENDIF
- ENDIF
- ENDIF
- 150 CONTINUE
-
-C simulate only hard scatterings
- IF(ISWMDL(2).EQ.0) THEN
- WRITE(LO,'(2(/1X,A))')
- & 'WARNING: generation of hard scatterings only!',
- & '============================================='
- DO 151 I=2,7
- IPRON(I,1) = 0
- 151 CONTINUE
- DO 152 K=2,4
- DO 153 I=1,15
- IPRON(I,K) = 0
- 153 CONTINUE
- 152 CONTINUE
- SIGGEN(4) = 0.D0
- DO 160 I=1,IEEMAX
- SIGMAX = 0.D0
- IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
- IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
- IF(SIGMAX.GT.SIGGEN(4)) THEN
- ISIGM = I
- SIGGEN(4) = SIGMAX
- ENDIF
- 160 CONTINUE
- ELSE
-* --- Commented by Chiara
-* WRITE(LO,'(2(/1X,A))')
-* & 'activated processes, cross section',
-* & '----------------------------------'
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' elastic scattering',(IPRON(2,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' double pomeron processes',(IPRON(4,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' double diffract. processes',(IPRON(7,K),K=1,4)
-* WRITE(LO,'(5X,A,I3,2X,3I3)')
-* & ' direct photon processes',(IPRON(8,K),K=1,4)
-
-C calculate effective cross section
- SIGGEN(4) = 0.D0
- DO 165 I=1,IEEMAX
- CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
- & PVIRT(1),PVIRT(2))
- SIGMAX = 0.D0
- if(iswmdl(2).ge.1) then
- IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
- & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
- & -SIGLDD-SIGHDD-SIGDIR
- IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
- IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
- IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
- IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
- IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
- IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
- IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
- else
- IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
- IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
- endif
- IF(SIGMAX.GT.SIGGEN(4)) THEN
- ISIGM = I
- SIGGEN(4) = SIGMAX
- ENDIF
- 165 CONTINUE
- ENDIF
-
-C debug output
- IF(SIGGEN(4).LT.1.D-20) THEN
- WRITE(LO,'(//1X,A)')
- & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
- STOP
- ENDIF
- WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
- & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
- WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
-
- END
-
-CDECK ID>, PHO_REJSTA
- SUBROUTINE PHO_REJSTA(IMODE)
-C********************************************************************
-C
-C MC rejection counting
-C
-C input IMODE -1 initialization
-C -2 output of statistics
-C
-C********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- INTEGER IMODE
-
- INTEGER I
-
-C initialization
- IF(IMODE.EQ.-1) THEN
- DO 100 I=1,NMXJ
- IFAIL(I) = 0
- 100 CONTINUE
-C
- REJTIT(1) = 'PARTON ALL'
- REJTIT(2) = 'STDPAR ALL'
- REJTIT(3) = 'STDPAR DPO'
- REJTIT(4) = 'POMSCA ALL'
- REJTIT(5) = 'POMSCA INT'
- REJTIT(6) = 'POMSCA KIN'
- REJTIT(7) = 'DIFDIS ALL'
- REJTIT(8) = 'POSPOM ALL'
- REJTIT(9) = 'HRES.DIF.1'
- REJTIT(10) = 'HDIR.DIF.1'
- REJTIT(11) = 'HRES.DIF.2'
- REJTIT(12) = 'HDIR.DIF.2'
- REJTIT(13) = 'DIFDIS INT'
- REJTIT(14) = 'HADRON SP2'
- REJTIT(15) = 'HADRON SP3'
- REJTIT(16) = 'HARDIR ALL'
- REJTIT(17) = 'HARDIR INT'
- REJTIT(18) = 'HARDIR KIN'
- REJTIT(19) = 'MCHECK BAR'
- REJTIT(20) = 'MCHECK MES'
- REJTIT(21) = 'DIF.DISS.1'
- REJTIT(22) = 'DIF.DISS.2'
- REJTIT(23) = 'STRFRA ALL'
- REJTIT(24) = 'MSHELL CHA'
- REJTIT(25) = 'PARTPT SOF'
- REJTIT(26) = 'PARTPT HAR'
- REJTIT(27) = 'INTRINS KT'
- REJTIT(28) = 'HACHEK DIR'
- REJTIT(29) = 'HACHEK RES'
- REJTIT(30) = 'STRING ALL'
- REJTIT(31) = 'POMSCA INT'
- REJTIT(32) = 'DIFF SLOPE'
- REJTIT(33) = 'GLU2QU ALL'
- REJTIT(34) = 'MASCOR ALL'
- REJTIT(35) = 'PARCOR ALL'
- REJTIT(36) = 'MSHELL PAR'
- REJTIT(37) = 'MSHELL ALL'
- REJTIT(38) = 'POMCOR ALL'
- REJTIT(39) = 'DB-POM KIN'
- REJTIT(40) = 'DB-POM ALL'
- REJTIT(41) = 'SOFTXX ALL'
- REJTIT(42) = 'SOFTXX PSP'
-
-C write output
-* --- Commented by Chiara
-* ELSE IF(IMODE.EQ.-2) THEN
-* WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
-* & '--------------------------------'
-* DO 300 I=1,NMXJ
-* IF(IFAIL(I).GT.0)
-* & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
-* 300 CONTINUE
-* ELSE
-* WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
- ENDIF
-
- END
-
-CDECK ID>, PHO_POSPOM
- SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
-C***********************************************************************
-C
-C registration of one cut pomeron (soft/semihard)
-C
-C input: IP particle combination the pomeron belongs to
-C IND1,2 position of X values in /POSOFT/
-C 1 corresponds to a valence-pomeron
-C IGEN production process of mother particles
-C IPOM pomeron number
-C KCUT total number of cut pomerons and reggeons
-C
-C output: ISWAP exchange of x values
-C IND1,2 increased by the number of partons belonging
-C to the generated pomeron cut
-C IREJ success/failure
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-8 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-
- DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
-
- IREJ = 0
- ISWAP = 0
- JM1 = NPOSP(1)
- JM2 = NPOSP(2)
- INDX1 = IND1
- INDX2 = IND2
- EA1 = XS1(IND1)*ECMP/2.D0
- EA2 = XS1(IND1+1)*ECMP/2.D0
- EB1 = XS2(IND2)*ECMP/2.D0
- EB2 = XS2(IND2+1)*ECMP/2.D0
- CMASS1 = MIN(EA1,EA2)
- CMASS2 = MIN(EB1,EB2)
-
-C debug output
- IF(IDEB(9).GE.20) THEN
- WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
- & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
- WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
- & CMASS1,CMASS2
- ENDIF
-
-C flavours
- IF(IND1.EQ.1) THEN
- CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
- ELSE
- CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
- ENDIF
- IF(IND2.EQ.1) THEN
- CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
- ELSE
- CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
- ENDIF
- DO 75 I=1,4
- P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
- P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
- 75 CONTINUE
-
-C pomeron resolved?
- IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
-C find energy for cross section calculation
- IF(IPAMDL(16).EQ.2) THEN
- ESUB = ECMP
- ELSE IF(IPAMDL(16).EQ.3) THEN
- IF(IPROCE.EQ.1) THEN
- ESUB = ECM
- ELSE
- ESUB = ECMP
- ENDIF
- ELSE
- ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
- & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
- ENDIF
-C load cross sections from interpolation table
- IF(ESUB.LE.SIGECM(IP,1)) THEN
- I1 = 1
- I2 = 2
- ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
- DO 50 I=2,ISIMAX
- IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
- 50 CONTINUE
- 200 CONTINUE
- I1 = I-1
- I2 = I
- ELSE
- WRITE(LO,'(/1X,A,2E12.3)')
- & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
- CALL PHO_PREVNT(-1)
- I1 = ISIMAX-1
- I2 = ISIMAX
- ENDIF
- FAC2=0.D0
- IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
- & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
- FAC1=1.D0-FAC2
-C calculate weights
-* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
-* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
-* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
-* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
-* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
-* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
-
- WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
- & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
- WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
- WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
- WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
- & +SIGTAB(IP,64,I2))
- & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
- & +SIGTAB(IP,64,I1))
- WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
- & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
- & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
- & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
-
-C one-pomeron cut
- WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
-C central diff. cut
- WGX(2) = WGXCDF
-C diff. diss. of particle 1
- WGX(3) = WGXHSD(1)
-C diff. diss. of particle 2
- WGX(4) = WGXHSD(2)
-C double diff. dissociation
- WGX(5) = WGXHDD
-C two-pomeron cut
- WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
-
-* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
-* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
-* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
-* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
-* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
-* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
-* ENDIF
-
- SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
-
-C selection loop
- 205 CONTINUE
- XI = DT_RNDM(SUM)*SUM
- I = 0
- SUM = 0.D0
- 210 CONTINUE
- I = I+1
- SUM = SUM+WGX(I)
- IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
-C phase space correction
- IF(I.NE.1) THEN
- ISAM = 4
- IF(I.EQ.6) ISAM = 8
- PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
-* IF(DT_RNDM(SUM).GT.PACC) I=1
- IF(DT_RNDM(SUM).GT.PACC) GOTO 205
- ENDIF
-
-C do not generate diffraction for events with only one cut pomeron
- IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
-
-C do not generate recursive calls for remants with
-C diquark-anti-diquark flavour contents
- if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
- if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
-
-C debug output
- IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
- & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
-
- IF(I.GT.1) THEN
-C second scattering needed
- CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
- CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
- IDPD1 = IPHO_ID2PDG(IDHA1)
- IDPD2 = IPHO_ID2PDG(IDHA2)
-
- if(INDX1.eq.1) then
- if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
- & IGEN_had = IGEN
- else
- IGEN_had = -IGEN
- endif
- CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
- & IPOM,IGEN_had,0,0,IPOS1,1)
-
- if(INDX2.eq.1) then
- if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
- & IGEN_had = IGEN
- else
- IGEN_had = -IGEN
- endif
- CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
- & IPOM,IGEN_had,0,0,IPOS1,1)
-
- IND1 = IND1+2
- IND2 = IND2+2
-C update index
- IPOIX2 = IPOIX2+1
-
- IF(IPOIX2.GT.MAXIPX) THEN
- WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
- & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
- IREJ = 1
- RETURN
- ENDIF
-
- IPORES(IPOIX2) = I+2
- IPOPOS(1,IPOIX2) = IPOS1-1
- IPOPOS(2,IPOIX2) = IPOS1
- RETURN
- ENDIF
- ENDIF
-
- 100 CONTINUE
- IF(ISWMDL(12).EQ.0) THEN
-C sample colors
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
-
-C purely gluonic pomeron or sea strings formed by gluons
-
- IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
- & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
- IFLA1 = 21
- IFLA2 = 21
- ENDIF
- IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
- & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
- IFLB1 = 21
- IFLB2 = 21
- ENDIF
-
-C color connection
- IF(IFLA1.NE.21) THEN
- IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
- & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
- & CALL PHO_SWAPI(ICA1,ICD1)
- ENDIF
- IF(IFLB1.NE.21) THEN
- IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
- & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
- & CALL PHO_SWAPI(ICB1,ICC1)
- ENDIF
- ISWAP = 0
- IF(ICA1*ICB1.GT.0) THEN
- IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
- IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
- CALL PHO_SWAPI(IFLA1,IFLA2)
- CALL PHO_SWAPI(ICA1,ICD1)
- ELSE
- CALL PHO_SWAPI(IFLB1,IFLB2)
- CALL PHO_SWAPI(ICB1,ICC1)
- ENDIF
- ELSE IF(IND1.NE.1) THEN
- CALL PHO_SWAPI(IFLA1,IFLA2)
- CALL PHO_SWAPI(ICA1,ICD1)
- ELSE IF(IND2.NE.1) THEN
- CALL PHO_SWAPI(IFLB1,IFLB2)
- CALL PHO_SWAPI(ICB1,ICC1)
- ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
- IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
- CALL PHO_SWAPI(IFLA1,IFLA2)
- CALL PHO_SWAPI(ICA1,ICD1)
- ELSE
- CALL PHO_SWAPI(IFLB1,IFLB2)
- CALL PHO_SWAPI(ICB1,ICC1)
- ENDIF
- ELSE IF(IFLA1.EQ.-IFLA2) THEN
- CALL PHO_SWAPI(IFLA1,IFLA2)
- CALL PHO_SWAPI(ICA1,ICD1)
- ELSE IF(IFLB1.EQ.-IFLB2) THEN
- CALL PHO_SWAPI(IFLB1,IFLB2)
- CALL PHO_SWAPI(ICB1,ICC1)
- ELSE
- ISWAP = 1
- IF(IDEB(9).GE.5) THEN
- WRITE(LO,'(1X,A,I12)')
- & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
- WRITE(LO,'(5X,A,4I7)')
- & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
- WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
- ENDIF
- ENDIF
- ENDIF
-
-C registration
-
-C purely gluonic pomeron or sea strings formed by gluons
- IF(IFLA1.EQ.21) THEN
- CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
- & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
- IND1 = IND1+2
-
-C strings formed by quarks
- ELSE
-C valence quark labels
- IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
- & .and.(IDHEP(JM1).NE.990)) THEN
- ICA2 = 1
- ICD2 = 1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
- & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
- & ICA2,IPOS1,1)
- IND1 = IND1+1
- CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
- & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
- & ICD2,IPOS,1)
- IND1 = IND1+1
-
- ENDIF
-
-C purely gluonic pomeron or sea strings formed by gluons
- IF(IFLB1.EQ.21) THEN
- CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
- & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
- IND2 = IND2+2
-
-C strings formed by quarks
- ELSE
-C valence quark labels
- IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
- & .and.(IDHEP(JM2).NE.990)) THEN
- ICB2 = 1
- ICC2 = 1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
- & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
- & ICB2,IPOS,1)
- IND2 = IND2+1
- CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
- & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
- & ICC2,IPOS2,1)
- IND2 = IND2+1
-
- ENDIF
-
-C soft pt assignment
- IF(ISWMDL(18).EQ.0) THEN
- CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(25) = IFAIL(25)+1
- RETURN
- ENDIF
- ENDIF
- ELSE
-* CALL PHO_BFKL(P1,P2,IPART,IREJ)
-* IF(IREJ.NE.0) RETURN
- ENDIF
-
- END
-
-CDECK ID>, PHO_HADSP2
- SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
-C***********************************************************************
-C
-C split hadron momentum XMAX into two partons using
-C lower cut-off: AS
-C
-C input: IFLB compressed particle code of particle to split
-C XS1 sum of x values already selected
-C XMAX maximal x possible
-C
-C output: XS1 new sum of x values (without first one)
-C XSOFT1 field of selected x values
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-8 )
-
- DIMENSION XSOFT1(50)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-
-C model exponents
- DATA PVMES1 /-0.5D0/
- DATA PVMES2 /-0.5D0/
- DATA PVBAR1 / 1.5D0/
- DATA PVBAR2 /-0.5D0/
-C
- IREJ = 0
- ITMAX = 100
-C
-C mesonic particle
- IF(ipho_bar3(IFLB,0).EQ.0) THEN
- XPOT1 = PVMES1+1.D0
- XPOT2 = PVMES2+1.D0
-C baryonic particle
- ELSE
- XPOT1 = PVBAR1+1.D0
- XPOT2 = PVBAR2+1.D0
- ENDIF
- ITER = 0
- XREST= 1.D0-XS1
-C selection loop
- 100 CONTINUE
- ITER = ITER+1
- IF(ITER.GE.ITMAX) THEN
- IF(IDEB(39).GE.3) THEN
- WRITE(LO,'(1X,A,I8)')
- & 'PHO_HADSP2: REJECTION (ITER)',ITER
- WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
- ENDIF
- IFAIL(14) = IFAIL(14)+1
- IREJ = 1
- RETURN
- ENDIF
- ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
- IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
- XSS1 = XS1 + ZZ
- IF((1.D0-XSS1).LT.AS) GOTO 100
-C
- XS1 = XSS1
- XSOFT1(1) = 1.D0-XSS1
- XSOFT1(2) = ZZ
-C debug output
- IF(IDEB(39).GE.10) THEN
- WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
- WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
- & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
- ENDIF
- END
-
-CDECK ID>, PHO_HADSP3
- SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
-C***********************************************************************
-C
-C split hadron momentum XMAX into diquark & quark pair
-C using lower cut-off: AS
-C
-C input: IFLB compressed particle code of particle to split
-C XS1 sum of x values already selected
-C XMAX maximal x possible
-C
-C output: XS1 new sum of x values
-C XSOFT1 field of selected x values
-C
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
- PARAMETER ( DEPS = 1.D-8 )
-
- DIMENSION XSOFT1(50),XSOFT2(50)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-
- DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
-
-C model exponents
- DATA PVMES1 /-0.5D0/
- DATA PVMES2 /-0.5D0/
- DATA PSMES /-0.99D0/
- DATA PVBAR1 / 1.5D0/
- DATA PVBAR2 /-0.5D0/
- DATA PSBAR /-0.99D0/
-C
- IREJ = 0
-C
-C determine exponents
-C particle 1
-C
- XMMIN = 0.3D0/ECMP
- XBMIN = 1.6D0/ECMP
-C mesonic particle
- IF(ipho_bar3(IFLB,0).EQ.0) THEN
- XPOT1(1) = PVMES1
- XMIN(1,1) = XMMIN
- XPOT1(2) = PVMES2
- XMIN(1,2) = XMMIN
- XPOT1(3) = PSMES
- XMIN(1,3) = XMMIN
-C baryonic particle
- ELSE
- XPOT1(1) = PVBAR1
- XMIN(1,1) = XBMIN
- XPOT1(2) = PVBAR2
- XMIN(1,2) = XMMIN
- XPOT1(3) = PSBAR
- XMIN(1,3) = XMMIN
- ENDIF
-C particle 2
-C mesonic particle
- XPOT2(1) = PVMES1
- XMIN(2,1) = XMMIN
- XPOT2(2) = PVMES2
- XMIN(2,2) = XMMIN
- XPOT2(3) = PSMES
- XMIN(2,3) = XMMIN
-C
- XDUM1 = 0.01D0
- XDUM2 = 0.99D0
- CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
- & XSOFT1,XSOFT2,IREJ)
-C rejection?
- IF(IREJ.NE.0) THEN
- IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
- & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
- IFAIL(15) = IFAIL(15)+1
- IREJ = 1
- RETURN
- ENDIF
-C debug output
- IF(IDEB(74).GE.10) THEN
- WRITE(LO,'(1X,A,I6,2E12.4)')
- & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
- DO 100 I=1,3
- WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
- 100 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_SOFTXX
- SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
- & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
-C***********************************************************************
-C
-C select soft x values
-C
-C input: JM1,JM2 mother particle index in POEVT1
-C (0 flavour not known before)
-C MSPAR1,2 number of x values to select
-C IVAL1,2 number valence quarks involved in hard
-C scattering (0,1,2)
-C MSM1,2 minimum number of soft x to get sampled
-C XSUM1,2 sum of all x values samples up this call
-C XMAX1,2 max. x value
-C
-C output XSUM1,2 new sum of x-values sampled
-C XS1,2 field containing sampled x values
-C
-C x values of valence partons are first given
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-
- DIMENSION XS1(*),XS2(*)
-
- INTEGER MAXPOT
- PARAMETER ( MAXPOT = 50 )
- DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
-
- IREJ = 0
-
- MSMAX = MAX(MSPAR1,MSPAR2)
- MSMIN = MAX(MSM1,MSM2)
-
- IF(MSMAX.GT.MAXPOT) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
- & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
- IREJ = 1
- RETURN
- ENDIF
-
-C determine exponents
- IBAR1 = ipho_bar3(JM1,2)
- IBAR2 = ipho_bar3(JM2,2)
- ISWAP = 0
- IF((IBAR1*IBAR2).LT.0) ISWAP = 1
-C meson-baryon scattering (asymmetric sea)
- IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
- PSBAR = PARMDL(53)
- PSMES = PARMDL(57)
- ELSE
- PSBAR = PARMDL(52)
- PSMES = PARMDL(56)
- ENDIF
-
-C lower limits for x sampling
- XMMINA = 2.D0*PARMDL(157)/ECMP
- XBMINA = 2.D0*PARMDL(158)/ECMP
- XSMINA = 2.D0*PARMDL(159)/ECMP
- XMIN1 = MAX(XSOMIN,AS/XMAX2)
- XMIN2 = MAX(XSOMIN,AS/XMAX1)
- XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
- XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
- XMIN1 = MAX(AS/XMAX2,XMIN1)
- XMIN2 = MAX(AS/XMAX1,XMIN2)
-
-C particle 1
- XMMIN1 = MAX(XMIN1,XMMINA)
- XBMIN1 = MAX(XMIN1,XBMINA)
- XSMIN1 = MAX(XMIN1,XSMINA)
-C mesonic particle
- IF(IBAR1.EQ.0) THEN
- IF(IHFLS(1).EQ.0) THEN
- XPOT1(1) = PARMDL(62)
- XMIN(1,1) = XSMIN1
- XPOT1(2) = PARMDL(63)
- XMIN(1,2) = XSMIN1
- ELSE
- XPOT1(1) = PARMDL(54)
- XMIN(1,1) = XMMIN1
- XPOT1(2) = PARMDL(55)
- XMIN(1,2) = XMMIN1
- ENDIF
- DO 100 I=3-IVAL1,MSMAX
- XPOT1(I) = PSMES
- XMIN(1,I) = XSMIN1
- 100 CONTINUE
-C baryonic particle
- ELSE
- IF(IHFLS(1).EQ.0) THEN
- XPOT1(1) = PARMDL(62)
- XMIN(1,1) = XSMIN1
- XPOT1(2) = PARMDL(63)
- XMIN(1,2) = XSMIN1
- ELSE
- XPOT1(1) = PARMDL(50)
- XMIN(1,1) = XBMIN1
- XPOT1(2) = PARMDL(51)
- XMIN(1,2) = XMMIN1
- ENDIF
- DO 200 I=3-IVAL1,MSMAX
- XPOT1(I) = PSBAR
- XMIN(1,I) = XSMIN1
- 200 CONTINUE
- ENDIF
-
-C particle 2
- XMMIN2 = MAX(XMIN2,XMMINA)
- XBMIN2 = MAX(XMIN2,XBMINA)
- XSMIN2 = MAX(XMIN2,XSMINA)
-C mesonic particle
- IF(IBAR2.EQ.0) THEN
- IF(IHFLS(2).EQ.0) THEN
- XPOT2(1) = PARMDL(62)
- XMIN(2,1) = XSMIN2
- XPOT2(2) = PARMDL(63)
- XMIN(2,2) = XSMIN2
- ELSE
- XPOT2(1) = PARMDL(54)
- XMIN(2,1) = XMMIN2
- XPOT2(2) = PARMDL(55)
- XMIN(2,2) = XMMIN2
- ENDIF
- DO 300 I=3-IVAL2,MSMAX
- XPOT2(I) = PSMES
- XMIN(2,I) = XSMIN2
- 300 CONTINUE
-C baryonic particle
- ELSE
- IF(IHFLS(2).EQ.0) THEN
- XPOT2(1) = PARMDL(62)
- XMIN(2,1) = XSMIN2
- XPOT2(2) = PARMDL(63)
- XMIN(2,2) = XSMIN2
- ELSE
- XPOT2(1) = PARMDL(50)
- XMIN(2,1) = XBMIN2
- XPOT2(2) = PARMDL(51)
- XMIN(2,2) = XMMIN2
- ENDIF
- DO 400 I=3-IVAL2,MSMAX
- XPOT2(I) = PSBAR
- XMIN(2,I) = XSMIN2
- 400 CONTINUE
- ENDIF
-
- XSS1 = XSUM1
- XSS2 = XSUM2
- MSOFT = MSMAX
-
-C check limits (important for valences)
- IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
- IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
-
- XMINS1 = XSS1
- IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
- XMINS2 = XSS2
- IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
- DO 10 I=1,MSOFT
- XMINS1 = XMINS1+XMIN(1,I)
- XMINS2 = XMINS2+XMIN(2,I)
- 10 CONTINUE
- IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
-
-C try to sample x values
- IF(IPAMDL(14).EQ.0) THEN
- IF(MSOFT.EQ.2) THEN
- CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
- & XS1,XS2,IREJ)
- ELSE IF(MSOFT.LT.5) THEN
- CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ELSE
- CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ENDIF
- ELSE IF(IPAMDL(14).EQ.1) THEN
- IF(MSOFT.EQ.2) THEN
- CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
- & XS1,XS2,IREJ)
- ELSE
- CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ENDIF
- ELSE IF(IPAMDL(14).EQ.2) THEN
- CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ELSE IF(IPAMDL(14).EQ.3) THEN
- IF(MSOFT.EQ.2) THEN
- CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
- & XS1,XS2,IREJ)
- ELSE IF(IVAL1+IVAL2.EQ.0) THEN
- CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ELSE
- CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
- & XMAXP1,XMAXP2,XS1,XS2,IREJ)
- ENDIF
- ELSE
- WRITE(LO,'(/,1X,A,I3)')
- & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
- STOP
- ENDIF
- IF(IREJ.NE.0) THEN
- IFAIL(41) = IFAIL(41)+1
- IF(IDEB(60).GE.2) THEN
- WRITE(LO,'(1X,A,I12,4I3)')
- & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
- & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
- WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
- & XSUM1,XSUM2,XMAX1,XMAX2
- ENDIF
- RETURN
- ENDIF
- IF(MSOFT.NE.MSMAX) THEN
- MSDIFF = MSMAX-MSOFT
- MSPAR1 = MSPAR1-MSDIFF
- MSPAR2 = MSPAR2-MSDIFF
- ENDIF
-
-C correct for different MSPAR numbers
- IF(MSOFT.NE.MSPAR1) THEN
- IF(MSPAR1.GT.1) THEN
- XDEL = 0.D0
- DO 500 I=MSPAR1+1,MSOFT
- XDEL = XDEL+XS1(I)
- 500 CONTINUE
- XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
- DO 550 I=2,MSPAR1
- XS1(I) = XS1(I)*XFAC
- 550 CONTINUE
- XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
- ELSE
- XSS1 = XSUM1
- ENDIF
- ENDIF
- IF(MSOFT.NE.MSPAR2) THEN
- IF(MSPAR2.GT.1) THEN
- XDEL = 0.D0
- DO 600 I=MSPAR2+1,MSOFT
- XDEL = XDEL+XS2(I)
- 600 CONTINUE
- XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
- DO 650 I=2,MSPAR2
- XS2(I) = XS2(I)*XFAC
- 650 CONTINUE
- XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
- ELSE
- XSS2 = XSUM2
- ENDIF
- ENDIF
-
-C first x entry
- XS1(1) = 1.D0 - XSS1
- XS2(1) = 1.D0 - XSS2
- XSUM1 = XSS1
- XSUM2 = XSS2
-
-C debug output
- IF(IDEB(60).GE.10) THEN
- WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
- & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
- & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
- WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
- DO 30 I=1,MSOFT
- WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
- & XMIN(1,I),XMIN(2,I)
- 30 CONTINUE
- ENDIF
-
- RETURN
-
-C not enough phase space
- 1000 CONTINUE
-
- IFAIL(42) = IFAIL(42)+1
- IREJ = 1
-
-C warning message
- IF(IDEB(60).GE.1) THEN
- WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
- & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
- & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
- & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
- WRITE(LO,'(1X,A,1P,3E11.3)')
- & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
- WRITE(LO,'(1X,A,1P,3E11.3)')
- & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
- WRITE(LO,'(1X,A,1P,3E11.3)')
- & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
- WRITE(LO,'(1X,A)')
- & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
- DO 27 I=1,MSOFT
- WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
- 27 CONTINUE
- WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
- & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
- & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
- WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
- DO 25 I=1,MSOFT
- WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
- & XMIN(1,I),XMIN(2,I)
- 25 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_SELSXR
- SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
- & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
-C***********************************************************************
-C
-C select x values of soft string ends (rejection method)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-
- DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
-
- IF(IDEB(13).GE.10) THEN
- WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
- WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
- & MSOFT,XS1,XS2,XMAX1,XMAX2
- DO 40 I=1,MSOFT
- WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
- 40 CONTINUE
- ENDIF
-C
- IREJ = 0
-C
- XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
- XMIN1 = MAX(AS/XMAX1,XMINK)
- XMIN2 = MAX(AS/XMAX2,XMINK)
-C
- IF(MSOFT.EQ.1) THEN
- XSOFT1(2) = 0.D0
- XSOFT2(2) = 0.D0
- RETURN
- ENDIF
- XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
- & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
-C
- 10 CONTINUE
-C
- DO 50 I=2,MSOFT
- POT(1,I) = XPOT1(I)+1.D0
- POT(2,I) = XPOT2(I)+1.D0
- REVP(1,I) = 1.D0/POT(1,I)
- REVP(2,I) = 1.D0/POT(2,I)
- XLMIN(1,I) = XMIN(1,I)**POT(1,I)
- XLMAX = XMAX1**POT(1,I)
- XLDIF(1,I) = XLMAX-XLMIN(1,I)
- XLMIN(2,I) = XMIN(2,I)**POT(2,I)
- XLMAX = XMAX2**POT(2,I)
- XLDIF(2,I) = XLMAX-XLMIN(2,I)
- 50 CONTINUE
-C
- ITRY0 = 0
- 5 CONTINUE
- ITRY0 = ITRY0 + 1
- IF(ITRY0.GE.IPAMDL(181)) THEN
- IF(MSOFT-MSMIN.GE.2) THEN
- MSOFT = MSMIN
- GOTO 10
- ENDIF
- GOTO 1000
- ENDIF
- XREST1 = 1.D0-XS1
- XREST2 = 1.D0-XS2
- DO 100 I=2,MSOFT
- ITRY1 = 0
-
- 20 CONTINUE
- Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
- Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
- XSOFT1(I) = Z1**REVP(1,I)
- XSOFT2(I) = Z2**REVP(2,I)
- ITRY1 = ITRY1+1
- IF(ITRY1.GE.50) GOTO 1000
- IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
-
- XREST1 = XREST1-XSOFT1(I)
- IF(XREST1.LT.XMIN1) GOTO 5
- IF(XREST1.LT.XMIN(1,1)) GOTO 5
- XREST2 = XREST2-XSOFT2(I)
- IF(XREST2.LT.XMIN2) GOTO 5
- IF(XREST2.LT.XMIN(2,1)) GOTO 5
- IF(XREST1*XREST2.LT.AS) GOTO 5
-
- 100 CONTINUE
- XSOFT1(1) = XREST1
- XSOFT2(1) = XREST2
- IREJ=0
-* XX = 1.D0
-* DO 200 I=2,MSOFT
-* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
-*200 CONTINUE
- XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
- IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
-
- XS1 = 1.D0-XREST1
- XS2 = 1.D0-XREST2
- RETURN
-
- 1000 CONTINUE
- IREJ = 1
- IF(IDEB(13).GE.2) THEN
- WRITE(LO,'(1X,A,2I4)')
- & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
- WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
- ENDIF
-
- END
-
-CDECK ID>, PHO_SELSX2
- SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
- & XS1,XS2,IREJ)
-C***********************************************************************
-C
-C select x values of soft string ends using PHO_RNDBET
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-
- IREJ = 0
-
- IF(IDEB(32).GE.10) THEN
- WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
- WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
- & AS,XSUM1,XSUM2,XMAX1,XMAX2
- DO 30 I=1,2
- WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
- 30 CONTINUE
- ENDIF
-
- FAC1 = 1.D0-XSUM1
- FAC2 = 1.D0-XSUM2
- FAC = FAC1*FAC2
- GAM1 = XPOT1(1)+1.D0
- GAM2 = XPOT2(1)+1.D0
- BET1 = XPOT1(2)+1.D0
- BET2 = XPOT2(2)+1.D0
-
- ITRY0 = 0
- DO 100 I=1,IPAMDL(182)
-
- ITRY1 = 0
- 10 CONTINUE
- X1 = PHO_RNDBET(GAM1,BET1)
- ITRY1 = ITRY1+1
- IF(ITRY1.GE.50) GOTO 1000
- IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
-
- ITRY2 = 0
- 11 CONTINUE
- X2 = PHO_RNDBET(GAM2,BET2)
- ITRY2 = ITRY2+1
- IF(ITRY2.GE.50) GOTO 1000
- IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
-
- X3 = 1.D0 - X1
- X4 = 1.D0 - X2
- IF(X1*X2*FAC.GT.AS) THEN
- IF(X3*X4*FAC.GT.AS) THEN
- XS1(1) = X1*FAC1
- XS1(2) = X3*FAC1
- XS2(1) = X2*FAC2
- XS2(2) = X4*FAC2
- IF(XS1(1).GT.XMIN(1,1)) THEN
- IF(XS2(1).GT.XMIN(2,1)) THEN
- IF(XS1(2).GT.XMIN(1,2)) THEN
- IF(XS2(2).GT.XMIN(2,2)) THEN
- XSUM1 = XSUM1+XS1(2)
- XSUM2 = XSUM2+XS2(2)
- GOTO 300
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ITRY0 = ITRY0+1
-
- 100 CONTINUE
-
- 1000 CONTINUE
- IREJ = 1
- IF(IDEB(32).GE.2) THEN
- WRITE(LO,'(1X,A,3I4)')
- & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
- WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
- ENDIF
- RETURN
- 300 CONTINUE
-
- END
-
-CDECK ID>, PHO_SELSXS
- SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
- & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
-C***********************************************************************
-C
-C select x values of soft string ends (rescaling method)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-
- DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
-
- IREJ = 0
-
- 10 CONTINUE
-
- IF(MSOFT.EQ.1) THEN
- XSOFT1(1) = 1.D0-XS1
- XSOFT1(2) = 0.D0
- XSOFT2(1) = 1.D0-XS2
- XSOFT2(2) = 0.D0
- RETURN
- ENDIF
-
- DO 50 I=1,MSOFT
- POT(1,I) = XPOT1(I)+1.D0
- POT(2,I) = XPOT2(I)+1.D0
- REVP(1,I) = 1.D0/POT(1,I)
- REVP(2,I) = 1.D0/POT(2,I)
- XLMIN(1,I) = XMIN(1,I)**POT(1,I)
- XLMAX = XMAX1**POT(1,I)
- XLDIF(1,I) = XLMAX-XLMIN(1,I)
- XLMIN(2,I) = XMIN(2,I)**POT(2,I)
- XLMAX = XMAX2**POT(2,I)
- XLDIF(2,I) = XLMAX-XLMIN(2,I)
- 50 CONTINUE
-
- ITRY0 = 0
- 5 CONTINUE
- ITRY0 = ITRY0 + 1
- IF(ITRY0.GE.IPAMDL(180)) THEN
- IF(MSOFT-MSMIN.GE.2) THEN
- MSOFT= MSMIN
- GOTO 10
- ENDIF
- GOTO 1000
- ENDIF
- XSUM1 = 0.D0
- XSUM2 = 0.D0
- DO 100 I=1,MSOFT
- ITRY1 = 0
- 20 CONTINUE
- Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
- Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
- XSOFT1(I) = Z1**REVP(1,I)
- XSOFT2(I) = Z2**REVP(2,I)
- ITRY1 = ITRY1+1
- IF(ITRY1.GE.50) GOTO 1000
- IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
- XSUM1 = XSUM1+XSOFT1(I)
- XSUM2 = XSUM2+XSOFT2(I)
- 100 CONTINUE
- FAC1 = (1.D0-XS1)/XSUM1
- FAC2 = (1.D0-XS2)/XSUM2
- DO 200 I=1,MSOFT
- XSOFT1(I) = XSOFT1(I)*FAC1
- XSOFT2(I) = XSOFT2(I)*FAC2
- IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
- IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
- IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
- 200 CONTINUE
-
- XS1 = 1.D0-XSOFT1(1)
- XS2 = 1.D0-XSOFT2(1)
- RETURN
-
- 1000 CONTINUE
- IREJ = 1
- IF(IDEB(14).GE.2) THEN
- WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
- & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
- DO 300 I=1,MSOFT
- WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
- 300 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_SELSXI
- SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
- & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
-C***********************************************************************
-C
-C select x values of soft string ends (sea independent from valence)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-
- DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
-
- IREJ = 0
-
- 10 CONTINUE
-
- DO 50 I=1,MSOFT
- POT(1,I) = XPOT1(I)+1.D0
- POT(2,I) = XPOT2(I)+1.D0
- REVP(1,I) = 1.D0/POT(1,I)
- REVP(2,I) = 1.D0/POT(2,I)
- XLMIN(1,I) = XMIN(1,I)**POT(1,I)
- XLMAX = XMAX1**POT(1,I)
- XLDIF(1,I) = XLMAX-XLMIN(1,I)
- XLMIN(2,I) = XMIN(2,I)**POT(2,I)
- XLMAX = XMAX2**POT(2,I)
- XLDIF(2,I) = XLMAX-XLMIN(2,I)
- 50 CONTINUE
-
-C selection of sea
- ITRY0 = 0
- 5 CONTINUE
-
- ITRY0 = ITRY0 + 1
- IF(ITRY0.GE.IPAMDL(183)) THEN
- IF(MSOFT-MSMIN.GE.2) THEN
- MSOFT = MSMIN
- GOTO 10
- ENDIF
- GOTO 1000
- ENDIF
- XSUM1 = XS1
- XSUM2 = XS2
- DO 100 I=3,MSOFT
- ITRY1 = 0
- 20 CONTINUE
- Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
- Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
- XSOFT1(I) = Z1**REVP(1,I)
- XSOFT2(I) = Z2**REVP(2,I)
- ITRY1 = ITRY1+1
- IF(ITRY1.GE.50) GOTO 1000
- IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
- XSUM1 = XSUM1+XSOFT1(I)
- XSUM2 = XSUM2+XSOFT2(I)
- 100 CONTINUE
-
- IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
- IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
-
-C selection of valence
- CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
- & XSOFT1,XSOFT2,IREJ)
- IF(IREJ.NE.0) THEN
- IF(MSOFT-MSMIN.GE.2) THEN
- MSOFT = MSMIN
- GOTO 10
- ENDIF
- IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
- & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
- & XSUM1,XSUM2,XMAX1,XMAX2
- RETURN
- ENDIF
-
- XS1 = 1.D0-XSOFT1(1)
- XS2 = 1.D0-XSOFT2(1)
- RETURN
-
- 1000 CONTINUE
- IREJ = 1
- IF(IDEB(14).GE.2) THEN
- WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
- & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
- DO 300 I=1,MSOFT
- WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
- 300 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_SELCOL
- SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
-C********************************************************************
-C
-C color combinatorics
-C
-C input: ICO1,2 colors of incoming particle
-C IMODE -2 output of initialization status
-C -1 initialization
-C ICINP(1) selection mode
-C 0 QCD
-C 1 large N_c expansion
-C ICINP(2) max. allowed color
-C 0 clear internal color counter
-C 1 hadron into two colored objects
-C 2 quark into quark gluon
-C 3 gluon into gluon gluon
-C 4 gluon into quark antiquark
-C
-C output: ICOA1,2 colors of first outgoing particle
-C ICOB1,2 colors of second outgoing particle
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
- DATA METHOD /0/, II /0/
-
- ICI1 = ICO1
- ICI2 = ICO2
- IF(METHOD.EQ.0) THEN
-
- IF(IMODE.EQ.1) THEN
- II = II+1
- IF(II.GT.MAXCOL)
- & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
- ICOA1 = II
- ICOA2 = 0
- ICOB1 = -II
- ICOB2 = 0
- ELSE IF(IMODE.EQ.2) THEN
- II = II+1
- IF(II.GT.MAXCOL)
- & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
- ICOA2 = 0
- IF(ICI1.GT.0) THEN
- ICOA1 = II
- ICOB1 = ICI1
- ICOB2 = -II
- ELSE
- ICOA1 = -II
- ICOB1 = II
- ICOB2 = ICI1
- ENDIF
- ELSE IF(IMODE.EQ.3) THEN
- II = II+1
- IF(II.GT.MAXCOL)
- & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
- IF(DT_RNDM(DUM).GT.0.5D0) THEN
- ICOA1 = ICI1
- ICOA2 = -II
- ICOB1 = II
- ICOB2 = ICI2
- ELSE
- ICOB1 = ICI1
- ICOB2 = -II
- ICOA1 = II
- ICOA2 = ICI2
- ENDIF
- ELSE IF(IMODE.EQ.4) THEN
- ICOA1 = ICI1
- ICOA2 = 0
- ICOB1 = ICI2
- ICOB2 = 0
- ELSE IF(IMODE.EQ.0) THEN
- II = 0
- ELSE IF(IMODE.EQ.-1) THEN
- METHOD = ICI1
- MAXCOL = ICI2
- ELSE IF(IMODE.EQ.-2) THEN
- WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
- & METHOD,MAXCOL
- ELSE
- WRITE(LO,'(1X,A,I5)')
- & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
- CALL PHO_ABORT
- ENDIF
-
- ELSE
- WRITE(LO,'(1X,A,I5)')
- & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
- CALL PHO_ABORT
- ENDIF
-
- II = ABS(II)
- IF(IDEB(75).GE.10) THEN
- WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
- & IMODE,MAXCOL,II
- WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
- WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
- ENDIF
-
- END
-
-CDECK ID>, ipho_diqu
- INTEGER FUNCTION ipho_diqu(iq1,iq2)
-C***********************************************************************
-C
-C selection of diquark number (PDG convention)
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer iq1,iq2
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C external functions
- double precision DT_RNDM
-
-C local variables
- integer i0,i1,i2
- double precision dum
-
- i1 = abs(iq1)
- i2 = abs(iq2)
-
- if(i1.eq.i2) then
- i0 = i1*1100+3
- else
- i0 = max(i1,i2)*1000+min(i1,i2)*100
- if(DT_RNDM(dum).gt.PARMDL(135)) then
- i0 = i0+1
- else
- i0 = i0+3
- endif
- endif
-
- ipho_diqu = sign(i0,iq1)
-
- END
-
-CDECK ID>, PHO_PARREM
- SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
-C**********************************************************************
-C
-C selection of particle remnant flavour(s) (quark or diquark)
-C
-C input: INDX index of particle in /POEVT1/
-C IOUT parton which was taken out
-C
-C output: IREM remnant according to valence flavours
-C IREJ 0 flavour combination possible
-C 1 flavour combination impossible
-C
-C all particle ID are given according to PDG conventions
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer INDX,IOUT,IREM,IREJ
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C external functions
- integer ipho_diqu
-
-C local variables
- integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
- dimension IQUA(3),IDQ(2)
-
- ID1 = IDHEP(INDX)
- ID2 = IMPART(INDX)
- IREJ = 0
-
- IF(ID2.EQ.0) THEN
- WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
- CALL PHO_ABORT
- ENDIF
-
-C particle with flavour mixing
- if(ID1.eq.22) then
-C photon
- IREM = -IOUT
- GOTO 100
- else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
-C pi0, rho0, and omega
- IF(ABS(IOUT).LE.2) THEN
- IREM = -IOUT
- GOTO 100
- ELSE
- GOTO 150
- ENDIF
- else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
-C neutral kaons (K0,K0-bar)
- if(abs(IOUT).eq.1) then
- IREM = sign(3,-IOUT)
- goto 100
- else if(abs(IOUT).eq.3) then
- IREM = sign(1,-IOUT)
- goto 100
- else
- goto 150
- endif
- else if((ID1.eq.990).or.(ID1.eq.110)) then
-C pomeron and reggeon
- IREM = -IOUT
- GOTO 100
- endif
-
-C ordinary hadron
- ID = abs(ID2)
- IS = sign(1,ID2)
- IQUA(1) = iq_list(1,ID)*IS
- IQUA(2) = iq_list(2,ID)*IS
- IQUA(3) = iq_list(3,ID)*IS
-
-C compare to flavour content
- IF(ABS(IOUT).LT.1000) THEN
-C single quark requested
- IF(IQUA(1).EQ.IOUT) THEN
- K1 = 2
- K2 = 3
- ELSE IF(IQUA(2).EQ.IOUT) THEN
- K1 = 1
- K2 = 3
- ELSE IF(IQUA(3).EQ.IOUT) THEN
- K1 = 1
- K2 = 2
- ELSE
- GOTO 150
- ENDIF
- IF(IQUA(3).EQ.0) THEN
- IREM = IQUA(K1)
- ELSE
- IREM = ipho_diqu(IQUA(K1),IQUA(K2))
- ENDIF
- ELSE IF(IQUA(3).NE.0) THEN
-C diquark requested from baryon
- IDQ(1) = IOUT/1000
- IDQ(2) = (IOUT-IDQ(1)*1000)/100
- do i=1,2
- do k=1,3
- if(IDQ(i).eq.IQUA(k)) then
- IQUA(k) = 0
- goto 110
- endif
- enddo
- goto 150
- 110 continue
- enddo
- IREM = IQUA(1)+IQUA(2)+IQUA(3)
- ENDIF
-
- 100 CONTINUE
-C debug output
- IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
- & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
- & INDX,ID1,ID2,IOUT,IREM
- RETURN
-
-C rejection
- 150 CONTINUE
- IREJ = 1
- IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
- & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
-
- END
-
-CDECK ID>, PHO_VALFLA
- SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
-C***********************************************************************
-C
-C selection of valence flavour decomposition of particle IPAR
-C
-C input: IPAR particle index in /POEVT1/
-C -1 initialization
-C -2 output of statistics
-C XMASS mass of particle
-C (important for pomeron:
-C mass dependent flavour sampling)
-C
-C output: IFL1,IFL2
-C baryon: IFL1 diquark flavour
-C (valence flavours according to PDG conventions)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 0.1D0,
- & DEPS = 1.D-15)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
- data ITMX / 5 /
-
- IF(IPAR.GT.0) THEN
- K = IPAR
-C select particle code
- ID1 = IDHEP(K)
- ID = abs(IMPART(K))
- IBAR = IPHO_BAR3(K,2)
- ITER = 0
-
- 10 CONTINUE
-
- ifl1 = 0
- ifl2 = 0
- ITER = ITER+1
- if(ITER.GT.ITMX) then
- WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
- & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
- return
- endif
-
-C not baryon
- IF(IBAR.EQ.0) THEN
-
-C photon
- IF(ID1.EQ.22) THEN
-C charge dependent flavour sampling
- 15 CONTINUE
- K = INT(DT_RNDM(E1)*6.D0)+1
- IF(K.LE.4) THEN
- IFL1 = 2
- IFL2 = -2
- ELSE IF(K.EQ.5) THEN
- IFL1 = 1
- IFL2 = -1
- ELSE
- IFL1 = 3
- IFL2 = -3
- ENDIF
-C optional strangeness suppression
- IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
- IF(DT_RNDM(DUM).LT.0.5D0) THEN
- K = IFL1
- IFL1 = IFL2
- IFL2 = K
- ENDIF
-
-C pomeron, reggeon
- ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
- IF(ISWMDL(19).EQ.0) THEN
-C SU(3) symmetric valences
- K = INT(DT_RNDM(E1)*3.D0)+1
- IF(DT_RNDM(DUM).LT.0.5D0) THEN
- IFL1 = K
- ELSE
- IFL1 = -K
- ENDIF
- IFL2 = -IFL1
- ELSE IF(ISWMDL(19).EQ.1) THEN
-C mass dependent flavour sampling
- EMIN = MIN(E1,E2)
- CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
- ELSE
- WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
- & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
- CALL PHO_ABORT
- ENDIF
-
-C meson with flavour mixing
- ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
- K = INT(2.D0*DT_RNDM(E1))+1
- IFL1 = K
- IFL2 = -K
-C meson (standard)
- ELSE
- K = INT(2.D0*DT_RNDM(E1))+1
- IFL1 = iq_list(K,ID)
- K = MOD(K,2) + 1
- IFL2 = iq_list(K,ID)
- if(IFL1.EQ.0) then
- EMIN = MIN(E1,E2)
- CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
- endif
- ENDIF
-
-C baryon
- ELSE
- K = INT(2.999999D0*DT_RNDM(E2))+1
- K1 = MOD(K,3)+1
- K2 = MOD(K1,3)+1
- IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
- IFL2 = iq_list(K,ID)
- ENDIF
-
-C change sign for antiparticles
- if(ID1.lt.0) then
- IFL1 = -IFL1
- IFL2 = -IFL2
- endif
-
-************************************************************************
-C check kinematic constraints
-* IF((PHO_PMASS(IFL1,3).GT.E1)
-* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
-************************************************************************
-
-C debug output
- IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
- & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
-
- ELSE IF(IPAR.EQ.-1) THEN
-C initialization
-
- ELSE IF(IPAR.EQ.-2) THEN
-C output of final statistics
-
- ELSE
- WRITE(LO,'(1X,A,I10)')
- & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_REGFLA
- SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
-C**********************************************************************
-C
-C selection of reggeon flavours
-C
-C input: JM1,JM2 position index of mother hadrons
-C
-C output: IFLR1,IFLR2 valence flavours according to
-C PDG conventions and JM1,JM2
-C IREJ 0 reggeon possible
-C 1 reggeon impossible
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 0.1D0,
- & DEPS = 1.D-15)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- IF(JM1.GT.0) THEN
- IREJ = 0
- ITER = 0
-C available energy
- E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
- & -(PHEP(1,JM1)+PHEP(1,JM2))**2
- & -(PHEP(2,JM1)+PHEP(2,JM2))**2
- & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
- 50 CONTINUE
- ITER = ITER+1
- IF(ITER.GT.50) THEN
- IREJ = 1
-C debug output
- IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
- & 'PHO_REGFLA: rejection, no reggeon found for',
- & IDHEP(JM1),IDHEP(JM2),E1
- RETURN
- ENDIF
-
- CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
- CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
- IF(IFLA1.EQ.-IFLB1) THEN
- IFLR1 = IFLA2
- IFLR2 = IFLB2
- ELSE IF(IFLA1.EQ.-IFLB2) THEN
- IFLR1 = IFLA2
- IFLR2 = IFLB1
- ELSE IF(IFLA2.EQ.-IFLB1) THEN
- IFLR1 = IFLA1
- IFLR2 = IFLB2
- ELSE IF(IFLA2.EQ.-IFLB2) THEN
- IFLR1 = IFLA1
- IFLR2 = IFLB1
- ELSE
-C debug output
- IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
- & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
- GOTO 50
- ENDIF
-C debug output
- IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
- & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
- & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
- ELSE IF(JM1.EQ.-1) THEN
-C initialization
- ELSE IF(JM1.EQ.-2) THEN
-C output of statistics
- ELSE
- WRITE(LO,'(1X,A,I10)')
- & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_SEAFLA
- SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
-C**********************************************************************
-C
-C selection of sea flavour content of particle IPAR
-C
-C input: IPAR particle index in /POEVT1/
-C CHMASS available invariant string mass
-C positive mass --> use BAMJET method
-C negative mass --> SU(3) symmetric sea according
-C to values given in PARMDL(1-6)
-C IPAR -1 initialization
-C -2 output of statistics
-C
-C output: sea flavours according to PDG conventions
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 0.1D0,
- & DEPS = 1.D-15)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-
- IF(IPAR.GT.0) THEN
- IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
-C constant weights for sea
- 15 CONTINUE
- SUM = 0.D0
- DO 40 K=1,NFSEA
- SUM = SUM + PARMDL(K)
- 40 CONTINUE
- XI = DT_RNDM(SUM)*SUM
- SUM = 0.D0
- DO 50 K=1,NFSEA
- SUM = SUM + PARMDL(K)
- IF(XI.LE.SUM) GOTO 55
- 50 CONTINUE
- 55 CONTINUE
- IF(K.GT.NFSEA) GOTO 15
- ELSE
-C mass dependent flavour sampling
- 10 CONTINUE
- CALL PHO_FLAUX(CHMASS,K)
- IF(K.GT.NFSEA) GOTO 10
- ENDIF
- IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
- IFL1 = K
- IFL2 = -K
- IF(IDEB(46).GE.10) THEN
- WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
- & IPAR,IFL1,IFL2,CHMASS
- ENDIF
- ELSE IF(IPAR.EQ.-1) THEN
-C initialization
- NFSEA = NFS
- ELSE IF(IPAR.EQ.-2) THEN
-C output of statistics
- ELSE
- WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_FLAUX
- SUBROUTINE PHO_FLAUX(EQUARK,K)
-C***********************************************************************
-C
-C auxiliary subroutine to select flavours
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-14 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-
- DIMENSION WGHT(9)
-
-C calculate weights for given energy
- IF(EQUARK.LT.QMASS(1)) THEN
- IF(IDEB(16).GE.5)
- & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
- & EQUARK
- WGHT(1) = 0.5D0
- WGHT(2) = 0.5D0
- WGHT(3) = 0.D0
- WGHT(4) = 0.D0
- SUM = 1.D0
- ELSE
- SUM = 0.D0
- DO 305 K=1,NFS
- IF(EQUARK.GT.QMASS(K)) THEN
- WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
- ELSE
- WGHT(K) = 0.D0
- ENDIF
- SUM = SUM + WGHT(K)
- 305 CONTINUE
- ENDIF
-C sample flavours
- XI = SUM*(DT_RNDM(SUM)-DEPS)
- K = 0
- SUM = 0.D0
- 400 CONTINUE
- K = K+1
- SUM = SUM + WGHT(K)
- IF(XI.GT.SUM) GOTO 400
-C debug output
- IF(IDEB(16).GE.20) THEN
- WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
- ENDIF
- END
-
-CDECK ID>, PHO_BETAF
- DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
-C********************************************************************
-C
-C weights of different quark flavours
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- AX=0.D0
- BETX1=BET*X1
- IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
- AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
-
- PHO_BETAF=AX+AY
-
- END
-
-CDECK ID>, PHO_MCHECK
- SUBROUTINE PHO_MCHECK(J1,IREJ)
-C********************************************************************
-C
-C check parton momenta for fragmentation
-C
-C input: J1 first string number
-C /POEVT1/
-C /POSTRG/
-C
-C output: /POEVT1/
-C /POSTRG/
-C IREJ 0 successful
-C 1 failure
-C
-C in case of very small string mass:
-C NNCH mass label of string
-C 0 string
-C -1 octett baryon / pseudo scalar meson
-C 1 decuplett baryon / vector meson
-C IBHAD hadron number according to CPC,
-C string will be treated as resonance
-C (sometimes far off mass shell)
-C
-C constant WIDTH ( 0.01GeV ) determines range of acceptance
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( WIDTH = 0.01D0,
- & DEPS = 1.D-15 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- IREJ = 0
-C quark antiquark jet
- STRM = PHEP(5,NPOS(1,J1))
- IF(NCODE(J1).EQ.3) THEN
- CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
- & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
- IF(IDEB(18).GE.5)
- & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
- & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
- & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
- IF(STRM.LT.AMPS) THEN
- IREJ = 1
- IFAIL(20) = IFAIL(20) + 1
- RETURN
- ELSE IF(STRM.LT.AMPS2) THEN
- IF(STRM.LT.(AMVE-WIDTH)) THEN
- NNCH(J1) = -1
- IBHAD(J1) = IPS
- ELSE
- NNCH(J1) = 1
- IBHAD(J1) = IVE
- ENDIF
- ELSE
- NNCH(J1) = 0
- IBHAD(J1) = 0
- ENDIF
-C quark diquark or v.s. jet
- ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
- CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
- & AM8,AM82,AM10,AM102,I8,I10)
- IF(IDEB(18).GE.5)
- & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
- & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
- & J1,STRM,AM8,AM82,AM10,AM102
- IF(STRM.LT.AM8) THEN
- IREJ = 1
- IFAIL(19) = IFAIL(19) + 1
- RETURN
- ELSE IF(STRM.LT.AM82) THEN
- IF(STRM.LT.(AM10-WIDTH)) THEN
- NNCH(J1) = -1
- IBHAD(J1) = I8
- ELSE
- NNCH(J1) = 1
- IBHAD(J1) = I10
- ENDIF
- ELSE
- NNCH(J1) = 0
- IBHAD(J1) = 0
- ENDIF
-C diquark a-diquark string
- ELSE IF(NCODE(J1).EQ.5) THEN
- CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
- & AM82,AM102)
- IF(IDEB(18).GE.5)
- & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
- & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
- & J1,STRM,AM82,AM102
- IF(STRM.LT.AM82) THEN
- IREJ = 1
- IFAIL(19) = IFAIL(19) + 1
- RETURN
- ELSE
- NNCH(J1) = 0
- IBHAD(J1) = 0
- ENDIF
- ELSE IF(NCODE(J1).LT.0) THEN
- RETURN
- ELSE
- WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
- & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
- CALL PHO_ABORT
- ENDIF
- END
-
-CDECK ID>, PHO_POMCOR
- SUBROUTINE PHO_POMCOR(IREJ)
-C********************************************************************
-C
-C join quarks to gluons in case of too small masses
-C
-C input: /POEVT1/
-C /POSTRG/
-C IREJ -1 initialization
-C -2 output of statistics
-C
-C output: /POEVT1/
-C /POSTRG/
-C IREJ 0 successful
-C 1 failure
-C
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
- DIMENSION PJ(4)
-
- IF(IREJ.EQ.-1) THEN
- ICTOT = 0
- ICCOR = 0
- RETURN
- ELSE IF(IREJ.EQ.-2) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A,2I8)')
-C & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
- RETURN
- ENDIF
-C
- IREJ = 0
-C
- NITER = 100
- ITER = 0
- ICTOT = ICTOT+ISTR
- IF(ISWMDL(25).LE.0) RETURN
-C debug string entries
- IF(IDEB(83).GE.25) CALL PHO_PRSTRG
-C
- 50 CONTINUE
- ITER = ITER+1
- IF(ITER.GE.NITER) THEN
- IREJ = 1
- IF(IDEB(83).GE.2) THEN
- WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
- IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
- ENDIF
- RETURN
- ENDIF
-C
-C check mass limits
- ISTRO = ISTR
- DO 100 I=1,ISTRO
- IF(NCODE(I).LT.0) GOTO 99
- J1 = NPOS(1,I)
- NRPOM = IPHIST(2,J1)
- IF(NRPOM.GE.100) GOTO 99
- CMASS0 = PHEP(5,J1)
-C get masses
- IF(NCODE(I).EQ.3) THEN
- CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
- ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
- CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
- & AM1,AM2,AM3,AM4,IP1,IP2)
- ELSE IF(NCODE(I).EQ.5) THEN
- CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
- & AM1,AM2)
- AM3 = 0.D0
- AM4 = 0.D0
- IP1 = 0
- IP2 = 0
- ELSE IF(NCODE(I).EQ.7) THEN
- GOTO 99
- ELSE IF(NCODE(I).LT.0) THEN
- GOTO 99
- ELSE
- WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
- & J1,NCODE(I)
- CALL PHO_ABORT
- ENDIF
- IF(IDEB(83).GE.5)
- & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
- & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
- & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
-C select masses to correct
- IF(CMASS0.LT.MAX(AM2,AM4)) THEN
- DO 200 K=1,ISTRO
- IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
- J2 = NPOS(1,K)
-C join quarks to gluon
- IF(NRPOM.EQ.IPHIST(2,J2)) THEN
-C flavour check
- IFL1 = 0
- IFL2 = 0
- PROB1 = 0.D0
- PROB2 = 0.D0
- KK1 = NPOS(2,I)
- KK2 = NPOS(2,K)
- IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
- CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
- & -(PHEP(1,KK1)+PHEP(1,KK2))**2
- & -(PHEP(2,KK1)+PHEP(2,KK2))**2
- & -(PHEP(2,KK1)+PHEP(2,KK2))**2
- IFL1 = ABS(IDHEP(KK1))
- IF(IFL1.GT.2) THEN
- PROB1 = 0.1D0/MAX(CMASS,EPS)
- ELSE
- PROB1 = 0.9D0/MAX(CMASS,EPS)
- ENDIF
- ENDIF
- KK1 = ABS(NPOS(3,I))
- KK2 = ABS(NPOS(3,K))
- IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
- CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
- & -(PHEP(1,KK1)+PHEP(1,KK2))**2
- & -(PHEP(2,KK1)+PHEP(2,KK2))**2
- & -(PHEP(2,KK1)+PHEP(2,KK2))**2
- IFL2 = ABS(IDHEP(KK1))
- IF(IFL2.GT.2) THEN
- PROB2 = 0.1D0/MAX(CMASS,EPS)
- ELSE
- PROB2 = 0.9D0/MAX(CMASS,EPS)
- ENDIF
- ENDIF
- IF(IFL1+IFL2.EQ.0) GOTO 99
-C fusion possible
- ICCOR = ICCOR+1
- IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
- JJ = 2
- JE = 3
- ELSE
- JJ = 3
- JE = 2
- ENDIF
- KK1 = ABS(NPOS(JJ,I))
- KK2 = ABS(NPOS(JJ,K))
- I1 = ABS(NPOS(JE,I))
- I2 = KK1
- IS = SIGN(1,I2-I1)
- I2 = I2 - IS
- K1 = KK2
- K2 = ABS(NPOS(JE,K))
- KS = SIGN(1,K2-K1)
- K1 = K1 + KS
- IP1 = NHEP+1
-C copy mother partons of string I
- DO 300 II=I1,I2,IS
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
- & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
- & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
- 300 CONTINUE
-C register gluon
- DO 350 II=1,4
- PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
- 350 CONTINUE
- CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
- & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
-C copy mother partons of string K
- DO 400 II=K1,K2,KS
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
- & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
- & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
- 400 CONTINUE
-C create new string entry
- DO 450 II=1,4
- PJ(II) = PHEP(II,J1)+PHEP(II,J2)
- 450 CONTINUE
- IP2 = IPOS
- CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
- & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
- & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
-C delete string K in /POSTRG/
- NCODE(K) = -999
-C update string I in /POSTRG/
- NPOS(1,I) = IPOS
- NPOS(2,I) = IP1
- NPOS(3,I) = -IP2
-C calculate new CPC string codes
- CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
- & IPAR2(I),IPAR3(I),IPAR4(I))
- GOTO 99
- ENDIF
- ENDIF
- 200 CONTINUE
- ENDIF
- 99 CONTINUE
- 100 CONTINUE
- IF(IDEB(83).GE.20) THEN
- WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
- IF(IDEB(83).GE.22) THEN
- CALL PHO_PRSTRG
- CALL PHO_PREVNT(0)
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_MASCOR
- SUBROUTINE PHO_MASCOR(IREJ)
-C********************************************************************
-C
-C check and adjust parton momenta for fragmentation
-C
-C input: /POEVT1/
-C /POSTRG/
-C IREJ -1 initialization
-C -2 output of statistics
-C
-C output: /POEVT1/
-C /POSTRG/
-C IREJ 0 successful
-C 1 failure
-C
-C in case of very small string mass:
-C - direct manipulation of /POEVT1/ and /POEVT2/
-C - string will be deleted from /POSTRG/ (label -99)
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-10,
- & EMIN = 0.3D0,
- & DEPS = 1.D-15)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
- DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
-
- IF(IREJ.EQ.-1) THEN
- ICTOT = 0
- ICCOR = 0
- RETURN
- ELSE IF(IREJ.EQ.-2) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A,2I8/)')
-C & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
- RETURN
- ENDIF
-
- IREJ = 0
- NITER = 100
- ITER = 0
- ICTOT = ICTOT+ISTR
- IF(ISWMDL(7).EQ.-1) RETURN
-C debug /POSTRG/
- IF(IDEB(42).GE.25) CALL PHO_PRSTRG
-
- ITOUCH = 0
- 50 CONTINUE
- ITER = ITER+1
- IF(ITER.GE.NITER) THEN
- IREJ = 1
- IF(IDEB(42).GE.2) THEN
- WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
- IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
- ENDIF
- RETURN
- ENDIF
-
-C check mass limits
- IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
- IM1 = 1
- IM2 = ISTR
- IST = 1
- ELSE
- IM1 = ISTR
- IM2 = 1
- IST = -1
- ENDIF
- DO 100 I=IM1,IM2,IST
- J1 = NPOS(1,I)
- CMASS0 = PHEP(5,J1)
-C get masses
- IF(NCODE(I).EQ.3) THEN
- CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
- ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
- CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
- & AM1,AM2,AM3,AM4,IP1,IP2)
- ELSE IF(NCODE(I).EQ.5) THEN
- CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
- & AM1,AM2)
- AM3 = 0.D0
- AM4 = 0.D0
- IP1 = 0
- IP2 = 0
- ELSE IF(NCODE(I).EQ.7) THEN
- AM1 = 0.15D0
- AM2 = 0.3D0
- AM3 = 0.765D0
- AM4 = 1.5D0
-*??????????????????????????????????
- IP1 = 23
- IP2 = 33
-*??????????????????????????????????
- ELSE IF(NCODE(I).LT.0) THEN
- GOTO 90
- ELSE
- WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
- & J1,NCODE(I)
- CALL PHO_ABORT
- ENDIF
- IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
- & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
- & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
-C select masses to correct
- IBHAD(I) = 0
- NNCH(I) = 0
-C correction needed?
-C no resonances for diquark-antidiquark and gluon-gluon strings
- IF(NCODE(I).EQ.5) THEN
- IF(CMASS0.LT.1.3D0*AM1) THEN
- IF(ISWMDL(7).LE.2) THEN
- IBHAD(I) = 90
- NNCH(I) = -1
- CHMASS = AM1*1.3D0
- ELSE
- IREJ = 1
- RETURN
- ENDIF
- ENDIF
- ELSE
- INEED = 0
-C resonances possible
- IF(ISWMDL(7).EQ.0) THEN
- IF(CMASS0.LT.AM1*0.99D0) THEN
- IBHAD(I) = IP1
- NNCH(I) = -1
- CHMASS = AM1
- INEED = 1
- ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
- DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
- DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
- IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
- IBHAD(I) = IP1
- NNCH(I) = -1
- CHMASS = AM1
- ELSE
- IBHAD(I) = IP2
- NNCH(I) = 1
- CHMASS = AM3
- ENDIF
- ENDIF
- ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
- IF(CMASS0.LT.AM1*0.99) THEN
- IBHAD(I) = IP1
- NNCH(I) = -1
- CHMASS = AM1
- INEED = 1
- ENDIF
- ELSE IF(ISWMDL(7).EQ.3) THEN
- IF(CMASS0.LT.AM1) THEN
- IREJ = 1
- RETURN
- ENDIF
- ELSE
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
- CALL PHO_ABORT
- ENDIF
- ENDIF
-C
-C correction necessary?
- IF(IBHAD(I).NE.0) THEN
-C find largest invar. mass
- IPOS = 0
- CMASS1 = -1.D0
- DO 200 J2=NHEP,3,-1
-
- IF(ABS(ISTHEP(J2)).EQ.1) THEN
- IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
- WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
- & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
- CALL PHO_PREVNT(0)
- ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
- CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
- & -(PHEP(1,J1)+PHEP(1,J2))**2
- & -(PHEP(2,J1)+PHEP(2,J2))**2
- & -(PHEP(3,J1)+PHEP(3,J2))**2
- IF(CMASS2.GT.CMASS1) THEN
- IPOS=J2
- CMASS1=CMASS2
- ENDIF
- ENDIF
- ENDIF
-
- 200 CONTINUE
- J2 = IPOS
- IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
- IF(INEED.EQ.1) THEN
- IREJ = 1
- RETURN
- ELSE
- IBHAD(I) = 0
- NNCH(I) = 0
- GOTO 90
- ENDIF
- ENDIF
- ISTA = ISTHEP(J1)
- ISTB = ISTHEP(J2)
- CMASS1 = SQRT(CMASS1)
- CMASS2 = PHEP(5,J2)
- IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
- IREJ = 1
- IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
- & CHMASS,CMASS2,PC1,PC2,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(24) = IFAIL(24)+1
- IF(IDEB(42).GE.2) THEN
- WRITE(LO,'(1X,A,2I4)')
- & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
- IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
-C momentum transfer
- DO 210 II=1,4
- PTR(II) = PHEP(II,J2)-PC2(II)
- 210 CONTINUE
- IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
- & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
-C copy parents of strings
-C register partons belonging to first string
- IF(IDHEP(J1).EQ.90) THEN
- K1 = JMOHEP(1,J1)
- K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
- ESUM = 0.D0
- DO 500 II=K1,K2
- ESUM = ESUM+PHEP(4,II)
- 500 CONTINUE
- IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
- DO 600 II=K1,K2
- FAC = PHEP(4,II)/ESUM
- DO 650 K=1,4
- P1(K) = PHEP(K,II)+FAC*PTR(K)
- 650 CONTINUE
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
- & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
- & ICOLOR(2,II),IPOS,1)
- 600 CONTINUE
- K1A = IPOS+K1-K2
- IF(JMOHEP(2,J1).GT.0) THEN
- II = JMOHEP(2,J1)
- FAC = PHEP(4,II)/ESUM
- DO 675 K=1,4
- P1(K) = PHEP(K,II)+FAC*PTR(K)
- 675 CONTINUE
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
- & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
- & ICOLOR(2,II),IPOS,1)
- ENDIF
- K2A = -IPOS
- ELSE
- K1A = J1
- K2A = J2
- ENDIF
-C register partons belonging to second string
- IF(IDHEP(J2).EQ.90) THEN
- CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
- K1 = JMOHEP(1,J2)
- K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
- ESUM = 0.D0
- DO 300 II=K1,K2
- ESUM = ESUM+PHEP(4,II)
- 300 CONTINUE
- IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
- DO 400 II=K1,K2
- FAC = PHEP(4,II)/ESUM
- IF(IREJL.EQ.0) THEN
- CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
- P1(4) = P1(4)+FAC*DELE
- ELSE
- DO 450 K=1,4
- P1(K) = PHEP(K,II)-FAC*PTR(K)
- 450 CONTINUE
- ENDIF
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
- & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
- & ICOLOR(2,II),IPOS,1)
- 400 CONTINUE
- K1B = IPOS+K1-K2
- IF(JMOHEP(2,J2).GT.0) THEN
- II = JMOHEP(2,J2)
- FAC = PHEP(4,II)/ESUM
- IF(IREJL.EQ.0) THEN
- CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
- P1(4) = P1(4)+FAC*DELE
- ELSE
- DO 475 K=1,4
- P1(K) = PHEP(K,II)-FAC*PTR(K)
- 475 CONTINUE
- ENDIF
- CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
- & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
- & ICOLOR(2,II),IPOS,1)
- ENDIF
- K2B = -IPOS
- ELSE
- K1B = J1
- K2B = J2
- ENDIF
-C register first string/collapsed to hadron
- IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
- IF(NCODE(I).NE.5) THEN
- CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
- & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
-C label string as collapsed to hadron/resonance
- NCODE(I) = -99
- IDHEP(J1) = 92
- ELSE
- CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
- & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
- IDHEP(J1) = 91
- ENDIF
- NPOS(1,I) = IPOS
- NPOS(2,I) = K1A
- NPOS(3,I) = K2A
- ELSE
- CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
- & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
- & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
- IF(IDHEP(J1).EQ.90) THEN
- NPOS(1,IPHIST(1,J1)) = IPOS
- NPOS(2,IPHIST(1,J1)) = K1A
- NPOS(3,IPHIST(1,J1)) = K2A
-C label string as collapsed to resonance-string
- IDHEP(J1) = 91
- ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
- IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
- ENDIF
- ENDIF
-C register second string/hadron/parton
- CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
- & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
- & ICOLOR(2,J2),IPOS,1)
- IF(IDHEP(J2).EQ.90) THEN
- NPOS(1,IPHIST(1,J2))=IPOS
- NPOS(2,IPHIST(1,J2))=K1B
- NPOS(3,IPHIST(1,J2))=K2B
-C label string touched by momentum transfer
- IDHEP(J2) = 91
- ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
- IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
- ENDIF
- ICCOR = ICCOR+1
- ITOUCH = ITOUCH+1
-C consistency checks
- IF(IDEB(42).GE.5) THEN
- CALL PHO_CHECK(-1,IDEV)
- IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
- ENDIF
-C jump to next iteration
- GOTO 50
- ENDIF
- 90 CONTINUE
- 100 CONTINUE
-C debug output
- IF(IDEB(42).GE.15) THEN
- IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
- WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
- CALL PHO_PREVNT(1)
- ENDIF
- ENDIF
- END
-
-CDECK ID>, PHO_PARCOR
- SUBROUTINE PHO_PARCOR(MODE,IREJ)
-C********************************************************************
-C
-C conversion of string partons (using JETSET masses)
-C
-C input: MODE >0 position index of corresponding string
-C -1 initialization
-C -2 output of statistics
-C
-C output: /POSTRG/
-C IREJ 1 combination of strings impossible
-C 0 successful combination
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DELM = 0.005D0,
- & DEPS = 1.D-15,
- & EPS = 1.D-5)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
- DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
- & PL(4,100),XMP(100),XML(100)
-
- DOUBLE PRECISION PYMASS
-
- IREJ = 0
- IMODE = MODE
-C
- IF(IMODE.GT.0) THEN
- ICH = 0
- I1 = JMOHEP(1,IMODE)
- I2 = ABS(JMOHEP(2,IMODE))
-C copy to local field
- L = 0
- DO 100 I=I1,I2
- L = L+1
- DO 200 K=1,4
- PL(K,L) = PHEP(K,I)
- 200 CONTINUE
- XMP(L) = PHEP(5,I)
-
- XML(L) = PYMASS(IDHEP(I))
-
- 100 CONTINUE
- IPAR = L
- XMC = PHEP(5,IMODE)
- IF(IDEB(82).GE.20) THEN
- WRITE(LO,'(1X,A,I7,2I4)')
- & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
- & KEVENT,IMODE,L
- DO 150 I=1,L
- WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
- & XMP(I),XML(I)
- 150 CONTINUE
- ENDIF
-C
-C two parton configurations
-C -----------------------------------------
- IF(IPAR.EQ.2) THEN
- XM1 = XML(1)
- XM2 = XML(2)
- IF((XM1+XM2).GE.XMC) THEN
- IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
- & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
- & IMODE,XM1,XM2,XMC
- GOTO 990
- ENDIF
-C conversion possible
- CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(36) = IFAIL(36)+1
- IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
- & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
- & KEVENT,IMODE,XMC
- GOTO 990
- ENDIF
- ICH = 1
- DO 115 K=1,4
- PL(K,1) = PP1(K)
- PL(K,2) = PP2(K)
- XMP(1) = XM1
- XMP(2) = XM2
- 115 CONTINUE
-C
-C multi parton configurations
-C ---------------------------------
- ELSE
-C
-C random selection of string side to start with
- IF(DT_RNDM(XMC).LT.0.5D0) THEN
- K1 = 1
- K2 = IPAR
- KS = 1
- ELSE
- K1 = IPAR
- K2 = 1
- KS = -1
- ENDIF
- ITER = 0
-C
- 300 CONTINUE
- IF(ITER.LT.4) THEN
- KK = K1
- K1 = K2
- K2 = KK
- KS = -KS
- ELSE
- GOTO 990
- ENDIF
- ITER = ITER+1
-C select method
- IF(ITER.GT.2) GOTO 230
-
-C conversion according to color flow method
- IFAI = 0
- DO 210 II=K1,K2-KS,KS
- DO 215 IK=II+KS,K2,KS
- XM1 = XML(II)
- XM2 = XML(IK)
-* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
-* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
- IF((ABS(XM1-XMP(II)).GT.DELM)
- & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
- CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(36) = IFAIL(36)+1
- IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
- & 'PHO_PARCOR: ',
- & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
- & KEVENT,IMODE,II,IK
- IREJ = 0
- ELSE
- ICH = ICH+1
- DO 220 KK=1,4
- PL(KK,II) = PP1(KK)
- PL(KK,IK) = PP2(KK)
- 220 CONTINUE
- XMP(II) = XM1
- XMP(IK) = XM2
- GOTO 219
- ENDIF
- ELSE
- GOTO 219
- ENDIF
- 215 CONTINUE
- IFAI = II
- 219 CONTINUE
- 210 CONTINUE
- IF(IFAI.NE.0) GOTO 300
- GOTO 950
-C
- 230 CONTINUE
-C
-C conversion according to remainder method
- DO 350 I=K1,K2,KS
- XM1 = XML(I)
- IF(ABS(XM1-XMP(I)).GT.DELM) THEN
- ICH = ICH+1
- IFAI = I
-C conversion necessary
- DO 400 K=1,4
- PB1(K) = PL(K,I)
- PB2(K) = PHEP(K,IMODE)-PB1(K)
- 400 CONTINUE
- XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
- IF(XM2.LT.0.D0) THEN
- IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
- & 'PHO_PARCOR: ',
- & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
- & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
- GOTO 300
- ENDIF
- XM2 = SQRT(XM2)
- IF((XM1+XM2).GE.XMC) THEN
- IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
- & 'PHO_PARCOR: ',
- & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
- & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
- GOTO 300
- ENDIF
-C conversion possible
- CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(36) = IFAIL(36)+1
- IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
- & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
- & ITER,IMODE,I
- GOTO 300
- ENDIF
-C calculate Lorentz transformation
- CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
- & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
- & ITER,IMODE,I
- GOTO 300
- ENDIF
- IFAI = 0
-C transform remaining partons
- DO 450 L=K1,K2,KS
- IF(L.NE.I) THEN
- CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
- DO 500 K=1,4
- PL(K,L) = PP2(K)
- 500 CONTINUE
- ELSE
- DO 550 K=1,4
- PL(K,L) = PP1(K)
- 550 CONTINUE
- ENDIF
- 450 CONTINUE
- XMP(I) = XM1
- ENDIF
- 350 CONTINUE
- ENDIF
-
-C register transformed partons
- 950 CONTINUE
- IREJ = 0
- IF(ICH.NE.0) THEN
- IP1 = NHEP+1
- L = 0
- DO 700 I=I1,I2
- L= L+1
- CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
- & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
- & ICOLOR(2,I),IPOS,1)
- 700 CONTINUE
- IP2 = IPOS
-C register string
- CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
- & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
- & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
-C update /POSTRG/
- I = IPHIST(1,IMODE)
- NPOS(1,I) = IPOS
- NPOS(2,I) = IP1
- NPOS(3,I) = -IP2
- ENDIF
-C debug output
- IF(IDEB(82).GE.20) THEN
- WRITE(LO,'(1X,A,I7,2I4)')
- & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
- & KEVENT,IMODE,L
- DO 850 I=1,L
- WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
- & XMP(I),XML(I)
- 850 CONTINUE
- WRITE(LO,'(1X,A,2I5)')
- & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
- ENDIF
- RETURN
-C rejection
- 990 CONTINUE
- IREJ = 1
- IF(IDEB(82).GE.3) THEN
- WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
- & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
- & IFAI,IPAR,IMODE,XMC
- IF(IDEB(82).GE.5) THEN
- WRITE(LO,'(1X,A,I7,2I4)')
- & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
- & KEVENT,IMODE,IPAR
- DO 155 I=1,IPAR
- WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
- & XMP(I),XML(I)
- 155 CONTINUE
- ENDIF
- ENDIF
- RETURN
-
- ELSE IF(IMODE.EQ.-1) THEN
-C initialization
- RETURN
-
- ELSE IF(IMODE.EQ.-2) THEN
-C final output
- RETURN
- ENDIF
- END
-
-CDECK ID>, PHO_STRING
- SUBROUTINE PHO_STRING(IMODE,IREJ)
-C********************************************************************
-C
-C calculation of string combinatorics, Lorentz boosts and
-C particle codes
-C
-C - splitting of gluons
-C - strings will be built up from pairs of partons
-C according to their color labels
-C with IDHEP(..) = -1
-C - there can be other particles between to string partons
-C (these will be unchanged by string construction)
-C - string mass fine correction
-C
-C input: IMODE 1 complete string processing
-C -1 initialization
-C -2 output of statistics
-C
-C output: /POSTRG/
-C IREJ 1 combination of strings impossible
-C 0 successful combination
-C 50 rejection due to user cutoffs
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-15,
- & EPS = 1.D-5 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- IREJ = 0
- IF(IMODE.EQ.-1) THEN
- CALL PHO_POMCOR(-1)
- CALL PHO_MASCOR(-1)
- CALL PHO_PARCOR(-1,IREJ)
-
- RETURN
- ELSE IF(IMODE.EQ.-2) THEN
- CALL PHO_POMCOR(-2)
- CALL PHO_MASCOR(-2)
- CALL PHO_PARCOR(-2,IREJ)
-
- RETURN
- ENDIF
-
-C generate enhanced graphs
- IF(IPOIX2.GT.0) THEN
- 200 CONTINUE
- I1 = MAX(1,IPOIX1)
- I2 = IPOIX2
- IF(ISWMDL(14).EQ.1) IPOIX1 = 0
- KSPOMS = KSPOM-1
- KSREGS = KSREG
- KHPOMS = KHPOM
- KHDIRS = KHDIR
- IDDFS1 = IDIFR1
- IDDFS2 = IDIFR2
- IDDPOS = IDDPOM
- DO 110 I=I1,I2
- IPOIX3 = I
- KSPOM = 0
- KSREG = 0
- KHPOM = 0
- KHDIR = 0
- IF(IPORES(I).EQ.8) THEN
- KSPOM = 2
- LSPOM = 2
- LHPOM = 0
- LSREG = 0
- LHDIR = 0
- IGEN = abs(IPHIST(2,IPOPOS(1,I)))
- CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
- & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IDEB(4).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- KSPOM = KSPOMS+LSPOM
- KSREG = KSREGS+LSREG
- KHPOM = KHPOMS+LHPOM
- KHDIR = KHDIRS+LHDIR
- ELSE IF(IPORES(I).EQ.4) THEN
- ITEMP = ISWMDL(17)
- ISWMDL(17) = 0
- CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
- ISWMDL(17) = ITEMP
- IF(IREJ.NE.0) THEN
- IF(IDEB(4).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- KSDPO = KSDPO+1
- KSPOM = KSPOMS+KSPOM
- KSREG = KSREGS+KSREG
- KHPOM = KHPOMS+KHPOM
- KHDIR = KHDIRS+KHDIR
- ELSE
- IDIF1 = 1
- IDIF2 = 1
- IF(IPORES(I).EQ.5) THEN
- IDIF2 = 0
- KSTRG = KSTRG+1
- ELSE IF(IPORES(I).EQ.6) THEN
- IDIF1 = 0
- KSTRG = KSTRG+1
- ELSE
- KSLOO = KSLOO+1
- ENDIF
- ITEMP = ISWMDL(16)
- ISWMDL(16) = 0
- SPROB = 1.D0
- CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
- & 0,MSOFT,MHARD,IREJ)
- ISWMDL(16) = ITEMP
- IF(IREJ.NE.0) THEN
- IF(IDEB(4).GE.2) THEN
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- KSPOM = KSPOMS+KSPOM
- KSREG = KSREGS+KSREG
- KHPOM = KHPOMS+KHPOM
- KHDIR = KHDIRS+KHDIR
- ENDIF
- IDIFR1 = IDDFS1
- IDIFR2 = IDDFS2
- IDDPOM = IDDPOS
- 110 CONTINUE
- IF(IPOIX2.GT.I2) THEN
- IPOIX1 = I2+1
- GOTO 200
- ENDIF
- ENDIF
-
-C optional: split gluons to q-qbar pairs
- IF(ISWMDL(9).GT.0) THEN
- NHEPO = NHEP
- DO 30 I=3,NHEPO
- IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
- ICG1=ICOLOR(1,I)
- ICG2=ICOLOR(2,I)
- IQ1 = 0
- IQ2 = 0
- DO 40 K=3,NHEPO
- IF(ICOLOR(1,K).EQ.-ICG1) THEN
- IQ1 = K
- IF(IQ1*IQ2.NE.0) GOTO 45
- ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
- IQ2 = K
- IF(IQ1*IQ2.NE.0) GOTO 45
- ENDIF
- 40 CONTINUE
- WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
- & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
- CALL PHO_ABORT
- 45 CONTINUE
- CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IDEB(19).GE.5) THEN
- WRITE(LO,'(/,1X,A)')
- & 'PHO_STRING: no gluon splitting possible'
- CALL PHO_PREVNT(0)
- ENDIF
- RETURN
- ENDIF
- ENDIF
- 30 CONTINUE
- ENDIF
-
-C construct strings and write entries sorted by strings
-
- ISTR = ISTR+1
- NHEPO = NHEP
- DO 50 I=3,NHEPO
-
- IF(ISTR.GT.MSTR) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
- & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
- CALL PHO_PREVNT(0)
- IREJ = 1
- RETURN
- ENDIF
-
- IF(ISTHEP(I).EQ.1) THEN
-C hadrons / resonances / clusters
- NPOS(1,ISTR) = I
- NPOS(2,ISTR) = 0
- NPOS(3,ISTR) = 0
- NPOS(4,ISTR) = abs(IPHIST(2,I))
- NCODE(ISTR) = -99
- IPHIST(1,I) = ISTR
- ISTR = ISTR+1
- ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
-C quark /diquark terminated strings
- ICOL1 = -ICOLOR(1,I)
- P1 = PHEP(1,I)
- P2 = PHEP(2,I)
- P3 = PHEP(3,I)
- P4 = PHEP(4,I)
- ICH1 = IPHO_CHR3(I,2)
- IBA1 = IPHO_BAR3(I,2)
- CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
- & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
- & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
- JM1 = IPOS
-
- NRPOM = 0
- 65 CONTINUE
- DO 55 K=3,NHEPO
- IF(ISTHEP(K).EQ.-1)THEN
- IF(IDHEP(K).EQ.21) THEN
- IF(ICOLOR(1,K).EQ.ICOL1) THEN
- ICOL1 = -ICOLOR(2,K)
- GOTO 60
- ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
- ICOL1 = -ICOLOR(1,K)
- GOTO 60
- ENDIF
- ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
- ICOL1 = 0
- GOTO 60
- ENDIF
- ENDIF
- 55 CONTINUE
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
- CALL PHO_ABORT
- 60 CONTINUE
- P1 = P1+PHEP(1,K)
- P2 = P2+PHEP(2,K)
- P3 = P3+PHEP(3,K)
- P4 = P4+PHEP(4,K)
- NRPOM = MAX(NRPOM,IPHIST(1,K))
- ICH1 = ICH1+IPHO_CHR3(K,2)
- IBA1 = IBA1+IPHO_BAR3(K,2)
- CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
- & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
- & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
-C further parton involved?
- IF(ICOL1.NE.0) GOTO 65
- JM2 = IPOS
-C register string
- IGEN = IPHIST(2,K)
- CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
- & ISTR,IGEN,ICH1,IBA1,IPOS,1)
-C store additional string information
- NPOS(1,ISTR) = IPOS
- NPOS(2,ISTR) = JM1
- NPOS(3,ISTR) = -JM2
- NPOS(4,ISTR) = abs(IPHIST(2,K))
-C calculate CPC string codes
- CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
- & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
- ISTR = ISTR+1
- ENDIF
- 50 CONTINUE
-
- DO 150 I=3,NHEPO
-
- IF(ISTR.GT.MSTR) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
- & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
- CALL PHO_PREVNT(0)
- IREJ = 1
- RETURN
- ENDIF
-
- IF(ISTHEP(I).EQ.-1) THEN
-C gluon loop-strings
- ICOL1 = -ICOLOR(1,I)
- P1 = PHEP(1,I)
- P2 = PHEP(2,I)
- P3 = PHEP(3,I)
- P4 = PHEP(4,I)
- IBA1 = 0
- ICH1 = 0
- CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
- & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
- & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
- JM1 = IPOS
-C
- NRPOM = 0
- 165 CONTINUE
- IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
- DO 155 K=I,NHEPO
- IF(ISTHEP(K).EQ.-1)THEN
- IF(ICOLOR(1,K).EQ.ICOL1) THEN
- ICOL1 = -ICOLOR(2,K)
- GOTO 160
- ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
- ICOL1 = -ICOLOR(1,K)
- GOTO 160
- ENDIF
- ENDIF
- 155 CONTINUE
- WRITE(LO,'(/1X,A,I5)')
- & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
- CALL PHO_ABORT
- 160 CONTINUE
- P1 = P1+PHEP(1,K)
- P2 = P2+PHEP(2,K)
- P3 = P3+PHEP(3,K)
- P4 = P4+PHEP(4,K)
- NRPOM = MAX(NRPOM,IPHIST(1,K))
- CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
- & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
- & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
-C further parton involved?
- IF(ICOL1.NE.0) GOTO 165
- 170 CONTINUE
- JM2 = IPOS
-C register string
- IGEN = IPHIST(2,K)
- CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
- & ISTR,IGEN,ICH1,IBA1,IPOS,1)
-C store additional string information
- NPOS(1,ISTR) = IPOS
- NPOS(2,ISTR) = JM1
- NPOS(3,ISTR) = -JM2
- NPOS(4,ISTR) = abs(IPHIST(2,K))
-C calculate CPC string codes
- CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
- & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
- ISTR = ISTR+1
- ENDIF
- 150 CONTINUE
-
- ISTR = ISTR-1
-
- IF(IDEB(19).GE.17) THEN
- WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
- CALL PHO_PREVNT(0)
- ENDIF
-
-C pomeron corrections
- CALL PHO_POMCOR(IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(38) = IFAIL(38)+1
- IF(IDEB(19).GE.3) THEN
- WRITE(LO,'(1X,A,I6)')
- & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-
-C string mass corrections
- CALL PHO_MASCOR(IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(34) = IFAIL(34)+1
- IF(IDEB(19).GE.3) THEN
- WRITE(LO,'(1X,A,I6)')
- & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
-
-C parton mass corrections
- DO 100 I=1,ISTR
- IF(NCODE(I).GE.0) THEN
- CALL PHO_PARCOR(NPOS(1,I),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(35) = IFAIL(35)+1
- IF(IDEB(19).GE.3) THEN
- WRITE(LO,'(1X,A,I6)')
- & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
- CALL PHO_PREVNT(-1)
- ENDIF
- RETURN
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C statistics of hard processes
- DO 550 I=3,NHEP
- IF(ISTHEP(I).EQ.25) THEN
- K = IMPART(I)
- II = IDHEP(I)
- MH_acc_2(K,II) = MH_acc_2(K,II)+1
- ENDIF
- 550 CONTINUE
-
-C debug: write out strings
- IF(IDEB(19).GE.5) THEN
- IF(IDEB(19).GE.10)
- & CALL PHO_CHECK(1,IDEV)
- IF(IDEB(19).GE.15) THEN
- CALL PHO_PREVNT(0)
- ELSE
- CALL PHO_PRSTRG
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_STRFRA
- SUBROUTINE PHO_STRFRA(IREJ)
-C********************************************************************
-C
-C do all fragmentation of strings
-C
-C output: IREJ 0 successful
-C 1 rejection
-C 50 rejection due to user cutoffs
-C
-C********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
- INTEGER IREJ
-
- DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
-
- INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
- & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
-
- integer indx(500),indx_max
-
- DOUBLE PRECISION DT_RNDM
- INTEGER ipho_pdg2id
- EXTERNAL DT_RNDM,ipho_pdg2id
-
- DOUBLE PRECISION PYP,RQLUN
- INTEGER PYK
-
- INTEGER MSTU,MSTJ
- DOUBLE PRECISION PARU,PARJ
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-
- INTEGER N,NPAD,K
- DOUBLE PRECISION P,V
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
-
- DIMENSION IJOIN(100)
-
- IREJ = 0
- IF(ABS(ISWMDL(6)).GT.3) THEN
- WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
- & 'invalid value of ISWMDL(6)',ISWMDL(6)
- CALL PHO_ABORT
- ENDIF
-
-C popcorn suppression
- IF(PARMDL(134).GT.0.D0) THEN
- IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
- MSTJ(12) = 2
- ELSE
- MSTJ(12) = 1
- ENDIF
- ENDIF
-
-C copy partons to fragmentation code JETSET
- IP = 0
- IP_old = 1
-
- DO 300 J=1,ISTR
-
-C select partons with common production process
- IGEN = NPOS(4,J)
- if(IGEN.lt.0) goto 299
-
- indx_max = 0
- DO 400 I=J,ISTR
- if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
-
-C write final particles/resonances to JETSET
- IF(NCODE(I).EQ.-99) THEN
- II = NPOS(1,I)
- IP = IP+1
- P(IP,1) = PHEP(1,II)
- P(IP,2) = PHEP(2,II)
- P(IP,3) = PHEP(3,II)
- P(IP,4) = PHEP(4,II)
- P(IP,5) = PHEP(5,II)
- K(IP,1) = 1
- K(IP,2) = IDHEP(II)
- K(IP,3) = 0
- K(IP,4) = 0
- K(IP,5) = 0
- IPHIST(2,II) = IP
-
- if(indx_max.eq.500) then
- WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
- & 'no space left in index vector (indx,Kevent)',
- & indx_max,KEVENT
- IREJ = 1
- return
- endif
-
- indx_max = indx_max+1
- indx(indx_max) = II
-C write partons to JETSET
- ELSE IF(NCODE(I).GE.0) THEN
- K1 = JMOHEP(1,NPOS(1,I))
- K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
- IJ = 0
- DO II=K1,K2
- IP = IP+1
- P(IP,1) = PHEP(1,II)
- P(IP,2) = PHEP(2,II)
- P(IP,3) = PHEP(3,II)
- P(IP,4) = PHEP(4,II)
- P(IP,5) = PHEP(5,II)
- K(IP,1) = 1
- K(IP,2) = IDHEP(II)
- K(IP,3) = 0
- K(IP,4) = 0
- K(IP,5) = 0
- IPHIST(2,II) = IP
- IJ = IJ+1
- IJOIN(IJ) = IP
- indx_max = indx_max+1
- indx(indx_max) = II
-
- ENDDO
- II = JMOHEP(2,NPOS(1,I))
- IF((II.GT.0).AND.(II.NE.K1)) THEN
- IP = IP+1
- P(IP,1) = PHEP(1,II)
- P(IP,2) = PHEP(2,II)
- P(IP,3) = PHEP(3,II)
- P(IP,4) = PHEP(4,II)
- P(IP,5) = PHEP(5,II)
- K(IP,1) = 1
- K(IP,2) = IDHEP(II)
- K(IP,3) = 0
- K(IP,4) = 0
- K(IP,5) = 0
- IPHIST(2,II) = IP
- IJ = IJ+1
- IJOIN(IJ) = IP
- indx_max = indx_max+1
- indx(indx_max) = II
-
- ENDIF
- N = IP
-C connect partons to strings
-
- CALL PYJOIN(IJ,IJOIN)
-
- ENDIF
-
- NPOS(4,I) = -NPOS(4,I)
- endif
- 400 continue
-
-C set Lund counter
- N = IP
- if(IP.eq.0) goto 299
-
-C hard final state evolution
- IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
- ISH = 0
- do 125 k1=1,indx_max
- I = indx(k1)
- IF(IPHIST(1,I).LE.-100) THEN
- ISH = ISH+1
- IJOIN(ISH) = I
- ENDIF
- 125 continue
- IF(ISH.GE.2) THEN
- DO 130 K1=1,ISH
- IF(IJOIN(K1).EQ.0) GOTO 130
- I = IJOIN(K1)
- IF((IPAMDL(102).EQ.1)
- & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
- DO 135 K2=K1+1,ISH
- IF(IJOIN(K2).EQ.0) GOTO 135
- II = IJOIN(K2)
- IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
- PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
- PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
- RQLUN = MIN(PT1,PT2)
-
- IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
- & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
- CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
-
- IJOIN(K1) = 0
- IJOIN(K2) = 0
- GOTO 130
- ENDIF
- 135 CONTINUE
- 130 CONTINUE
- ENDIF
- ENDIF
-
-C fragment parton / hadron configuration (hadronization & decay)
-
- IF(ISWMDL(6).NE.0) THEN
- II = MSTU(21)
- MSTU(21) = 1
-
- CALL PYEXEC
-
- MSTU(21) = II
-C Lund warning?
- if(MSTU(28).ne.0) then
- IF(IDEB(22).GE.10) THEN
- WRITE(LO,'(1X,A,I12,I3)')
- & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
- & KEVENT,MSTU(28)
- CALL PHO_PREVNT(2)
- ENDIF
- endif
-C event accepted?
- IF(MSTU(24).NE.0) THEN
- IF(IDEB(22).GE.2) THEN
- WRITE(LO,'(1X,A,I12,I3)')
- & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
- & KEVENT,MSTU(24)
- CALL PHO_PREVNT(2)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
- ENDIF
-
- IP = N
-C change particle status in JETSET to avoid internal adjustments
- do k1=IP_old,IP
- K(k1,1) = K(k1,1)+1000
- enddo
- IP_old = IP+1
-
- 299 continue
- 300 CONTINUE
-
-C restore original JETSET particle status codes
- do i=1,N
- K(i,1) = K(i,1)-1000
- enddo
-
-* IF(IDEB(22).GE.25) THEN
-* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
-* & 'particle/string system before fragmentation'
-* CALL PHO_PREVNT(2)
-* ENDIF
-
-C copy hadrons back to POEVT1 / POEVT2
-
- IF(IP.GT.0) THEN
- NHEP1 = NHEP+1
-
- NLINES = PYK(0,1)
-
-C copy hadrons back with full history information
- IF(IPAMDL(178).EQ.1) THEN
- DO 155 II=1,ISTR
- IF(NCODE(II).GE.0) THEN
- K1 = IPHIST(2,NPOS(2,II))
- K2 = IPHIST(2,-NPOS(3,II))
- ELSE IF(NCODE(II).EQ.-99) THEN
- K1 = IPHIST(2,NPOS(1,II))
- K2 = K1
- ELSE
- GOTO 149
- ENDIF
- IFOUND = 0
- DO 160 J=1,NLINES
-
- IF(PYK(J,7).EQ.1) THEN
- IPMOTH = PYK(J,15)
-
- IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
-
- IBAM = ipho_pdg2id(PYK(J,8))
-
- IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
- IF(IDEB(22).GE.2) THEN
- WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
- & 'LUND interface (1) rejection'
- CALL PHO_PREVNT(2)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
- IFOUND = IFOUND+1
-
- PX = PYP(J,1)
- PY = PYP(J,2)
- PZ = PYP(J,3)
- HE = PYP(J,4)
- XMB = PYP(J,5)**2
-
-C register parton/hadron
- IS = 1
- IF(IBAM.EQ.0) THEN
- IF(ISWMDL(6).EQ.0) THEN
- IS = -1
- ELSE
- IF(IDEB(22).GE.2) THEN
- WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
- & 'LUND interface (2) rejection'
- CALL PHO_PREVNT(2)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
- ENDIF
-
- CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
- & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
-
- ISTHEP(IPOS) = 1
- ENDIF
- ENDIF
- 160 CONTINUE
- IF(IFOUND.EQ.0) THEN
- IF(IDEB(2).GE.2) THEN
- WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
- & 'no particles found for string (EVE,ISTR):',KEVENT,II
- ENDIF
- ISTHEP(NPOS(1,II)) = 2
- ENDIF
- 149 CONTINUE
- 155 CONTINUE
- ELSE
-C copy hadrons back without history information
- JDAHEP(1,1) = NHEP1
- JDAHEP(1,2) = NHEP1
- DO 170 J=1,NLINES
-
- IF(PYK(J,7).EQ.1) THEN
- IBAM = ipho_pdg2id(PYK(J,8))
-
- IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
- IF(IDEB(22).GE.2) THEN
- WRITE(LO,'(/1X,A)')
- & 'PHO_STRFRA: LUND interface (3) rejection'
- CALL PHO_PREVNT(2)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
-
- PX = PYP(J,1)
- PY = PYP(J,2)
- PZ = PYP(J,3)
- HE = PYP(J,4)
- XMB = PYP(J,5)**2
-
-C register parton/hadron
- IS = 1
- IF(IBAM.EQ.0) THEN
- IF(ISWMDL(6).EQ.0) THEN
- IS = -1
- ELSE
- IF(IDEB(22).GE.2) THEN
- WRITE(LO,'(/1X,A)')
- & 'PHO_STRFRA: LUND interface (4) rejection'
- CALL PHO_PREVNT(2)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
- ENDIF
-
- CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
- & HE,J,0,0,0,IPOS,1)
-
- ISTHEP(IPOS) = 1
- ENDIF
- 170 CONTINUE
- DO 180 II=1,ISTR
- IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
- & ISTHEP(NPOS(1,II)) = 2
- 180 CONTINUE
- ENDIF
- ENDIF
-
-C debug event status
- IF(IDEB(22).GE.15) THEN
- WRITE(LO,'(//1X,A)')
- & 'PHO_STRFRA: particle system after fragmentation'
- CALL PHO_PREVNT(2)
- ENDIF
-
- END
-
-CDECK ID>, PHO_EVEINI
- SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
-C********************************************************************
-C
-C prepare /POEVT1/ for new event
-C
-C first subroutine called for each event
-C
-C input: P1(4) particle 1
-C P2(4) particle 2
-C IMODE 0 general initialization
-C 1 initialization of particles and kinematics
-C 2 initialization after internal rejection
-C
-C output: IP1,IP2 index of interacting particles
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION P1(4),P2(4)
-
- PARAMETER ( EPS = 1.D-5,
- & DEPS = 1.D-15 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C gamma-lepton or gamma-hadron vertex information
- INTEGER IGHEL,IDPSRC,IDBSRC
- DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
- & RADSRC,AMSRC,GAMSRC
- COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
- & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
- & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DIMENSION IM(2)
-
-C reset debug variables
- KSPOM = 0
- KHPOM = 0
- KSREG = 0
- KHDIR = 0
- KSTRG = 0
- KHTRG = 0
- KSLOO = 0
- KHLOO = 0
- KSDPO = 0
- KSOFT = 0
- KHARD = 0
-C
- IDNODF = 0
- IDIFR1 = 0
- IDIFR2 = 0
- IDDPOM = 0
- ISTR = 0
- IPOIX1 = 0
- IF(ISWMDL(14).GT.0) IPOIX1 = 1
- IPOIX2 = 0
- IPOIX3 = 0
-C reset /POEVT1/ and /POEVT2/
- CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
- & 0,0,0,0,IPOS,0)
- CALL PHO_SELCOL(0,0,0,0,0,0,0)
- DO 15 I=0,10
- IPOWGC(I) = 0
- 15 CONTINUE
-
-C initialization of particle kinematics
-
-C lepton-photon/hadron-photon vertex and initial particles
- IM(1) = 0
- IM(2) = 0
- IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
- CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
- & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
- ELSE
- CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
- & P1(4),0,0,0,0,IP1,1)
- ENDIF
- IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
- CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
- & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
- ELSE
- CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
- & P2(4),0,0,0,0,IP2,1)
- ENDIF
- IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
- CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
- & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
- CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
- & P1(4),0,0,0,0,IP1,1)
- ENDIF
- IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
- CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
- & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
- CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
- & P2(4),0,0,0,0,IP2,1)
- ENDIF
- NEVHEP = KACCEP
-
- IF(IMODE.LE.1) THEN
-C CMS energy
- ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
- & -(P1(3)+P2(3))**2)
-* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
- PMASS(1) = PHEP(5,IP1)
- PVIRT(1) = 0.D0
- IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
- PMASS(2) = PHEP(5,IP2)
- PVIRT(2) = 0.D0
- IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
- ENDIF
-
-C cross section calculations
-
- IF(IMODE.NE.1) THEN
- IP = 1
- CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
- & ECM,PVIRT(1),PVIRT(2))
- ENDIF
-
- IF(IMODE.LE.0) THEN
-C effective cross section
- SIGGEN(3) = 0.D0
- IF(ISWMDL(2).ge.1) THEN
- IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
- & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
- & -SIGHDD-SIGDIR
- IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
- IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
- IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
- IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
- IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
- IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
- IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
-C simulate only hard scatterings
- ELSE
- IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
- IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
- ENDIF
-
- ENDIF
-
-C reset of mother/daughter relations only (IMODE = 2)
-
-C debug output
- IF(IDEB(63).GE.15) THEN
- WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
- & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
- IF(IMODE.LE.0) THEN
- WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
- & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
- & FSUP,FSUH,FSUD
- ONEM = -1.D0
- ITMP = IDEB(57)
- IDEB(57) = MAX(5,ITMP)
- CALL PHO_XSECT(1,0,ONEM)
- IDEB(57) = ITMP
- ENDIF
- CALL PHO_PREVNT(0)
- ENDIF
-
- END
-
-CDECK ID>, PHO_CSINT
- SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
-C********************************************************************
-C
-C calculate cross sections by interpolation
-C
-C input: IP particle combination
-C IFPA/B particle PDG number
-C IHLA/B particle helicity (photons only)
-C ECM c.m. energy (GeV)
-C PVIR2A virtuality of particle A (GeV**2, positive)
-C PVIR2B virtuality of particle B (GeV**2, positive)
-C
-C output: cross sections stored in /POCSEC/
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-5,
- & DEPS = 1.D-15 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
- DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
-
- dimension PD(-6:6),FH_T(2),FH_L(2)
-
-C debug
- IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
- & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
- & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
-
-C check currently stored cross sections
- IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
- & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
- & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
-C nothing to calculate
- IF(IDEB(15).GE.20)
- & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
- RETURN
- ELSE
-
-C copy to local fields
- IFPAP(1) = IFPA
- IFPAP(2) = IFPB
- IHEL(1) = IHLA
- IHEL(2) = IHLB
- PVIRT(1) = PVIR2A
- PVIRT(2) = PVIR2B
-
-C load cross sections from interpolation table
- IF(ECM.LE.SIGECM(IP,1)) THEN
- I1 = 1
- I2 = 2
- ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
- DO 50 I=2,ISIMAX
- IF(ECM.LE.SIGECM(IP,I)) GOTO 200
- 50 CONTINUE
- 200 CONTINUE
- I1 = I-1
- I2 = I
- ELSE
- WRITE(LO,'(/1X,A,2E12.3)')
- & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
- CALL PHO_PREVNT(-1)
- I1 = ISIMAX-1
- I2 = ISIMAX
- ENDIF
- FAC2=0.D0
- IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
- & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
- FAC1=1.D0-FAC2
-
-C cross section dependence on photon virtualities
- DO 140 K=1,2
- FSUP(K) = 1.D0
- FSUD(K) = 1.D0
- FSUH(K) = 1.D0
- IF(IFPAP(K).EQ.22) THEN
- IF(ISWMDL(10).GE.1) THEN
- FSUP(K) = 0.D0
- FSUT(K) = 0.D0
- FSUL(K) = 0.D0
- FSUH(K) = 0.D0
-C GVDM factors for transverse/longitudinal photons
- DO 150 I=1,3
- FSUT(K) = FSUT(K)+PARMDL(26+I)
- & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
- FSUL(K) = FSUL(K)
- & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
- & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
- 150 CONTINUE
- FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
-C transverse part
- IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
- FSUP(K) = FSUT(K)
- FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
-C diffraction of trans. photons corresponds mainly to leading twist
- FSUD(K) = 1.D0
- ENDIF
-C longitudinal (scalar) part
- IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
- FSUP(K) = FSUP(K)+FSUL(K)
- FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
-C diffraction of long. photons corresponds mainly to higher twist
- FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
- & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
- & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
- ENDIF
-C debug output
- if(ideb(15).ge.10) then
- WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
- & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
- & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
- endif
- ENDIF
- ENDIF
- 140 CONTINUE
-
- FACP = FSUP(1)*FSUP(2)
- FACH = FSUH(1)*FSUH(2)
- FACD = FSUD(1)*FSUD(2)
-
-C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
-
- if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
- & .and.(IPAMDL(117).gt.0)) then
-C check kinematic limit
- Q2_max = max(PVIRT(1),PVIRT(2))
- Q2_min = min(PVIRT(1),PVIRT(2))
- if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
-
-C calculate F2 from current parton density
- if(PVIRT(1).gt.PVIRT(2)) then
- K = 2
- else
- K = 1
- endif
- Q2 = Q2_max
- P2 = Q2_min
- X = Q2/(ECM**2+Q2+P2)
- call pho_actpdf(IFPAP(K),K)
- call pho_pdf(K,X,Q2,P2,PD)
-C light quark contribution
- F2_light = 0.D0
- do j=1,3
- F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
- enddo
-C heavy quark contribution
- call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
- F2_c = 2.D0*4.D0/9.D0*xpdf_c
- F2 = (F2_light+F2_c)
-
-C calculate model prediction
- SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
- SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
- CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
-
- if(ISWMDL(10).ge.2) then
-
-C calculate all helicity combinations
- if(IPAMDL(115).eq.0) then
- SIGDIH = HSig(14)
- SIGSRH(1) = HSig(10)+HSig(11)
- SIGSRH(2) = HSig(12)+HSig(13)
- SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
-C photon helicity factors
- FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
- FH_L(1) = 1.D0-FH_T(1)
- FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
- FH_L(2) = 1.D0-FH_T(2)
- SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
- & + SIGDIH*FH_T(1)*FH_T(2)
- & + SIGSRH(1)*FH_T(1)*FSUT(2)
- & + SIGSRH(2)*FSUT(1)*FH_T(2)
- SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
- & + SIGDIH*FH_T(1)*FH_L(2)
- & + SIGSRH(1)*FH_T(1)*FSUL(2)
- & + SIGSRH(2)*FSUT(1)*FH_L(2)
- SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
- & + SIGDIH*FH_L(1)*FH_T(2)
- & + SIGSRH(1)*FH_L(1)*FSUT(2)
- & + SIGSRH(2)*FSUL(1)*FH_T(2)
- SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
- & + SIGDIH*FH_L(1)*FH_L(2)
- & + SIGSRH(1)*FH_L(1)*FSUL(2)
- & + SIGSRH(2)*FSUL(1)*FH_L(2)
- else
-C use explicit PDF virtuality dependence (pre-tabulated)
- SIGDIH = HSig(14)
- SIGSRH(1) = HSig(10)+HSig(11)
- SIGSRH(2) = HSig(12)+HSig(13)
- SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
- print LO,' PHO_CSINT: invalid option for F2 matching'
- stop
-* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
-* & Max_pro_2,3,4,1)
-* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
-* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
-* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
-* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
-* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
-* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
-* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
-* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
- endif
- Xnu = Ecm*Ecm+Q2+P2
- F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
- & *137.D0/GeV2mb
- if(K.eq.2) then
- F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
- F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
- & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
- else
- F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
- F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
- & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
- endif
-
- else
-
-C assume sig_eff = sigtot
- SIGDIH = HSig(14)
- SIGSRH(1) = HSig(10)+HSig(11)
- SIGSRH(2) = HSig(12)+HSig(13)
- SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
- SIGeff = SIGtmp*FSUP(1)*FSUP(2)
- & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
- Xnu = Ecm*Ecm+Q2+P2
- F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
- & *137.D0/GeV2mb
- F2m = F2_fac*SIGeff
- F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
- endif
-* print LO,' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
-* print LO,' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
-
-C global factor to re-scale suppression of soft contributions
- Fcorr = (F2-F2m+F2s)/F2s
-* print LO,' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
- FACP = FACP*Fcorr
-
- endif
- endif
-
- SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
- SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
- SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
- J = 2
- DO 5 I=0,4
- DO 6 K=0,4
- J = J+1
- SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
- & *FACP**2
- 6 CONTINUE
- 5 CONTINUE
-
- SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
- SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
-C suppression of multi-pomeron graphs (diffraction)
- SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
- & *FACP*FSUP(2)*FSUD(1)
- SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
- & *FACP*FSUP(1)*FSUD(2)
- SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
- & *FACP*FSUP(2)*FSUD(1)
- SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
- & *FACP*FSUP(1)*FSUD(2)
- SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
- & *FACP**2*FACD
- SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
- SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
- & *FACP**2
- SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
- & *FACP*FSUP(2)*FSUD(1)
- SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
- & *FACP*FSUP(2)*FSUD(1)
- SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
- & *FACP*FSUP(1)*FSUD(2)
- SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
- & *FACP*FSUP(1)*FSUD(2)
- SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
- SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
- & *FACP**2
- SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
- & *FACP**2
- SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
- & *FACP**2
- SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
- & *FACP**2
-
-C corrections due to photon virtuality dependence of PDFs
- if(iswmdl(2).eq.1) then
- CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
-C minimum bias event generation
- IF(IPAMDL(115).GE.1) THEN
-C all the virtuality dependence is given by PDF parametrization
- SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
- IF(IPAMDL(116).GE.2) THEN
-C direct interaction according to full QPM calculation
- SIGDIH = HSig(14)
- SIGSRH(1) = HSig(10)+HSig(11)
- SIGSRH(2) = HSig(12)+HSig(13)
- ELSE
-C direct interaction suppressed according to helicity factor
- SIGDIH = HSig(14)*FACH
- SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
- SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
- ENDIF
- print LO,' PHO_CSINT: option not supported yet'
- stop
- ELSE
-C rescale relevant hard processes
- SIGDIH = HSig(14)
- SIGSRH(1) = HSig(10)+HSig(11)
- SIGSRH(2) = HSig(12)+HSig(13)
- SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
- SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
- & +SIGSRH(2)*FSUP(1)*FSUH(2)
- SIGINE = SIGtmp+SIGDIR
- SIGTOT = SIGINE+SIGELA
- ENDIF
- else
-C only hard interactions
- CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
- SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
- SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
- SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
- SIGHAR = HSig(9)*FACH
- endif
-
- SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
- SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
- SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
- J = 39
- DO 9 I=1,4
- DO 10 K=1,4
- J = J+1
- SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
- 10 CONTINUE
- 9 CONTINUE
- SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
- SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
-
- IPFIL = IP
- IFAFIL = IFPA
- IFBFIL = IFPB
- ECMFIL = ECM
- P2AFIL = PVIR2A
- P2BFIL = PVIR2B
-
- IF(IDEB(15).GE.20)
- & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_PRIMKT
- SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
-C***********************************************************************
-C
-C give primordial kt to partons entering hard scatterings and
-C remants connected to hard parton-parton interactions by color flow
-C
-C input: IMODE -2 output of statistics
-C -1 initialization
-C 1 sampling of primordial kt
-C IF first entry in /POEVT1/ to check
-C IL last entry in /POEVT1/ to check
-C PTCUT current value of PTCUT to distinguish
-C between soft and hard
-C
-C output: IREJ 0 success
-C 1 failure
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- DOUBLE PRECISION DEPS
- PARAMETER ( DEPS = 1.D-15 )
-
- INTEGER IMODE,IF,IL,IREJ
- DOUBLE PRECISION PTCUT
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
- DIMENSION PTS(0:2,5),XP(5),
- & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
-
- INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
-
- PARAMETER (IRMAX=200)
- DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
-
- DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
- & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
- INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
-
-C debug output
- IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
- & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
- & IMODE,IF,IL,PTCUT
-
-C give primordial kt to partons engaged in a hard scattering
-
- IF(IMODE.EQ.1) THEN
-
- ISTART = IF
-
- 100 CONTINUE
-
- NHD = 0
- IBAL(1) = 0
- IBAL(2) = 0
- IROT = 0
- ICOM = 0
- DO 110 I=ISTART,IL
- IF(ISTHEP(I).EQ.25) THEN
-C hard scattering number
- NHD = IPHIST(1,I+1)
- ICOM = I
- K = LSIDX(NHD/100)
-C calculate momenta of incoming partons
- POLD(1,1) = XHD(K,1)*ECMP/2.D0
- POLD(2,1) = POLD(1,1)
- POLD(1,2) = -XHD(K,2)*ECMP/2.D0
- POLD(2,2) = -POLD(1,2)
- ISTART = I+3
- GOTO 150
- ENDIF
- 110 CONTINUE
- RETURN
-
- 150 CONTINUE
-
-C search for partons involved in hard interaction
- INEXT = 0
- IROT = 0
- DO 500 I=ISTART,IL
- IF(ABS(ISTHEP(I)).EQ.1) THEN
-C hard scatterd partons (including ISR)
- IF((IPHIST(1,I).EQ.-NHD)
- & .OR.(IPHIST(1,I).EQ.NHD+1)
- & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
- IROT = IROT+1
-
- IF(IROT.GT.IRMAX) THEN
- WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
- & 'no memory left in IROTT, event rejected (max/IROT)',
- & IRMAX,IROT
- CALL PHO_PREVNT(0)
- IREJ = 1
- RETURN
- ENDIF
-
- IROTT(IROT) = I
-C hard remnant
- ELSE IF(IPHIST(1,I).EQ.NHD) THEN
- IF(PHEP(3,I).GT.0.D0) THEN
- J = 1
- ELSE
- J = 2
- ENDIF
- IBAL(J) = IBAL(J)+1
- IBALT(IBAL(J),J) = I
- XP2(IBAL(J),J) = PHEP(3,I)/ECMP
- IF(ISWMDL(24).EQ.0) THEN
- IV2(IBAL(J),J) = 0
- IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
- ELSE IF(ISWMDL(24).EQ.1) THEN
- IV2(IBAL(J),J) = -1
- ELSE
- IV2(IBAL(J),J) = 1
- ENDIF
- ENDIF
-C possibly further hard scattering
- ELSE IF(ISTHEP(I).EQ.25) THEN
- INEXT = 1
- ISTART = I
- GOTO 550
- ENDIF
- 500 CONTINUE
- 550 CONTINUE
-
-C debug output
- if(IDEB(10).ge.15) then
- WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
- & 'hard scattering number: ',NHD/100
- WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
- & 'number of entries to rotate: ',IROT
- DO I=1,IROT
- WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
- & 'entries to rotate: ',I,IROTT(I)
- ENDDO
- WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
- & 'number of entries to balance: ',IBAL
- DO J=1,2
- DO I=1,IBAL(J)
- WRITE(LO,'(1X,2A,I2,2I5)')
- & 'PHO_PRIMKT: entries to balance (side,no,line)',
- & J,I,IBALT(I,J)
- ENDDO
- ENDDO
- endif
-
-C incoming partons (comment lines), skip direct interacting particles
- DO 120 K=1,2
- IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
- IF(PHEP(3,ICOM+K).GT.0.D0) THEN
- J = 1
- ELSE
- J = 2
- ENDIF
- IBAL(J) = IBAL(J)+1
- IBALT(IBAL(J),J) = -ICOM-K
- XP2(IBAL(J),J) = POLD(1,J)/ECMP
- IV2(IBAL(J),J) = -1
- ENDIF
- 120 CONTINUE
-
-C check consistency
- IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
- WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
- & 'inconsistent hard scattering remnant for event: ',KEVENT
- WRITE(LO,'(1X,A,3I4,1P,E11.3)')
- & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
- & IMODE,IF,IL,PTCUT
- WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
- DO 390 I=1,IROT
- WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
- 390 CONTINUE
- DO 392 J=1,2
- DO 395 I=1,IBAL(J)
- WRITE(LO,'(1X,A,I2,2I5)')
- & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
- 395 CONTINUE
- 392 CONTINUE
- IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
- ENDIF
-
-C calculate primordial kt
-
-C something to do?
- IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
-
-C add transverse momentum (overwrite /POEVT1/ entries)
- DO 200 J=1,2
- IF(IBAL(J).GT.1) THEN
-C sample from truncated distribution
- K = IBAL(J)
- DO 180 I=1,K
- IV(I) = IV2(I,J)
- XP(I) = XP2(I,J)
- 180 CONTINUE
- 190 CONTINUE
- CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
- IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
-C transform incoming partons of hard scattering
- DEL = ABS(POLD(1,J))+POLD(2,J)
- PT2 = PTS(0,K)**2
- DEL2 = DEL*DEL
- PNEW(1,J) = PTS(1,K)
- PNEW(2,J) = PTS(2,K)
- PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
- PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
-C spectator partons
- ESUM = 0.D0
- DO 220 I=1,IBAL(J)-1
- K = IBALT(I,J)
- PHEP(1,K) = PHEP(1,K)+PTS(1,I)
- PHEP(2,K) = PHEP(2,K)+PTS(2,I)
- ESUM = ESUM+PHEP(4,K)
- 220 CONTINUE
-C long. momentum transfer
- PP(3) = PNEW(3,J) - POLD(1,J)
- PP(4) = PNEW(4,J) - POLD(2,J)
- DO 230 I=1,IBAL(J)-1
- K = IBALT(I,J)
- FAC = PHEP(4,K)/ESUM
- PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
- PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
- 230 CONTINUE
-
-C debug output
- IF(IDEB(10).GE.15) THEN
- WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
- & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
- WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
- & 'new incoming:',J,(PNEW(I,J),I=1,4)
- ENDIF
-
- ELSE
- PNEW(1,J) = 0.D0
- PNEW(2,J) = 0.D0
- PNEW(3,J) = POLD(1,J)
- PNEW(4,J) = POLD(2,J)
- ENDIF
- 200 CONTINUE
-
-C transformation of hard scattering final states (including ISR)
-
-C old parton c.m. energy
- SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
- EI = SQRT(SI)
-C new parton c.m. energy
- SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
- & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
- EF = SQRT(SF)
- FAC = EF/EI
-C debug output
- IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
- & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
-
-C calculate Lorentz transformation
- GAZ = -(POLD(1,1)+POLD(1,2))/EI
- GAE = (POLD(2,1)+POLD(2,2))/EI
- DO 240 I=1,4
- GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
- 240 CONTINUE
- CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
- & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
- PTOT = MAX(DEPS,PTOT)
- COD= PP(3)/PTOT
- SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
- COF= 1.D0
- SIF= 0.D0
- IF(PTOT*SID.GT.1.D-5) THEN
- COF=PP(1)/(SID*PTOT)
- SIF=PP(2)/(SID*PTOT)
- ANORF=SQRT(COF*COF+SIF*SIF)
- COF=COF/ANORF
- SIF=SIF/ANORF
- ENDIF
-
-C debug output
-C check consistency initial/final configuration before rotation
- IF(IDEB(10).GE.25) THEN
- WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
- & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
- DO I=1,4
- PP(I) = 0.D0
- ENDDO
- DO I=1,IROT
- K = IROTT(I)
- DO J=1,4
- PP(J) = PP(J)+PHEP(J,K)
- ENDDO
- ENDDO
- WRITE(LO,'(1X,A,1P,4E11.3)')
- & 'PHO_PRIMKT: fin. momentum (1):',PP
- ENDIF
-
-C apply rotation/boost to scattered particles
- DO 400 I=1,IROT
- K = IROTT(I)
- DO 350 J=1,4
- PP(J) = FAC*PHEP(J,K)
- 350 CONTINUE
- CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
- & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
- CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
- & COD,SID,COF,SIF,XX,YY,ZZ)
- EE = PHEP(4,K)
- CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
- & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
- 400 CONTINUE
-
-C debug output
-C check consistency initial/final configuration after rotation
- IF(IDEB(10).GE.25) THEN
- DO I=1,4
- PP(I) = PNEW(I,1)+PNEW(I,2)
- ENDDO
- WRITE(LO,'(1X,A,1P,4E11.3)')
- & 'PHO_PRIMKT: ini. momentum (2):',PP
- DO I=1,4
- PP(I) = 0.D0
- ENDDO
- DO I=1,IROT
- K = IROTT(I)
- DO J=1,4
- PP(J) = PP(J)+PHEP(J,K)
- ENDDO
- ENDDO
- WRITE(LO,'(1X,A,1P,4E11.3)')
- & 'PHO_PRIMKT: fin. momentum (2):',PP
- ENDIF
-
- ENDIF
-
- IF(INEXT.EQ.1) GOTO 100
-
-C initialization
-
- ELSE IF(IMODE.EQ.-1) THEN
-
-C output of statistics etc.
-
- ELSE IF(IMODE.EQ.-2) THEN
-
-C something wrong
-
- ELSE
- WRITE(LO,'(/1X,A,I4)')
- & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_PARTPT
- SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
-C********************************************************************
-C
-C assign to soft partons
-C
-C input: IMODE -2 output of statistics
-C -1 initialization
-C 0 sampling of pt for soft partons belonging to
-C soft Pomerons
-C 1 sampling of pt for soft partons belonging to
-C hard Pomerons
-C IF first entry in /POEVT1/ to check
-C IL last entry in /POEVT1/ to check
-C PTCUT current value of PTCUT to distinguish
-C between soft and hard
-C
-C output: IREJ 0 success
-C 1 failure
-C
-C (soft pt is sampled by call to PHO_SOFTPT)
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-15 )
-
- INTEGER IMODE,IF,IL,IREJ
- DOUBLE PRECISION PTCUT
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DOUBLE PRECISION PTS,PB,XP,XPB,PC
- DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
-
- INTEGER MODIFY,IV,IVB
- DIMENSION MODIFY(50),IV(50),IVB(2)
-
-C debug output
- IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
- & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
- & IMODE,IF,IL,PTCUT
-
- IF(IMODE.LT.0) GOTO 1000
-
- IREJ = 0
- IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
-
-C count entries to modify
- IENTRY = 0
- PTCUT2 = PTCUT**2
- EMIN = 1.D20
- IPEAK = 1
- ISTART = IF
-
-C soft Pomerons
-
- IF(IMODE.EQ.0) THEN
- DO 300 I=ISTART,IL
- IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
- IENTRY = IENTRY+1
- MODIFY(IENTRY) = I
- XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
- IV(IENTRY) = 0
- IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
- IF(PHEP(4,I).LT.EMIN) THEN
- EMIN = PHEP(4,I)
- IPEAK = IENTRY
- ENDIF
- ENDIF
- 300 CONTINUE
-
-C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
-
- ELSE IF(IMODE.EQ.1) THEN
-
- DO 350 I=ISTART,IL
- IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
- IF(MOD(IPHIST(1,I),100).EQ.0) THEN
- IENTRY = IENTRY+1
- MODIFY(IENTRY) = I
- XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
- IF(ISWMDL(24).EQ.0) THEN
- IV(IENTRY) = 0
- IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
- ELSE IF(ISWMDL(24).EQ.1) THEN
- IV(IENTRY) = -1
- ELSE
- IV(IENTRY) = 1
- ENDIF
- IF(PHEP(4,I).LT.EMIN) THEN
- EMIN = PHEP(4,I)
- IPEAK = IENTRY
- ENDIF
- ENDIF
- ENDIF
- 350 CONTINUE
-
-C something wrong
-
- ELSE
- WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
- CALL PHO_ABORT
- ENDIF
-
-C debug output
- IF(IDEB(6).GE.5) THEN
- WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
- & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
- IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
- ENDIF
-
-C nothing to do
- IF(IENTRY.LE.1) RETURN
-
-C sample pt of soft partons
-
- IF(ISWMDL(5).LE.1) THEN
- ITER = 0
- IPEAK = DT_RNDM(DUM)*IENTRY+1
- CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
- CALL PHO_SWAPD(XP(IPEAK),XP(1))
- CALL PHO_SWAPI(IV(IPEAK),IV(1))
- 400 CONTINUE
-C energy limited sampling
- PSUMX = 0.D0
- PSUMY = 0.D0
- ITER = ITER+1
- IF(ITER.GE.1000) THEN
- IF(IDEB(6).GE.3) THEN
- WRITE(LO,'(1X,A,3I5)')
- & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
- & IMODE,IENTRY,ITER
- WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
- & IPEAK
- DO 405 I=1,IENTRY
- II = MODIFY(I)
- WRITE(LO,'(5X,3I5,1P,2E13.4)')
- & I,II,IV(I),XP(I),PHEP(4,II)
- 405 CONTINUE
- IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
- ENDIF
- IREJ = 1
- RETURN
- ENDIF
- DO 410 I=2,IENTRY
- II = MODIFY(I)
- PTMX = MIN(PHEP(4,II),PTCUT)
- XPB(1) = XP(I)
- IVB(1) = IV(I)
- IF(ISWMDL(5).EQ.0) THEN
- CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
- ELSE
- CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
- ENDIF
- PTS(0,I) = PB(0,1)
- PTS(1,I) = PB(1,1)
- PTS(2,I) = PB(2,1)
- PSUMX = PSUMX+PB(1,1)
- PSUMY = PSUMY+PB(2,1)
- 410 CONTINUE
- PTREM = SQRT(PSUMX**2+PSUMY**2)
- IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
- PTS(1,1) = -PSUMX
- PTS(2,1) = -PSUMY
- ELSE IF((ISWMDL(5).EQ.2)
- & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
-C unlimited sampling
- IPEAK = DT_RNDM(PSUMX)*IENTRY+1
- CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
- CALL PHO_SWAPD(XP(IPEAK),XP(1))
- CALL PHO_SWAPI(IV(IPEAK),IV(1))
- CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
- ELSE IF(ISWMDL(5).EQ.3) THEN
-C each string has balanced pt
- DO 500 K=1,IENTRY
- IF(IV(K).LE.-90) GOTO 499
- I1 = MODIFY(K)
- IC1 = -ICOLOR(1,I1)
- DO 510 L=K+1,IENTRY
- IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
- 510 CONTINUE
- WRITE(LO,'(//1X,A,I5)')
- & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
- CALL PHO_ABORT
- 511 CONTINUE
- I2 = MODIFY(L)
- AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
- & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
- AM = SQRT(AMSQR)
- PTMX = AM/2.D0
- IVB(1) = MAX(IV(K),IV(L))
- XPB(1) = XP(K)
- CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
- PTS(1,K) = PB(1,1)
- PTS(2,K) = PB(2,1)
- PTS(1,L) = -PB(1,1)
- PTS(2,L) = -PB(2,1)
- GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
- GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
- PC(1) = PB(1,1)
- PC(2) = PB(2,1)
- PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
- PC(3) = SIGN(PLONG,PHEP(3,I1))
- PC(4) = PTMX
- CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
- & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
- PC(1) = -PC(1)
- PC(2) = -PC(2)
- PC(3) = -PC(3)
- CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
- & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
- IV(K) = IV(K)-100
- IV(L) = IV(L)-100
- 499 CONTINUE
- 500 CONTINUE
- ELSE
- WRITE(LO,'(/1X,A,I4)')
- & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
- CALL PHO_ABORT
- ENDIF
-
-C change partons in /POEVT1/
- DO 900 II=1,IENTRY
- IF(IV(II).GT.-90) THEN
- I = MODIFY(II)
- PHEP(1,I) = PHEP(1,I)+PTS(1,II)
- PHEP(2,I) = PHEP(2,I)+PTS(2,II)
- AMSQR = PHEP(4,I)**2
- & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
- PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
- ENDIF
- 900 CONTINUE
-
-C debug output
- IF(IDEB(6).GE.15) THEN
- WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
- & 'I II IV XP EP PTS PTX PTY',IPEAK
- DO 505 I=1,IENTRY
- II = MODIFY(I)
- WRITE(LO,'(2X,3I5,1P,5E12.4)')
- & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
- 505 CONTINUE
- CALL PHO_PREVNT(0)
- ENDIF
- RETURN
-
-C initialization / output of statistics
- 1000 CONTINUE
- CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
-
- END
-
-CDECK ID>, PHO_SOFTPT
- SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
-C***********************************************************************
-C
-C select pt of soft string ends
-C
-C input: ISOFT number of soft partons
-C -1 initialization
-C >=0 sampling of p_t
-C -2 output of statistics
-C PTCUT cutoff for soft strings
-C PTMAX maximal allowed PT
-C XV field of x values
-C IV 0 sea quark
-C 1 valence quark
-C
-C output: /POINT3/ containing parameters AAS,BETAS
-C PTSOF filed with soft pt values
-C
-C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
-C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
-C ISWMDL(3/4) = 2 photon wave function
-C ISWMDL(3/4) = 10 no soft P_t assignment
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-15)
-
- DIMENSION PTSOF(0:2,*),XV(*)
- DIMENSION IV(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-
- DIMENSION BETAB(100)
-
-C selection of pt
- IF(ISOFT.GE.0) THEN
- CALLS = CALLS + 1.D0
-C sample according to model ISWMDL(3-6)
- IF(ISOFT.GT.1) THEN
- 210 CONTINUE
- PTXS = 0.D0
- PTYS = 0.D0
- DO 300 I=2,ISOFT
- IMODE = ISWMDL(3)
-C valence partons
- IF(IV(I).EQ.1) THEN
- BETA = BETAS(1)
-C photon/pomeron valence part
- IF(IPAMDL(5).EQ.1) THEN
- IF(XV(I).GE.0.D0) THEN
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- IMODE = ISWMDL(4)
- BETA = BETAS(3)
- ENDIF
- ELSE
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- IMODE = ISWMDL(4)
- BETA = BETAS(3)
- ENDIF
- ENDIF
- ELSE IF(IPAMDL(5).EQ.2) THEN
- BETA = PARMDL(20)
- ELSE IF(IPAMDL(5).EQ.3) THEN
- BETA = BETAS(3)
- ENDIF
-C sea partons
- ELSE IF(IV(I).EQ.0) THEN
- BETA = BETAS(3)
-C hard scattering remnant
- ELSE
- IF(IPAMDL(6).EQ.0) THEN
- BETA = BETAS(1)
- ELSE IF(IPAMDL(6).EQ.1) THEN
- BETA = BETAS(3)
- ELSE
- BETA = PARMDL(20)
- ENDIF
- ENDIF
- BETA = MAX(BETA,0.01D0)
- CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
- PTS = MIN(PTMAX,PTS)
- CALL PHO_SFECFE(SIG,COG)
- PTSOF(0,I) = PTS
- PTSOF(1,I) = COG*PTS
- PTSOF(2,I) = SIG*PTS
- PTXS = PTXS+PTSOF(1,I)
- PTYS = PTYS+PTSOF(2,I)
- BETAB(I) = BETA
- 300 CONTINUE
-C balancing of momenta
- PTS = SQRT(PTXS**2+PTYS**2)
- IF(PTS.GE.PTMAX) GOTO 210
- PTSOF(0,1) = PTS
- PTSOF(1,1) = -PTXS
- PTSOF(2,1) = -PTYS
- BETAB(1) = 0.D0
-C
-*400 CONTINUE
-C
-C single parton only
- ELSE
- IMODE = ISWMDL(3)
-C valence partons
- IF(IV(1).EQ.1) THEN
- BETA = BETAS(1)
-C photon/Pomeron valence part
- IF(IPAMDL(5).EQ.1) THEN
- IF(XV(1).GE.0.D0) THEN
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- IMODE = ISWMDL(4)
- BETA = BETAS(3)
- ENDIF
- ELSE
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- IMODE = ISWMDL(4)
- BETA = BETAS(3)
- ENDIF
- ENDIF
- ELSE IF(IPAMDL(5).EQ.2) THEN
- BETA = PARMDL(20)
- ELSE IF(IPAMDL(5).EQ.3) THEN
- BETA = BETAS(3)
- ENDIF
-C sea partons
- ELSE IF(IV(1).EQ.0) THEN
- BETA = BETAS(3)
-C hard scattering remnant
- ELSE
- IF(IPAMDL(6).EQ.1) THEN
- BETA = BETAS(3)
- ELSE
- BETA = PARMDL(20)
- ENDIF
- ENDIF
- BETA = MAX(BETA,0.01D0)
- CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
- PTS = MIN(PTMAX,PTS)
- CALL PHO_SFECFE(SIG,COG)
- PTSOF(0,1) = PTS
- PTSOF(1,1) = COG*PTS
- PTSOF(2,1) = SIG*PTS
- BETAB(1) = BETA
- ENDIF
-
-C debug output
- IF(IDEB(29).GE.10) THEN
- WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
- WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
- DO 105 I=1,ISOFT
- WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
- & PTSOF(1,I),PTSOF(2,I),BETAB(I)
- 105 CONTINUE
- ENDIF
-
-C initialization of statistics and parameters
-
- ELSE IF(ISOFT.EQ.-1) THEN
- PTSMIN = 0.D0
- PTSMAX = PTCUT
-
- IMODE = -100+ISWMDL(3)
- CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
-
-C output of statistics
-
- ELSE IF(ISOFT.EQ.-2) THEN
-
- ELSE
- WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
- & 'unsupported ISOFT ',ISOFT
- STOP
- ENDIF
- END
-
-CDECK ID>, PHO_SELPT
- SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
-C***********************************************************************
-C
-C select pt from different distributions
-C
-C input: EE energy (for initialization only)
-C otherwise x value of corresponding parton
-C PTLOW lower pt limit
-C PTHIGH upper pt limit
-C (PTHIGH > 20 will cause DEXP underflows)
-C
-C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
-C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
-C IMODE = 2 dNs/dP_t according photon wave function
-C IMODE = 10 no sampling
-C
-C IMODE = -100+IMODE initialization according to
-C given limitations
-C
-C output: PTS sampled pt value
-C initialization:
-C BETA soft pt slope in central region
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( PI2 = 6.28318530718D0,
- & AMIN = 1.D-2,
- & EPS = 1.D-7,
- & DEPS = 1.D-30)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C average number of cut soft and hard ladders (obsolete)
- DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
- COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-
- DOUBLE PRECISION PHO_CONN0,PHO_CONN1
- EXTERNAL PHO_CONN0,PHO_CONN1
-
-C initialization
-
- IF(IMODE.LT.0) GOTO 100
-
- PX = PTHIGH
- PTS = 0.D0
-
-C initial checks
-
- IF(PX.LT.AMIN) RETURN
-
- IF((PX-PTLOW).LT.0.01) THEN
- IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
- & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
- RETURN
- ENDIF
-
-C sampling of pt values according to IMODE
-
- IF(IMODE.EQ.0) THEN
-
- FAC1 = EXP(-BETA*PX**2)
- FAC2 = (1.D0-FAC1)
- 25 CONTINUE
- XI1 = DT_RNDM(PX)*FAC2 + FAC1
- PTS = SQRT(-1.D0/BETA*LOG(XI1))
- IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
-
- ELSE IF(IMODE.EQ.1) THEN
-
- XIMIN = EXP(-BETA*PTHIGH)
- XIDEL = 1.D0-XIMIN
- 50 CONTINUE
- PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
- & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
- IF(PTS.LT.XMT) GOTO 50
- PTS = SQRT(PTS**2-XMT2)
- IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
-
- ELSE IF(IMODE.EQ.2) THEN
-
- IF(EE.GE.0.D0) THEN
- P2 = PVIRTP(1)
- ELSE
- P2 = PVIRTP(2)
- ENDIF
- XV = ABS(EE)
- AA = (1.D0-XV)*XV*P2+PARMDL(25)
- 75 CONTINUE
- PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
- IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
-
-C something wrong
-
- ELSE IF(IMODE.NE.10) THEN
- WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
- CALL PHO_ABORT
- ENDIF
-
-C debug output
- IF(IDEB(5).GE.20) THEN
- WRITE(LO,'(1X,A,I3,4E10.3)')
- & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
- & IMODE,BETA,PTLOW,PTHIGH,PTS
- ENDIF
- RETURN
-
-C initialization
- 100 CONTINUE
- PTSMIN = PTLOW
- PTSMAX = PTHIGH
- PTCON = PTHIGH
-C calculation of parameters
- INIT = IMODE+100
- AAS = 0.D0
-
-C initialization for model 0 (gaussian pt distribution)
-
- IF(INIT.EQ.0) THEN
- BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
- BETUP = BETAS(1)
- BETLO = -2.D0
- XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
- IF(XTOL.LT.0.D0) THEN
- XTOL = 1.D-4
- METHOD = 1
- MAXF = 500
- BETA = 0.D0
- BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
-* IF(BETA.LT.-1.D+10) THEN
-* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
-* & '(model 0: Ecm,PTcut)',EE,PTCON
-* WRITE(LO,'(1X,A,1P,3E10.3)')
-* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
-* CALL PHO_PREVNT(-1)
-* BETA = 0.01
-* ELSE
- AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
-* ENDIF
- ELSE
- AAS = 0.D0
- BETA = BETAS(1)
- ENDIF
-
-C initialization for model 1 (exponential pt distribution)
-
- ELSE IF(INIT.EQ.1) THEN
- XMT = PARMDL(43)
- XMT2 = XMT*XMT
- BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
- BETUP = BETAS(1)
- BETLO = -3.D0
- XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
- IF(XTOL.LT.0.D0) THEN
- XTOL = 1.D-4
- METHOD = 1
- MAXF = 500
- BETA = 0.D0
- BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
-* IF(BETA.LT.-1.D+10) THEN
-* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
-* & '(model 1: Ecm,PTcut)',EE,PTCON
-* WRITE(LO,'(1X,A,1P,3E10.3)')
-* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
-* CALL PHO_PREVNT(-1)
-* BETA = 0.01
-* ELSE
- AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
-* ENDIF
- ELSE
- AAS = 0.D0
- BETA = BETAS(1)
- ENDIF
- ELSE IF(INIT.EQ.10) THEN
- IF(IDEB(5).GT.10)
- & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
- RETURN
- ELSE
- WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
- & INIT
- CALL PHO_ABORT
- ENDIF
- BETA = MIN(BETA,BETAS(1))
-
-C hard cross section is too big: neg. beta parameter
- IF(BETA.LE.0.D0) THEN
- WRITE(LO,'(1X,A,1P,2E12.3)')
- & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
- WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
- & SIGS,DSIGHP,SIGH,PTCON
- CALL PHO_PREVNT(-1)
- ENDIF
-
-C output of initialization parameters
- IF(IDEB(5).GE.10) THEN
- WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
- & INIT
- WRITE(LO,'(5X,A,1P,2E13.3)')
- & 'BETA,AAS ',BETA,AAS
- WRITE(LO,'(5X,A,1P,3E13.3)')
- & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
- WRITE(LO,'(5X,A,1P,3E13.3)')
- & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
- ENDIF
-
- END
-
-CDECK ID>, PHO_CONN0
- DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
-C***********************************************************************
-C
-C auxiliary function to determine parameters of soft
-C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
-C
-C internal factors: FS number of soft partons in soft Pomeron
-C FH number of soft partons in hard Pomeron
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C average number of cut soft and hard ladders (obsolete)
- DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
- COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-
- DOUBLE PRECISION BETA,XX,FF
-
- XX = BETA*PTCON**2
- IF(ABS(XX).LT.1.D-3) THEN
- FF = FS*SIGS+FH*SIGH
- & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
- ELSE
- FF = FS*SIGS+FH*SIGH
- & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
- ENDIF
- PHO_CONN0 = FF
-
-* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
-* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
-
- END
-
-CDECK ID>, PHO_CONN1
- DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
-C***********************************************************************
-C
-C auxiliary function to determine parameters of soft
-C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
-C
-C internal factors: FS number of soft partons in soft Pomeron
-C FH number of soft partons in hard Pomeron
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C average number of cut soft and hard ladders (obsolete)
- DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
- COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-
- DOUBLE PRECISION BETA,XX,FF
-
- XX = BETA*PTCON
- IF(ABS(XX).LT.1.D-3) THEN
- FF = FS*SIGS+FH*SIGH
- & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
- ELSE
- FF = FS*SIGS+FH*SIGH
- & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
- ENDIF
- PHO_CONN1 = FF
-
-* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
-* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
-
- END
-
-CDECK ID>, PHO_MSHELL
- SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
-C********************************************************************
-C
-C rescaling of momenta of two partons to put both
-C on mass shell
-C
-C input: PA1,PA2 input momentum vectors
-C XM1,2 desired masses of particles afterwards
-C P1,P2 changed momentum vectors
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-20 )
-
- DIMENSION PA1(*),PA2(*),P1(*),P2(*)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- IREJ = 0
- IDEV = 0
-C debug output
- IF(IDEB(40).GE.10) THEN
- WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
- WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
- WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
- WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
- ENDIF
-
-C Lorentz transformation into system CMS
- PX = PA1(1)+PA2(1)
- PY = PA1(2)+PA2(2)
- PZ = PA1(3)+PA2(3)
- EE = PA1(4)+PA2(4)
- XMS = EE**2-PX**2-PY**2-PZ**2
- IF(XMS.LT.(XM1+XM2)**2) THEN
- IREJ = 1
- IFAIL(37) = IFAIL(37)+1
-
- if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
-
- IF(IDEB(40).GE.3) THEN
- WRITE(LO,'(/1X,A,I12)')
- & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
- WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
- & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
- WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
- IDEV = 5
- IF(IDEB(40).GE.3) GOTO 55
- ENDIF
- RETURN
- ENDIF
- XMS = SQRT(XMS)
- BGX = PX/XMS
- BGY = PY/XMS
- BGZ = PZ/XMS
- GAM = EE/XMS
- CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
- & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
-C rotation angles
- PTOT1 = MAX(DEPS,PTOT1)
- COD = P1(3)/PTOT1
- SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
- COF = 1.D0
- SIF = 0.D0
- IF(PTOT1*SID.GT.1.D-5) THEN
- COF = P1(1)/(SID*PTOT1)
- SIF = P1(2)/(SID*PTOT1)
- ANORF = SQRT(COF*COF+SIF*SIF)
- COF = COF/ANORF
- SIF = SIF/ANORF
- ENDIF
-
-C new CM momentum and energies (for masses XM1,XM2)
- XM12 = XM1**2
- XM22 = XM2**2
- SS = XMS**2
- PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
- EE1 = SQRT(XM12+PCMP**2)
- EE2 = XMS-EE1
-C back rotation
- CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
- CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
- & PTOT1,P1(1),P1(2),P1(3),P1(4))
- CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
- & PTOT2,P2(1),P2(2),P2(3),P2(4))
-
-C check consistency
- DEL = XMS*0.0001
- IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
- IDEV = 1
- ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
- IDEV = 2
- ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
- IDEV = 3
- ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
- IDEV = 4
- ENDIF
- 55 CONTINUE
-C debug output
- IF(IDEV.NE.0) THEN
- WRITE(LO,'(1X,A,I3)')
- & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
- WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
- WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
- WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
- WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
- WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
- WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
- WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
- ELSE IF(IDEB(40).GE.10) THEN
- WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
- WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
- WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
- ENDIF
- END
-
-CDECK ID>, PHO_GLU2QU
- SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
-C********************************************************************
-C
-C split gluon with index I in POEVT1
-C (massless gluon assumed)
-C
-C input: /POEVT1/
-C IG gluon index
-C IQ1 first quark index
-C IQ2 second quark index
-C
-C output: new quarks in /POEVT1/
-C IREJ 1 splitting impossible
-C 0 splitting successful
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-15,
- & EPS = 1.D-5 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- DIMENSION P1(4),P2(4)
- DATA CUTM /0.02D0/
-
- IREJ = 0
-
-C calculate string masses max possible
- IF(ISWMDL(9).EQ.1) THEN
- CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
- & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
- IF(CMASS1.LT.CUTM) THEN
- IF(IDEB(73).GE.5) THEN
- WRITE(LO,'(1X,A,3I4,4E10.3)')
- & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
- ENDIF
- IFAIL(33) = IFAIL(33) + 1
- IREJ = 1
- RETURN
- ENDIF
- CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
- & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
- IF(CMASS2.LT.CUTM) THEN
- IF(IDEB(73).GE.5) THEN
- WRITE(LO,'(1X,A,3I4,4E10.3)')
- & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
- ENDIF
- IFAIL(33) = IFAIL(33) + 1
- IREJ = 1
- RETURN
- ENDIF
-C
-C calculate minimal z
- ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
- ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
- ZMIN = MIN(ZMIN1,ZMIN2)
- IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
- IF(IDEB(73).GE.5) THEN
- WRITE(LO,'(1X,A,3I3,4E10.3)')
- & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
- & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
- ENDIF
- IFAIL(33) = IFAIL(33) + 1
- IREJ = 1
- RETURN
- ENDIF
- ELSE
- ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
- ENDIF
-C
- ZFRAC = PHO_GLUSPL(ZMIN)
- IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
- ZFRAC = 1.D0-ZFRAC
- ENDIF
- DO 200 I=1,4
- P1(I) = PHEP(I,IG)*ZFRAC
- P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
- 200 CONTINUE
-C quark flavours
- CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
- CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
- & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
- CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
-
- IF(ABS(IDHEP(IQ1)).GT.6) THEN
- K = SIGN(ABS(K),IDHEP(IQ1))
- ELSE
- K = -SIGN(ABS(K),IDHEP(IQ1))
- ENDIF
-C colors
- IF(K.GT.0) THEN
- IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
- IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
- ELSE
- IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
- IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
- ENDIF
-C register new partons
- CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
- & IPHIST(1,IG),0,IC1,0,IPOS,1)
- CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
- & IPHIST(1,IG),0,IC2,0,IPOS,1)
-C debug output
- IF(IDEB(73).GE.20) THEN
- WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
- & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
- & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
- WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
- & K,-K,IC1,IC2
- ENDIF
- END
-
-CDECK ID>, PHO_GLUSPL
- DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
-C*********************************************************************
-C
-C calculate quark - antiquark light cone momentum fractions
-C according to Altarelli-Parisi g->q aq splitting function
-C (symmetric z interval assumed)
-C
-C input: ZMIN minimal Z value allowed,
-C 1-ZMIN maximal Z value allowed
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( ALEXP= 0.3333333333D0,
- & DEPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
- IF(ZMIN.GE.0.5D0) THEN
- IF(IDEB(69).GT.2) THEN
- WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
- ENDIF
- ZZ=0.D0
- GOTO 1000
- ELSE IF(ZMIN.LE.0.D0) THEN
- IF(IDEB(69).GT.2) THEN
- WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
- ENDIF
- ZMINL = DEPS
- ELSE
- ZMINL = ZMIN
- ENDIF
-
- ZMAX = 1.D0-ZMINL
- XI = DT_RNDM(ZMAX)
- ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
- IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
-
- 1000 CONTINUE
- IF(IDEB(69).GE.10) THEN
- WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
- ENDIF
- PHO_GLUSPL = ZZ
- END
-
-CDECK ID>, PHO_STDPAR
- SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
-C***********************************************************************
-C
-C select the initial parton x-fractions and flavors and
-C the final parton momenta and flavours
-C for standard Pomeron/Reggeon cuts
-C
-C input: IJM1 index of mother particle 1 in /POEVT1/
-C IJM2 index of mother particle 2 in /POEVT1/
-C IGEN production process of mother particles
-C MSPOM soft cut Pomerons
-C MHPOM hard or semihard cut Pomerons
-C MSREG soft cut Reggeons
-C MHDIR direct hard processes
-C
-C IJM1 -1 initialization of statistics
-C -2 output of statistics
-C
-C output: partons are directly written to /POEVT1/,/POEVT2/
-C
-C structure of /POSOFT/
-C XS1(I),XS2(I): x-values of initial partons
-C IJSI1(I),IJSI2(I): flavor of initial parton
-C 0 gluon
-C 1,2,3,4 quarks
-C negative antiquarks
-C IJSF1(I),IJSF2(I): flavor of final state partons
-C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
-C J=1 PX
-C =2 PY
-C =3 PZ
-C =4 ENERGY
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (RHOMAS = 0.766D0,
- & DEPS = 1.D-10,
- & TINY = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C particles created by initial state evolution
- INTEGER MXISR1,MXISR2
- PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
- INTEGER IFLISR,IPOISR,IMXISR
- DOUBLE PRECISION PHISR
- COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
- & IPOISR(2,2,MXISR2),IMXISR(2)
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C internal cross check information on hard scattering limits
- DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
- COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
- double precision pho_alphas
-
- DIMENSION PC(4),IFLA(2),ICI(2,2)
-
- IF(IJM1.EQ.-1) THEN
- DO 116 I=1,15
- ETAMI(1,I) = 1.D10
- ETAMA(1,I) = -1.D10
- ETAMI(2,I) = 1.D10
- ETAMA(2,I) = -1.D10
- XXMI(1,I) = 1.D0
- XXMA(1,I) = 0.D0
- XXMI(2,I) = 1.D0
- XXMA(2,I) = 0.D0
- 116 CONTINUE
- CALL PHO_HARSCA(IJM1,1)
- CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
-
- RETURN
-
- ELSE IF(IJM1.EQ.-2) THEN
-
-C output internal statistics
- IF(IDEB(23).GE.1) THEN
- WRITE(LO,'(/1X,A)')
- & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
- DO 117 I=1,15
- WRITE(LO,'(5X,I3,4E13.5)')
- & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
- 117 CONTINUE
- WRITE(LO,'(1X,A)')
- & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
- DO 118 I=1,15
- WRITE(LO,'(5X,I3,4E13.5)')
- & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
- 118 CONTINUE
- ENDIF
- CALL PHO_HARSCA(IJM1,1)
- CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
-
- RETURN
- ENDIF
-
- IREJ = 0
-C debug output
- IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
- 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
-
-C get mother data (exchange if first particle is a pomeron)
- IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
- JM1 = IJM2
- JM2 = IJM1
- ELSE
- JM1 = IJM1
- JM2 = IJM2
- ENDIF
-
- NPOSP(1) = JM1
- NPOSP(2) = JM2
- IDPDG1 = IDHEP(JM1)
- IDBAM1 = IMPART(JM1)
- IDPDG2 = IDHEP(JM2)
- IDBAM2 = IMPART(JM2)
-
-C store current status of /POEVT1/
- KHPOMS = KHPOM
- KSPOMS = KSPOM
- KSREGS = KSREG
- KHDIRS = KHDIR
- NHEPS = NHEP
- IPOIS1 = IPOIX1
- IPOIS2 = IPOIX2
-
-C get nominal masses (photons: VDM assumption)
- DELMAS = 0.D0
- IF(IDHEP(JM1).EQ.22) THEN
- PMASSP(1) = RHOMAS+DELMAS
- PVIRTP(1) = PHEP(5,JM1)**2
- ELSE
- PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
- PVIRTP(1) = 0.D0
- ENDIF
- IF(IDHEP(JM2).EQ.22) THEN
- PMASSP(2) = RHOMAS+DELMAS
- PVIRTP(2) = PHEP(5,JM2)**2
- ELSE
- PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
- PVIRTP(2) = 0.D0
- ENDIF
-
-C calculate c.m. energy and check kinematics
- PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
- PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
- PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
- PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
- SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
-
- IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
- WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
- & 'energy smaller than two-particle threshold (event rejected)'
- CALL PHO_PREVNT(1)
- IREJ = 5
- GOTO 150
- ENDIF
- ECMP = SQRT(SS)
-
- IF(IDEB(23).GE.5) THEN
- WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
- & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
- IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
- ENDIF
-
-C Lorentz transformation into c.m. system
- DO 10 I=1,4
- GAMBEP(I) = PC(I)/ECMP
- 10 CONTINUE
- CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
- & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
- & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
-C rotation angle: particle 1 moves along +z
- CODP = PC(3)/PTOT1
- SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
- COFP = 1.D0
- SIFP = 0.D0
- IF(PTOT1*SIDP.GT.1.D-5) THEN
- COFP = PC(1)/(SIDP*PTOT1)
- SIFP = PC(2)/(SIDP*PTOT1)
- ANORF = SQRT(COFP*COFP+SIFP*SIFP)
- COFP = COFP/ANORF
- SIFP = SIFP/ANORF
- ENDIF
-C get CM momentum
- XM12 = PMASSP(1)**2
- XM22 = PMASSP(2)**2
- PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
-
-C find particle combination
- II = 0
- IF(IDPDG2.EQ.IFPAP(2)) THEN
- IF(IDPDG1.EQ.IFPAP(1)) II = 1
- ELSE IF(IDPDG2.EQ.990) THEN
- IF(IDPDG1.EQ.IFPAP(1)) THEN
- II = 2
- ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
- II = 3
- ELSE IF(IDPDG1.EQ.990) THEN
- II = 4
- ENDIF
- ENDIF
- IF(II.EQ.0) THEN
- IF(ISWMDL(14).GT.0) THEN
- II = 1
- ELSE
- WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
- & 'invalid particle combination:',IDPDG1,IDPDG2
- CALL PHO_ABORT
- ENDIF
- ENDIF
-
-C select parton distribution functions from tables
- IF((MHPOM+MHDIR).GT.0) THEN
- CALL PHO_ACTPDF(IDPDG1,1)
- CALL PHO_ACTPDF(IDPDG2,2)
-C initialize alpha_s calculation
- DUMMY = PHO_ALPHAS(0.D0,-4)
- ENDIF
-
-C interpolate hard cross sections and rejection weights
- CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
- & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
-
- NTRY = 10
-
-C position of first particle added to /POEVT2/
- NLOR1 = NHEP+1
-
-C ---------------- direct processes -----------------
-
- IF(MHDIR.EQ.1) THEN
- CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
- IF(IREJ.EQ.50) RETURN
- IF(IREJ.NE.0) GOTO 150
-C write comments to /POEVT1/
- CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
- & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
- & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
- CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
- & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
- & ICA1,ICA2,IPOS,1)
- CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
- & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
- & ICA1,ICA2,IPOS,1)
- CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
- & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
- & IPOS1,1)
- CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
- & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
- & IPOS2,1)
-
-C soft spectator partons
- ICA1 = 0
- ICA2 = 0
- ICB1 = 0
- ICB2 = 0
- IPDF1 = 0
- IPDF2 = 0
-
-C single resolved: QCD compton scattering
-C ------------------------------
- IF(NPROHD(1).EQ.10) THEN
-C register hadron remnant
- CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
- IPDF2 = 1000*IGRP(2)+ISET(2)
- ELSE IF(NPROHD(1).EQ.12) THEN
-C register hadron remnant
- CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
- IPDF1 = 1000*IGRP(1)+ISET(1)
-
-C single resolved: photon gluon fusion
-C ---------------------------
- ELSE IF(NPROHD(1).EQ.11) THEN
-C register hadron remnant
- CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
- IPDF2 = 1000*IGRP(2)+ISET(2)
- ELSE IF(NPROHD(1).EQ.13) THEN
-C register hadron remnant
- CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
- IPDF1 = 1000*IGRP(1)+ISET(1)
-
-C direct process (no remnant)
-C ----------------------------
- ELSE IF(NPROHD(1).EQ.14) THEN
-
- ENDIF
-
-C write final high-pt partons to POEVT1
- IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
- ICI(1,1) = ICA1
- ICI(1,2) = ICA2
- ICI(2,1) = ICB1
- ICI(2,2) = ICB2
- I = 1
- IFLA(1) = NINHD(I,1)
- IFLA(2) = NINHD(I,2)
-C initial state radiation
- DO 130 K=1,2
- DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
- KK = 1
- 137 CONTINUE
- IFLB = IFLISR(K,IPA)
- IF(ABS(IFLB).LE.6) THEN
-C partons
- IF(ICI(K,1)*ICI(K,2).NE.0) THEN
- IF(IFLB.EQ.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),3)
- ELSE IF(IFLB.GT.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),4)
- ELSE
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
- & IC1,IC2,4)
- ENDIF
- ELSE
- IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
- IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
- CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
- KK = KK+1
- GOTO 137
- ENDIF
- ENDIF
- IF(IFLB.EQ.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
- & IC1,IC2,2)
- ELSE
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),2)
- ENDIF
- ENDIF
- IIFL = IPHO_CNV1(IFLB)
-
- IFLA(K) = IFLA(K)-IFLB
- IST = -1
- ELSE
-C other particle
- IIFL = IFLB
- IC1 = 0
- IC2 = 0
- IST = 1
- ENDIF
- CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
- & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
- & IGEN,IC1,IC2,IPOS,1)
- 135 CONTINUE
- 130 CONTINUE
- ICOLOR(1,IPOS1-2) = ICI(1,1)
- ICOLOR(2,IPOS1-2) = ICI(1,2)
- ICOLOR(1,IPOS1-1) = ICI(2,1)
- ICOLOR(2,IPOS1-1) = ICI(2,2)
- CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
- & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
- & NOUTHD(I,2),ICI(2,1),ICI(2,2))
- ICOLOR(1,IPOS1) = ICI(1,1)
- ICOLOR(2,IPOS1) = ICI(1,2)
- ICOLOR(1,IPOS2) = ICI(2,1)
- ICOLOR(2,IPOS2) = ICI(2,2)
- DO 140 K=1,2
- IPA = IPOISR(K,1,I)
- CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
- & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
- & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
- 140 CONTINUE
- ELSE
- ICOLOR(1,IPOS1-2) = ICA1
- ICOLOR(2,IPOS1-2) = ICA2
- ICOLOR(1,IPOS1-1) = ICB1
- ICOLOR(2,IPOS1-1) = ICB2
- CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
- & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
- & NOUTHD(1,2),ICB1,ICB2)
- ICOLOR(1,IPOS1) = ICA1
- ICOLOR(2,IPOS1) = ICA2
- ICOLOR(1,IPOS2) = ICB1
- ICOLOR(2,IPOS2) = ICB2
- I = -1
- IF(ABS(NOUTHD(1,1)).GT.12) I = 1
- CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
- & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
- CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
- & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
- ENDIF
-
-C assign soft pt to spectators
- IF(ISWMDL(18).EQ.0) THEN
- IPOS2 = IPOS2-1
- CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(26) = IFAIL(26) + 1
- GOTO 150
- ENDIF
-
- ENDIF
-
-C ----------------- resolved processes -------------------
-
-C single Reggeon exchange
-C ----------------------------
- ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
-C flavours
- CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(24) = IFAIL(24)+1
- GOTO 150
- ENDIF
-
-C colors
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
- & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
- CALL PHO_SWAPI(ICA1,ICB1)
- ENDIF
- ECMH = ECMP/2.D0
-
-C registration
-
-C DPMJET call with special projectile / target
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
- & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
- & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
-C default treatment
- ELSE
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
- & -1,IGEN,ICA1,0,IPOS1,1)
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
- & -1,IGEN,ICB1,0,IPOS2,1)
- ENDIF
-
-C soft pt assignment
- IF(ISWMDL(18).EQ.0) THEN
- CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(25) = IFAIL(25) + 1
- GOTO 150
- ENDIF
- ENDIF
-C
-C multi Reggeon / Pomeron exchange
-C----------------------------------------
- ELSE
-C parton configuration
-
- CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
- & MHPAR1,MHPAR2,IREJ)
-
- IF(IREJ.EQ.50) RETURN
- IF(IREJ.NE.0) GOTO 150
-
-C register particles
- IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
- & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
- & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
-
-C register soft partons
- IF(IVAL1.NE.0) THEN
- IF(IVAL1.LT.0) THEN
- IND1 = 3
- IVAL1=-IVAL1
- ELSE
- IND1 = 2
- ENDIF
- ELSE IF(MSPOM.EQ.0) THEN
- IND1 = 4
- ELSE
- IND1 = 1
- ENDIF
- IF(IVAL2.NE.0) THEN
- IF(IVAL2.LT.0) THEN
- IND2 = 3
- IVAL2=-IVAL2
- ELSE
- IND2 = 2
- ENDIF
- ELSE IF(MSPOM.EQ.0) THEN
- IND2 = 4
- ELSE
- IND2 = 1
- ENDIF
-
- IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
- & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
-
-C soft Pomeron final states
-C -----------------------------------
- K = MSPOM+MHPOM+MSREG
- DO 50 I=1,MSPOM
-
- CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(8) = IFAIL(8) + 1
- GOTO 150
- ENDIF
-C
- 50 CONTINUE
-
-C soft Reggeon final states
-C -----------------------------------------
- DO 75 I=1,MSREG
-C flavours
- CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
- IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
- CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
- ELSE
- CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
- ENDIF
-
-C colors
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
- & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
- & CALL PHO_SWAPI(ICA1,ICB1)
-C registration
- CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
- & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
- & I,IGEN,ICA1,ICA2,IPOS1,1)
- IND1 = IND1+1
- CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
- & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
- & I,IGEN,ICB1,ICB2,IPOS2,1)
- IND2 = IND2+1
-
- IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
- & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
- & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
-
-C soft pt assignment
- IF(ISWMDL(18).EQ.0) THEN
- CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(25) = IFAIL(25) + 1
- GOTO 150
- ENDIF
- ENDIF
-
- 75 CONTINUE
-
-C hard Pomeron final states
-C ------------------------------------
- IND1 = MSPAR1
- IND2 = MSPAR2
-
- DO 100 L=1,MHPOM
- I = LSIDX(L)
-
- IFLI1 = IPHO_CNV1(N0INHD(I,1))
- IFLI2 = IPHO_CNV1(N0INHD(I,2))
- IFLO1 = IPHO_CNV1(NOUTHD(I,1))
- IFLO2 = IPHO_CNV1(NOUTHD(I,2))
-
-C write comments to /POEVT1/
- CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
- & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
- & IFLO1,IFLO2,IPOS,1)
- I1 = 8*I-7
- IPDF = 1000*IGRP(1)+ISET(1)
- CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
- & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
- & ICA1,ICA2,IPOS,1)
- IPDF = 1000*IGRP(2)+ISET(2)
- CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
- & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
- & ICB1,ICB2,IPOS,1)
- I1 = 8*I-3
- IPDF = 1000*IGRP(1)+ISET(1)
- CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
- & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
- & ICA1,ICA2,IPOS1,1)
- IPDF = 1000*IGRP(2)+ISET(2)
- CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
- & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
- & ICB1,ICB2,IPOS2,1)
-
-C spectator partons belonging to hard interaction
- IF(IVAL1.EQ.I) THEN
- IVQ = 1
- IND = 1
- ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
- IVQ = 0
- IND = 1
- ELSE
- IVQ = -1
- IND = IND1
- ENDIF
- CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
- IF(IVQ.LT.0) IND1 = IND1-IUSED
- IF(IVAL2.EQ.I) THEN
- IVQ = 1
- IND = 1
- ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
- IVQ = 0
- IND = 1
- ELSE
- IVQ = -1
- IND = IND2
- ENDIF
- CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
- IF(IVQ.LT.0) IND2 = IND2-IUSED
-C
-C register hard scattered partons
- IF((ISWMDL(8).GE.2)
- & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
- ICI(1,1) = ICA1
- ICI(1,2) = ICA2
- ICI(2,1) = ICB1
- ICI(2,2) = ICB2
- IFLA(1) = NINHD(I,1)
- IFLA(2) = NINHD(I,2)
-C initial state radiation
- DO 230 K=1,2
- DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
- KK = 1
- 237 CONTINUE
- IFLB = IFLISR(K,IPA)
- IF(ABS(IFLB).LE.6) THEN
-C partons
- IF(ICI(K,1)*ICI(K,2).NE.0) THEN
- IF(IFLB.EQ.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),3)
- ELSE IF(IFLB.GT.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),4)
- ELSE
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
- & ICI(K,2),IC1,IC2,4)
- ENDIF
- ELSE
- IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
- IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
- CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
- KK = KK+1
- GOTO 237
- ENDIF
- ENDIF
- IF(IFLB.EQ.0) THEN
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
- & ICI(K,2),IC1,IC2,2)
- ELSE
- CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
- & ICI(K,1),ICI(K,2),2)
- ENDIF
- ENDIF
- IIFL = IPHO_CNV1(IFLB)
-
- IFLA(K) = IFLA(K)-IFLB
- IST = -1
- ELSE
-C other particles
- IIFL = IFLB
- IC1 = 0
- IC2 = 0
- IST = 1
- ENDIF
- CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
- & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
- & L*100+K,IGEN,IC1,IC2,IPOS,1)
- 235 CONTINUE
- 230 CONTINUE
- ICOLOR(1,IPOS1-2) = ICI(1,1)
- ICOLOR(2,IPOS1-2) = ICI(1,2)
- ICOLOR(1,IPOS1-1) = ICI(2,1)
- ICOLOR(2,IPOS1-1) = ICI(2,2)
- CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
- & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
- & NOUTHD(I,2),ICI(2,1),ICI(2,2))
- ICOLOR(1,IPOS1) = ICI(1,1)
- ICOLOR(2,IPOS1) = ICI(1,2)
- ICOLOR(1,IPOS2) = ICI(2,1)
- ICOLOR(2,IPOS2) = ICI(2,2)
- DO 240 K=1,2
- IPA = IPOISR(K,1,I)
- CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
- & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
- & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
- 240 CONTINUE
- ELSE
- ICOLOR(1,IPOS1-2) = ICA1
- ICOLOR(2,IPOS1-2) = ICA2
- ICOLOR(1,IPOS1-1) = ICB1
- ICOLOR(2,IPOS1-1) = ICB2
- CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
- & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
- & NOUTHD(I,2),ICB1,ICB2)
- ICOLOR(1,IPOS1) = ICA1
- ICOLOR(2,IPOS1) = ICA2
- ICOLOR(1,IPOS2) = ICB1
- ICOLOR(2,IPOS2) = ICB2
- I1 = 8*I-3
- CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
- & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
- & ICA1,ICA2,IPOS,1)
- CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
- & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
- & ICB1,ICB2,IPOS,1)
- ENDIF
- 100 CONTINUE
-C end of resolved parton registration
- ENDIF
-
- IF(MHDIR+MHPOM.GT.0) THEN
-
- IF(ISWMDL(29).GE.1) THEN
-C primordial kt of hard scattering
- CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(27) = IFAIL(27)+1
- GOTO 150
- ENDIF
- ELSE IF(ISWMDL(24).GE.0) THEN
-C give "soft" pt only to soft (spectator) partons in hard processes
- CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(26) = IFAIL(26)+1
- GOTO 150
- ENDIF
- ENDIF
-
- ENDIF
-
-C give "soft" pt to partons in soft Pomerons
- IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
- CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(25) = IFAIL(25) + 1
- GOTO 150
- ENDIF
- ENDIF
-
-C boost back to lab frame
- CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
- & GAMBEP(1),GAMBEP(2),GAMBEP(3))
- RETURN
-
-C rejection treatment
- 150 CONTINUE
- IFAIL(2) = IFAIL(2)+1
-C reset counters
- KSPOM = KSPOMS
- KHPOM = KHPOMS
- KHDIR = KHDIRS
- KSREG = KSREGS
-C reset mother-daugther relations
- JDAHEP(1,JM1) = 0
- JDAHEP(2,JM1) = 0
- JDAHEP(1,JM2) = 0
- JDAHEP(2,JM2) = 0
- ISTHEP(JM1) = 1
- ISTHEP(JM2) = 1
- IPOIX1 = IPOIS1
- IPOIX2 = IPOIS2
- NHEP = NHEPS
-C debug
- IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
- & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
- & MSPOM,MHPOM,MSREG,MHDIR
- RETURN
-
- END
-
-CDECK ID>, PHO_HARCOL
- SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
- & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
-C*********************************************************************
-C
-C calculate color flow for hard resolved process
-C
-C input: IP1..4 flavour of partons (PDG convention)
-C V parton subprocess Mandelstam variable V = t/s
-C (lightcone momenta assumed)
-C ICA,ICB color labels
-C MSPR process number
-C -1 initialization of statistics
-C -2 output of statistics
-C
-C output: ICC,ICD color label of final partons
-C
-C (it is possible to use the same variables for in and output)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-
- DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
-
-C initialization
- IF(MSPR.EQ.-1) THEN
- DO 200 I=1,8
- DO 210 K=1,5
- ICONF(I,K) = 0
- 210 CONTINUE
- IRECN(I,1) = 0
- IRECN(I,2) = 0
- 200 CONTINUE
- RETURN
-C output of statistics
- ELSE IF(MSPR.EQ.-2) THEN
- IF(IDEB(26).LT.1) RETURN
- WRITE(LO,'(/1X,A,/1X,A)')
- & 'PHO_HARCOL: sampled color configurations',
- & '----------------------------------------'
- WRITE(LO,'(6X,A,15X,A)')
- & 'diagram color configurations (1-4)','sum'
- DO 300 I=1,8
- DO 310 K=1,4
- ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
- 310 CONTINUE
- WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
- 300 CONTINUE
- IF(ISWMDL(11).GE.2) THEN
- WRITE(LO,'(/6X,A)')
- & 'diagram with / without color re-connection'
- DO 320 I=1,8
- WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
- 320 CONTINUE
- ENDIF
- RETURN
- ENDIF
-C
-C gluons: first color positive, quarks second color zero
- IF(IP1.EQ.0) THEN
- IF(ICA1.LT.0) THEN
- I = ICA2
- ICA2 = ICA1
- ICA1 = I
- ENDIF
- ELSE
- ICA2 = 0
- ENDIF
- IF(IP2.EQ.0) THEN
- IF(ICB1.LT.0) THEN
- I = ICB2
- ICB2 = ICB1
- ICB1 = I
- ENDIF
- ELSE
- ICB2 = 0
- ENDIF
- IC2 = 0
- IC4 = 0
-C debug output
- IF(IDEB(26).GE.15)
- & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
- & 'PHO_HARCOL: process',MSPR,
- & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
-C
- IRC = 0
- IF(IPAMDL(21).EQ.1) THEN
-C
-C soft color re-connection option
-C
- IF(MSPR.EQ.1) THEN
-C hard g g final state, only g g --> g g
- IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
- IF(DT_RNDM(V).LT.PARMDL(140)) THEN
- IC1 = ICA1
- IC2 = ICA2
- IC3 = ICB1
- IC4 = ICB2
- IRECN(MSPR,1) = IRECN(MSPR,1)+1
- IRC = 1
- GOTO 100
- ENDIF
- ENDIF
- ELSE IF(MSPR.EQ.3) THEN
-C hard q g final state
- IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
- IF(DT_RNDM(V).LT.PARMDL(141)) THEN
- IC1 = ICA1
- IC2 = ICA2
- IC3 = ICB1
- IC4 = ICB2
- IRECN(MSPR,1) = IRECN(MSPR,1)+1
- IRC = 1
- GOTO 100
- ENDIF
- ENDIF
- ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
-C hard q q final state
- IF(ICA1.NE.-ICB1) THEN
- IF(DT_RNDM(V).LT.PARMDL(142)) THEN
- IC1 = ICA1
- IC2 = ICA2
- IC3 = ICB1
- IC4 = ICB2
- IRECN(MSPR,1) = IRECN(MSPR,1)+1
- IRC = 1
- GOTO 100
- ENDIF
- ENDIF
- ENDIF
- IRECN(MSPR,2) = IRECN(MSPR,2)+1
- ENDIF
-C
- IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
-C
-C large Nc limit of all graphs
-C
- IF(MSPR.EQ.1) THEN
-C g g --> g g
- IF(DT_RNDM(V).GT.0.5D0) THEN
- IC1 = ICB1
- IC2 = ICA2
- IC3 = ICA1
- IC4 = ICB2
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = ICA1
- IC2 = ICB2
- IC3 = ICB1
- IC4 = ICA2
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.2) THEN
-C q qb --> g g
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(ICA1.LT.0) THEN
- IC1 = I1
- IC2 = ICA1
- IC3 = ICB1
- IC4 = I2
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ELSE
- IC1 = ICA1
- IC2 = I2
- IC3 = I1
- IC4 = ICB1
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ENDIF
- ELSE IF(MSPR.EQ.3) THEN
-C q g --> q g
- IF(DT_RNDM(V).LT.0.5D0) THEN
- IF(IP1+IP2.GT.0) THEN
- IC1 = ICB1
- IC2 = ICA2
- IC3 = ICA1
- IC4 = ICB2
- ELSE IF(IP1.LT.0) THEN
- IC1 = ICB2
- IC3 = ICB1
- IC4 = ICA1
- ELSE
- IC1 = ICA1
- IC2 = ICB1
- IC3 = ICA2
- ENDIF
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IF(IP1.GT.0) THEN
- CALL PHO_HARCOR(-ICA1,ICB2)
- IC1 = ICA1
- IC3 = ICB1
- IC4 = -ICA1
- ELSE IF(IP2.GT.0) THEN
- CALL PHO_HARCOR(-ICB1,ICA2)
- IC1 = ICA1
- IC2 = -ICB1
- IC3 = ICB1
- ELSE IF(IP1.LT.0) THEN
- CALL PHO_HARCOR(-ICA1,ICB1)
- IC1 = ICA1
- IC3 = -ICA1
- IC4 = ICB2
- ELSE IF(IP2.LT.0) THEN
- CALL PHO_HARCOR(-ICB1,ICA1)
- IC1 = -ICB1
- IC2 = ICA2
- IC3 = ICB1
- ENDIF
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.4) THEN
-C g g --> q qb
- IC1 = ICA1
- IC3 = ICB2
- CALL PHO_HARCOR(-ICB1,ICA2)
- IF(ICB2.EQ.-ICB1) IC3 = ICA2
- IF(IP3*IC1.LT.0) THEN
- I = IC1
- IC1 = IC3
- IC3 = I
- ENDIF
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ELSE IF(MSPR.EQ.5) THEN
-C q qb --> q qb
- IF(DT_RNDM(V).LT.0.5D0) THEN
- IF(ICA1*IP3.LT.0) THEN
- IC1 = ICB1
- IC3 = ICA1
- ELSE
- IC1 = ICA1
- IC3 = ICB1
- ENDIF
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IF(ICA1*IP3.LT.0) THEN
- IC1 = -ICA1
- IC3 = ICA1
- ELSE
- IC1 = ICA1
- IC3 = -ICA1
- ENDIF
- CALL PHO_HARCOR(-ICA1,ICB1)
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.6) THEN
-C q qb --> qp qbp
- IF(ICA1*IP3.LT.0) THEN
- IC1 = ICB1
- IC3 = ICA1
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = ICA1
- IC3 = ICB1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.7) THEN
-C q q --> q q
- IF(DT_RNDM(V).LT.0.5D0) THEN
- IC1 = ICA1
- IC3 = ICB1
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = ICB1
- IC3 = ICA1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.8) THEN
-C q qp --> q qp
- IF(IP1*IP2.GT.0) THEN
- IF(IP3.EQ.IP1) THEN
- IC1 = ICB1
- IC3 = ICA1
- ELSE
- IC1 = ICA1
- IC3 = ICB1
- ENDIF
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IF(ICA1*IP3.LT.0) THEN
- IC1 = -ICA1
- IC3 = ICA1
- ELSE
- IC1 = ICA1
- IC3 = -ICA1
- ENDIF
- CALL PHO_HARCOR(-ICA1,ICB1)
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
-C unknown process
- WRITE(LO,'(/1X,A,I3)')
- & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
- CALL PHO_ABORT
- ENDIF
-C
- ELSE
-C
-C color flow according to QCD leading order matrix element
-C
- U = -(1.D0+V)
- IF(MSPR.EQ.1) THEN
-C g g --> g g
- PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
- PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
- PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
- XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
- PCS = 0.D0
- DO 110 I=1,3
- PCS = PCS+PC(I)
- IF(XI.LT.PCS) GOTO 120
- 110 CONTINUE
- 120 CONTINUE
- IF(I.EQ.1) THEN
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(DT_RNDM(V).GT.0.5D0) THEN
- IC1 = I1
- IC2 = ICA2
- IC3 = ICB1
- IC4 = I2
- CALL PHO_HARCOR(-ICB2,ICA1)
- IF(ICB1.EQ.-ICB2) IC3 = ICA1
- ELSE
- IC1 = ICA1
- IC2 = I2
- IC3 = I1
- IC4 = ICB2
- CALL PHO_HARCOR(-ICB1,ICA2)
- IF(ICB2.EQ.-ICB1) IC4 = ICA2
- ENDIF
- ELSE IF(I.EQ.2) THEN
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(DT_RNDM(U).GT.0.5D0) THEN
- IC1 = ICB1
- IC2 = I2
- IC3 = I1
- IC4 = ICA2
- CALL PHO_HARCOR(-ICB2,ICA1)
- IF(ICB1.EQ.-ICB2) IC1 = ICA1
- ELSE
- IC1 = I1
- IC2 = ICB2
- IC3 = ICA1
- IC4 = I2
- CALL PHO_HARCOR(-ICB1,ICA2)
- IF(ICB2.EQ.-ICB1) IC2 = ICA2
- ENDIF
- ELSE
- IF(DT_RNDM(V).GT.0.5D0) THEN
- IC1 = ICB1
- IC2 = ICA2
- IC3 = ICA1
- IC4 = ICB2
- ELSE
- IC1 = ICA1
- IC2 = ICB2
- IC3 = ICB1
- IC4 = ICA2
- ENDIF
- ENDIF
- ICONF(MSPR,I) = ICONF(MSPR,I)+1
- ELSE IF(MSPR.EQ.2) THEN
-C q qb --> g g
- PC(1) = U/V-2.D0*U**2
- PC(2) = V/U-2.D0*V**2
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- XI = (PC(1)+PC(2))*DT_RNDM(U)
- IF(XI.LT.PC(1)) THEN
- IF(ICA1.GT.0) THEN
- IC1 = ICA1
- IC2 = I2
- IC3 = I1
- IC4 = ICB1
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = I1
- IC2 = ICA1
- IC3 = ICB1
- IC4 = I2
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
- IF(ICA1.GT.0) THEN
- IC1 = I1
- IC2 = ICB1
- IC3 = ICA1
- IC4 = I2
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ELSE
- IC1 = ICB1
- IC2 = I2
- IC3 = I1
- IC4 = ICA1
- ICONF(MSPR,4) = ICONF(MSPR,4)+1
- ENDIF
- ENDIF
- ELSE IF(MSPR.EQ.3) THEN
-C q g --> q g
- PC(1) = 2.D0*(U/V)**2-U
- PC(2) = 2.D0/V**2-1.D0/U
- XI = (PC(1)+PC(2))*DT_RNDM(V)
- IF(XI.LT.PC(1)) THEN
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(IP1.GT.0) THEN
- IC1 = I1
- IC3 = ICB1
- IC4 = I2
- CALL PHO_HARCOR(-ICA1,ICB2)
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE IF(IP1.LT.0) THEN
- IC1 = I2
- IC3 = I1
- IC4 = ICB2
- CALL PHO_HARCOR(-ICA1,ICB1)
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE IF(IP2.GT.0) THEN
- IC1 = ICA1
- IC2 = I2
- IC3 = I1
- CALL PHO_HARCOR(-ICB1,ICA2)
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ELSE
- IC1 = I1
- IC2 = ICA2
- IC3 = I2
- CALL PHO_HARCOR(-ICB1,ICA1)
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
- IF(IP1.GT.0) THEN
- IC1 = ICB1
- IC3 = ICA1
- IC4 = ICB2
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ELSE IF(IP1.LT.0) THEN
- IC1 = ICB2
- IC3 = ICB1
- IC4 = ICA1
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ELSE IF(IP2.GT.0) THEN
- IC1 = ICB1
- IC2 = ICA2
- IC3 = ICA1
- ICONF(MSPR,4) = ICONF(MSPR,4)+1
- ELSE
- IC1 = ICA1
- IC2 = ICB1
- IC3 = ICA2
- ICONF(MSPR,4) = ICONF(MSPR,4)+1
- ENDIF
- ENDIF
- ELSE IF(MSPR.EQ.4) THEN
-C g g --> q qb
- PC(1) = U/V-2.D0*U**2
- PC(2) = V/U-2.D0*V**2
- XI = (PC(1)+PC(2))*DT_RNDM(U)
- IF(XI.LT.PC(1)) THEN
- IF(IP3.GT.0) THEN
- IC1 = ICA1
- IC3 = ICB2
- CALL PHO_HARCOR(-ICB1,ICA2)
- IF(ICB2.EQ.-ICB1) IC3 = ICA2
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = ICA2
- IC3 = ICB1
- CALL PHO_HARCOR(-ICB2,ICA1)
- IF(ICB1.EQ.-ICB2) IC3 = ICA1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
- IF(IP3.GT.0) THEN
- IC1 = ICB1
- IC3 = ICA2
- CALL PHO_HARCOR(-ICB2,ICA1)
- IF(ICB1.EQ.-ICB2) IC1 = ICA1
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ELSE
- IC1 = ICB2
- IC3 = ICA1
- CALL PHO_HARCOR(-ICB1,ICA2)
- IF(ICB2.EQ.-ICB1) IC1 = ICA2
- ICONF(MSPR,4) = ICONF(MSPR,4)+1
- ENDIF
- ENDIF
- ELSE IF(MSPR.EQ.5) THEN
-C q qb --> q qb
- PC(1) = (1.D0+U**2)/V**2
- PC(2) = (V**2+U**2)
- XI = (PC(1)+PC(2))*DT_RNDM(V)
- IF(XI.LT.PC(1)) THEN
- CALL PHO_HARCOR(-ICB1,ICA1)
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(IP3.GT.0) THEN
- IC1 = I1
- IC3 = I2
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = I2
- IC3 = I1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
- IF(IP3.GT.0) THEN
- IC1 = MAX(ICA1,ICB1)
- IC3 = MIN(ICA1,ICB1)
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ELSE
- IC1 = MIN(ICA1,ICB1)
- IC3 = MAX(ICA1,ICB1)
- ICONF(MSPR,4) = ICONF(MSPR,4)+1
- ENDIF
- ENDIF
- ELSE IF(MSPR.EQ.6) THEN
-C q qb --> qp qpb
- IF(IP3.GT.0) THEN
- IC1 = MAX(ICA1,ICB1)
- IC3 = MIN(ICA1,ICB1)
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = MIN(ICA1,ICB1)
- IC3 = MAX(ICA1,ICB1)
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.7) THEN
-C q q --> q q
- PC(1) = (1.D0+U**2)/V**2
- PC(2) = (1.D0+V**2)/U**2
- XI = (PC(1)+PC(2))*DT_RNDM(U)
- IF(XI.LT.PC(1)) THEN
- IC1 = ICB1
- IC3 = ICA1
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = ICA1
- IC3 = ICB1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE IF(MSPR.EQ.8) THEN
-C q qp --> q qp
- IF(IP1*IP2.LT.0) THEN
- CALL PHO_HARCOR(-ICB1,ICA1)
- CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
- IF(IP1.GT.0) THEN
- IC1 = I1
- IC3 = I2
- ICONF(MSPR,1) = ICONF(MSPR,1)+1
- ELSE
- IC1 = I2
- IC3 = I1
- ICONF(MSPR,2) = ICONF(MSPR,2)+1
- ENDIF
- ELSE
- IC1 = ICB1
- IC3 = ICA1
- ICONF(MSPR,3) = ICONF(MSPR,3)+1
- ENDIF
-
- ELSE IF(MSPR.EQ.10) THEN
-C gam q --> q g
- CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
- IF(IP3.EQ.0) THEN
- CALL PHO_SWAPI(IC1,IC3)
- CALL PHO_SWAPI(IC2,IC4)
- ENDIF
- ELSE IF(MSPR.EQ.11) THEN
-C gam g --> q q
- IC1 = ICB1
- IC3 = ICB2
- IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
- ELSE IF(MSPR.EQ.12) THEN
-C q gam --> q g
- CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
- IF(IP3.EQ.0) THEN
- CALL PHO_SWAPI(IC1,IC3)
- CALL PHO_SWAPI(IC2,IC4)
- ENDIF
- ELSE IF(MSPR.EQ.13) THEN
-C g gam --> q q
- IC1 = ICA1
- IC3 = ICA2
- IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
- ELSE IF(MSPR.EQ.14) THEN
- IF(ABS(IP3).GT.12) THEN
- IC1 = 0
- IC3 = 0
- ELSE
- CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
- IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
- ENDIF
- ELSE
-C unknown process
- WRITE(LO,'(/1X,A,I3)')
- & 'PHO_HARCOL:ERROR:invalid process number',MSPR
- CALL PHO_ABORT
- ENDIF
- ENDIF
-C
- 100 CONTINUE
-C debug output
- IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
- & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
-C color connection?
-* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
-* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
-* & .OR.(IC2.EQ.0))) THEN
-C color exchange?
-* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
-* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
-* IF(IRC.NE.1) THEN
-* WRITE(LO,'(1X,A,I10,I3)')
-* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
-* WRITE(LO,'(5X,A,3I5,2X,3I5)')
-* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
-* WRITE(LO,'(5X,A,3I5,2X,3I5)')
-* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
-* ENDIF
-* IRC = 0
-* ENDIF
-* ENDIF
-* IF(IRC.EQ.1) THEN
-* WRITE(LO,'(1X,A,I10,I3)')
-* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
-* WRITE(LO,'(5X,A,3I5,2X,3I5)')
-* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
-* WRITE(LO,'(5X,A,3I5,2X,3I5)')
-* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
-* ENDIF
-C
- ICC1 = IC1
- ICC2 = IC2
- ICD1 = IC3
- ICD2 = IC4
-
- END
-
-CDECK ID>, PHO_HARCOR
- SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
-C***********************************************************************
-C
-C substituite color in /POEVT2/
-C
-C input: ICOLD old color
-C ICNEW new color
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DO 100 I=NHEP,3,-1
- IF(ISTHEP(I).EQ.-1) THEN
- IF(ICOLOR(1,I).EQ.ICOLD) THEN
- ICOLOR(1,I) = ICNEW
- RETURN
- ELSE IF(IDHEP(I).EQ.21) THEN
- IF(ICOLOR(2,I).EQ.ICOLD) THEN
- ICOLOR(2,I) = ICNEW
- RETURN
- ENDIF
- ENDIF
-* ELSE IF(ISTHEP(I).EQ.20) THEN
-* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
-* print LO,' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
-* ICOLOR(1,I) = -ICNEW
-* RETURN
-* ELSE IF(IDHEP(I).EQ.21) THEN
-* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
-* print LO,' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
-* ICOLOR(2,I) = -ICNEW
-* RETURN
-* ENDIF
-* ENDIF
- ENDIF
- 100 CONTINUE
- END
-
-CDECK ID>, PHO_HARREM
- SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
- & IUSED,IREJ)
-C***********************************************************************
-C
-C sample color structure for initial quark/gluon of hard scattering
-C and write hadron remnant to /POEVT1/
-C
-C input: JM1,2 index of mother particle in POEVT1
-C IGEN mother particle production process
-C IHPOS hard pomeron number
-C INDXH index of hard parton
-C positive for labels 1
-C negative for labels 2
-C IVAL 1 hard valence parton
-C 0 hard sea parton connected by color flow with
-C valence quarks
-C -1 hard sea parton independent off valence
-C quarks
-C INDXS index of soft partons needed
-C
-C output: IC1,IC2 color label of initial parton
-C IUSED number of soft X values used
-C IREJ rejection flag
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- IREJ = 0
-
- INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
-
- IF(INDXH.GT.0) THEN
- IJH = IPHO_CNV1(NINHD(INDXH,1))
- ELSE
- IJH = IPHO_CNV1(NINHD(-INDXH,2))
- ENDIF
-C direct process (photon or pomeron)
- IUSED = 0
- IC1 = 0
- IC2 = 0
- IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
-
- IHP = 100*ABS(IHPOS)
- IVSW = 1
-***************************************
-* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
-***************************************
-
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
- & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
- & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
-
-C quark
-C****************************************************************
-
- IF(IJH.NE.21) THEN
-
-C valence quark engaged in hard scattering
- IF(IVAL.EQ.1) THEN
- CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
- IF(IREJ.NE.0) THEN
- WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
- & 'invalid valence flavour requested JM,IFLA',JM1,IJH
- return
- ENDIF
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
- & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
- I = ICA1
- ICA1 = ICB1
- ICB1 = I
- ENDIF
-C remnant of hadron
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = IREM
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = IREM
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IREM,IPOS,SIGN(INDXS,INDXH)
-
- IUSED = 1
-
-C sea quark engaged in hard scattering, valence quarks treated
- ELSE IF(IVAL.EQ.0) THEN
- IF(INDXH.GT.0) THEN
- E1 = PSOFT1(4,INDXS)
- E2 = PSOFT1(4,INDXS+1)
- ELSE
- E1 = PSOFT2(4,INDXS)
- E2 = PSOFT2(4,INDXS+1)
- ENDIF
- CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(DT_RNDM(P1).LT.0.5D0) THEN
- CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
- ELSE
- CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
- ENDIF
- IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
- & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
- I = ICA1
- ICA1 = ICB1
- ICB1 = I
- ENDIF
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = IVFL1
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = IVFL1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IVFL1,IPOS,SIGN(INDXS,INDXH)
-
-C
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+1)
- P2 = PSOFT1(2,INDXS+1)
- P3 = PSOFT1(3,INDXS+1)
- P4 = PSOFT1(4,INDXS+1)
- IJSI1(INDXS+1) = IVFL2
- ELSE
- P1 = PSOFT2(1,INDXS+1)
- P2 = PSOFT2(2,INDXS+1)
- P3 = PSOFT2(3,INDXS+1)
- P4 = PSOFT2(4,INDXS+1)
- IJSI2(INDXS+1) = IVFL2
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICB1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
-
-C
- IF(IJH.LT.0) THEN
- ICB1 = ICC2
- ICA1 = ICC1
- ELSE
- ICB1 = ICC1
- ICA1 = ICC2
- ENDIF
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+2)
- P2 = PSOFT1(2,INDXS+2)
- P3 = PSOFT1(3,INDXS+2)
- P4 = PSOFT1(4,INDXS+2)
- IJSI1(INDXS+2) = -IJH
- ELSE
- P1 = PSOFT2(1,INDXS+2)
- P2 = PSOFT2(2,INDXS+2)
- P3 = PSOFT2(3,INDXS+2)
- P4 = PSOFT2(4,INDXS+2)
- IJSI2(INDXS+2) = -IJH
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,0,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & -IJH,IPOS,SIGN(INDXS+2,INDXH)
- IUSED = 3
-C
-C sea quark engaged in hard scattering, valences treated separately
- ELSE IF(IVAL.EQ.-1) THEN
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(IJH.GT.0) THEN
- ICC1 = ICB1
- ICB1 = ICA1
- ICA1 = ICC1
- ENDIF
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = -IJH
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = -IJH
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,0,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & -IJH,IPOS,SIGN(INDXS,INDXH)
-
- IUSED = 1
- ELSE
- WRITE(LO,'(1X,A,2I5)')
- & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
- & IVAL,IJH
- CALL PHO_ABORT
- ENDIF
-C
- IC1 = ICB1
- IC2 = 0
-C
-C gluon
-C****************************************************************
-C
-C gluon from valence quarks
- ELSE
- IF(IVAL.EQ.1) THEN
-C purely gluonic pomeron remnant
- IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
- P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
- P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
- P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
- IJSI1(INDXS) = 0
- ELSE
- P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
- P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
- P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
- P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
- IJSI2(INDXS) = 0
- ENDIF
- IFL1 = 21
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(DT_RNDM(P2).LT.0.5D0) THEN
- CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
- ELSE
- CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,ICB1,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
- & IFL1,IPOS,SIGN(INDXS,INDXH)
-
- IUSED = 2
-C valence quark remnant
- ELSE
- IF(INDXH.GT.0) THEN
- E1 = PSOFT1(4,INDXS)
- E2 = PSOFT1(4,INDXS+1)
- ELSE
- E1 = PSOFT2(4,INDXS)
- E2 = PSOFT2(4,INDXS+1)
- ENDIF
- CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
- & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
- I = ICA1
- ICA1 = ICB1
- ICB1 = I
- ENDIF
- IF(DT_RNDM(P2).LT.0.5D0) THEN
- CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
- ELSE
- CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
- ENDIF
-C remnant of hadron
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = IFL1
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = IFL1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IFL1,IPOS,SIGN(INDXS,INDXH)
-
-C
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+1)
- P2 = PSOFT1(2,INDXS+1)
- P3 = PSOFT1(3,INDXS+1)
- P4 = PSOFT1(4,INDXS+1)
- IJSI1(INDXS+1) = IFL2
- ELSE
- P1 = PSOFT2(1,INDXS+1)
- P2 = PSOFT2(2,INDXS+1)
- P3 = PSOFT2(3,INDXS+1)
- P4 = PSOFT2(4,INDXS+1)
- IJSI2(INDXS+1) = IFL2
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICB1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IFL2,IPOS,SIGN(INDXS+1,INDXH)
-
- IUSED = 2
- ENDIF
-C
-C gluon from sea quarks connected with valence quarks
- ELSE IF(IVAL.EQ.0) THEN
- IF(INDXH.GT.0) THEN
- E1 = PSOFT1(4,INDXS)
- E2 = PSOFT1(4,INDXS+1)
- ELSE
- E1 = PSOFT2(4,INDXS)
- E2 = PSOFT2(4,INDXS+1)
- ENDIF
- CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
- & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
- I = ICA1
- ICA1 = ICB1
- ICB1 = I
- ENDIF
- IF(DT_RNDM(P3).LT.0.5D0) THEN
- CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
- ELSE
- CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
- ENDIF
-C remnant of hadron
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = IFL1
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = IFL1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IFL1,IPOS,SIGN(INDXS,INDXH)
-
-C
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+1)
- P2 = PSOFT1(2,INDXS+1)
- P3 = PSOFT1(3,INDXS+1)
- P4 = PSOFT1(4,INDXS+1)
- IJSI1(INDXS+1) = IFL2
- ELSE
- P1 = PSOFT2(1,INDXS+1)
- P2 = PSOFT2(2,INDXS+1)
- P3 = PSOFT2(3,INDXS+1)
- P4 = PSOFT2(4,INDXS+1)
- IJSI2(INDXS+1) = IFL2
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICB1,IVSW,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
- & IFL2,IPOS,SIGN(INDXS+1,INDXH)
-
- IF(IPAMDL(18).EQ.0) THEN
-C sea quark pair
- CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
- IF(ICC1.GT.0) THEN
- IFL1 = ABS(IFL1)
- IFL2 = -IFL1
- ELSE
- IFL1 = -ABS(IFL1)
- IFL2 = -IFL1
- ENDIF
- IF(DT_RNDM(P4).LT.0.5D0) THEN
- ICB1 = ICC2
- CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
- ELSE
- ICA1 = ICC1
- CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
- ENDIF
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+2)
- P2 = PSOFT1(2,INDXS+2)
- P3 = PSOFT1(3,INDXS+2)
- P4 = PSOFT1(4,INDXS+2)
- IJSI1(INDXS+2) = IFL1
- ELSE
- P1 = PSOFT2(1,INDXS+2)
- P2 = PSOFT2(2,INDXS+2)
- P3 = PSOFT2(3,INDXS+2)
- P4 = PSOFT2(4,INDXS+2)
- IJSI2(INDXS+2) = IFL1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,0,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & IFL1,IPOS,SIGN(INDXS+2,INDXH)
-
-C
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS+3)
- P2 = PSOFT1(2,INDXS+3)
- P3 = PSOFT1(3,INDXS+3)
- P4 = PSOFT1(4,INDXS+3)
- IJSI1(INDXS+3) = IFL2
- ELSE
- P1 = PSOFT2(1,INDXS+3)
- P2 = PSOFT2(2,INDXS+3)
- P3 = PSOFT2(3,INDXS+3)
- P4 = PSOFT2(4,INDXS+3)
- IJSI2(INDXS+3) = IFL2
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICB1,0,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & IFL2,IPOS,SIGN(INDXS+3,INDXH)
-
- IUSED = 4
- ELSE
- IUSED = 2
- ENDIF
-C
-C gluon from independent sea quarks
- ELSE IF(IVAL.EQ.-1) THEN
- IF(IPAMDL(18).EQ.0) THEN
- CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
- CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
- IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
- & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
- I = ICA1
- ICA1 = ICB1
- ICB1 = I
- ENDIF
- IF(DT_RNDM(P1).LT.0.5D0) THEN
- CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
- ELSE
- CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
- ENDIF
-C remainder of hadron
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS)
- P2 = PSOFT1(2,INDXS)
- P3 = PSOFT1(3,INDXS)
- P4 = PSOFT1(4,INDXS)
- IJSI1(INDXS) = IFL1
- ELSE
- P1 = PSOFT2(1,INDXS)
- P2 = PSOFT2(2,INDXS)
- P3 = PSOFT2(3,INDXS)
- P4 = PSOFT2(4,INDXS)
- IJSI2(INDXS) = IFL1
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICA1,ICA2,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & IFL1,IPOS,SIGN(INDXS,INDXH)
-
-C remnant of sea
- IF(INDXH.GT.0) THEN
- P1 = PSOFT1(1,INDXS-1)
- P2 = PSOFT1(2,INDXS-1)
- P3 = PSOFT1(3,INDXS-1)
- P4 = PSOFT1(4,INDXS-1)
- IJSI1(INDXS-1) = IFL2
- ELSE
- P1 = PSOFT2(1,INDXS-1)
- P2 = PSOFT2(2,INDXS-1)
- P3 = PSOFT2(3,INDXS-1)
- P4 = PSOFT2(4,INDXS-1)
- IJSI2(INDXS-1) = IFL2
- ENDIF
-C registration
- CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
- & IHP,IGEN,ICB1,ICB2,IPOS,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
- & IFL2,IPOS,SIGN(INDXS-1,INDXH)
-
- IUSED = 2
- ELSE
- CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
- IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
- & 'PHO_HARREM: no spectator added:(INDXS)',
- & SIGN(INDXS,INDXH)
- IUSED = 0
- ENDIF
-C
- ELSE
- WRITE(LO,'(1X,A,2I5)')
- & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
- & IVAL,IJH
- CALL PHO_ABORT
- ENDIF
- IC1 = ICC1
- IC2 = ICC2
- ENDIF
- END
-
-CDECK ID>, PHO_HARDIR
- SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
- & IREJ)
-C**********************************************************************
-C
-C parton orientated formulation of direct scattering processes
-C
-C input:
-C
-C output: II particle combination (1..4)
-C IVAL1,2 0 no valence quarks engaged
-C 1 valence quarks engaged
-C MSPAR1,2 number of realized soft partons
-C MHPAR1,2 number of realized hard partons
-C IREJ 1 failure
-C 0 success
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- DIMENSION P1(4),P2(4),PD1(-6:6)
-
- PARAMETER ( TINY = 1.D-10 )
-
- ITRY = 0
- NTRY = 10
- LSC1HD = 0
- LSIDX(1) = 1
-
-C check phase space
- IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
- IFAIL(18) = IFAIL(18)+1
- IREJ = 50
- RETURN
- ENDIF
-
- AS = (PARMDL(160+II)/ECMP)**2
- AH = (2.D0*PTWANT/ECMP)**2
-
- ALNS = LOG(AS)
- ALNH = LOG(AH)
-
- XMAX = MAX(TINY,1.D0-AS)
- Z1MAX = LOG(XMAX)
- Z1DIF = Z1MAX-ALNH
-C
-C main loop to select hard and soft parton kinematics
-C -----------------------------------------------------
- 120 CONTINUE
- IREJ = 0
- ITRY = ITRY+1
- LSC1HD = LSC1HD+1
- IF(ITRY.GT.1) THEN
- IFAIL(17) = IFAIL(17)+1
- IF(ITRY.GE.NTRY) THEN
- IREJ = 1
- GOTO 450
- ENDIF
- ENDIF
- LINE = 0
- LSCAHD = 0
- XSS1 = 0.D0
- XSS2 = 0.D0
- MSPAR1 = 0
- MSPAR2 = 0
-
-C select hard V,X
- CALL PHO_HARSCA(1,II)
- XSS1 = XSS1+X1
- XSS2 = XSS2+X2
-C debug output
- IF(IDEB(25).GE.20) THEN
- WRITE(LO,'(1X,A,2E12.4,2I5)')
- & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
- & AS,XMAX,MSPR,ITRY
- WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
- & X1,X2,XSS1,XSS2
- ENDIF
-
- IF(MSPR.LE.11) THEN
- IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
- ELSE IF(MSPR.LE.13) THEN
- IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
- ENDIF
-
-C fill /POHSLT/
- LSCAHD = 1
- LSIDX(1) = 1
- XHD(1,1) = X1
- XHD(1,2) = X2
- X0HD(1,1) = X1
- X0HD(1,2) = X2
- VHD(1) = V
- ETAHD(1,1) = ETAC
- ETAHD(1,2) = ETAD
- PTHD(1) = PT
- Q2SCA(1,1) = QQPD
- Q2SCA(1,2) = QQPD
- NPROHD(1) = MSPR
- NBRAHD(1,1)= IDPDG1
- NBRAHD(1,2)= IDPDG2
- DO 45 I=1,4
- PPH(I,1) = PHI1(I)
- PPH(I,2) = PHI2(I)
- PPH(4+I,1) = PHO1(I)
- PPH(4+I,2) = PHO2(I)
- 45 CONTINUE
-C valence quarks
- IVAL1 = IV1
- IVAL2 = IV2
- PDFVA(1,1) = 0.D0
- PDFVA(1,2) = 0.D0
-C parton flavours
- IF(MSPR.LE.11) THEN
- NINHD(1,1) = IDPDG1
- NINHD(1,2) = IB
- PDFVA(1,2) = PDF2(IB)
- KHDIR = 1
- ELSE IF(MSPR.LE.13) THEN
- NINHD(1,1) = IA
- PDFVA(1,1) = PDF1(IA)
- NINHD(1,2) = IDPDG2
- KHDIR = 2
- ELSE
- NINHD(1,1) = IDPDG1
- NINHD(1,2) = IDPDG2
- KHDIR = 3
- ENDIF
- N0INHD(1,1) = NINHD(1,1)
- N0INHD(1,2) = NINHD(1,2)
- N0IVAL(1,1) = IVAL1
- N0IVAL(1,2) = IVAL2
- NOUTHD(1,1) = IC
- NOUTHD(1,2) = ID
-
-C reweight according to photon virtuality
- IF(MSPR.NE.14) THEN
- IF(IPAMDL(115).GE.1) THEN
- WGX = 1.D0
- IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
- QQPD = Q2SCA(1,2)
- IF(IPAMDL(115).EQ.1) THEN
- IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
- WGX = 0.D0
- ELSE
- WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
- & /LOG(QQPD/PARMDL(144))
- ENDIF
- IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
- ELSE IF(IPAMDL(115).EQ.2) THEN
- CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
- WGX = PD1(IB)/PDFVA(1,2)
- ENDIF
- ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
- & .AND.(IDPDG1.EQ.22)) THEN
- QQPD = Q2SCA(1,1)
- IF(IPAMDL(115).EQ.1) THEN
- IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
- WGX = 0.D0
- ELSE
- WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
- & /LOG(QQPD/PARMDL(144))
- ENDIF
- IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
- ELSE IF(IPAMDL(115).EQ.2) THEN
- CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
- WGX = PD1(IA)/PDFVA(1,1)
- ENDIF
- ENDIF
-
- IF(IDEB(25).GE.25)
- & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
- & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
- & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
-
- IF(WGX.LT.DT_RNDM(WGX)) THEN
- IREJ = 50
- RETURN
- ENDIF
-
- IF(WGX.GT.1.01D0)
- & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
- & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
- & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
-
- ENDIF
- ENDIF
-
-C generate ISR
- IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
- IF(IPAMDL(109).EQ.1) THEN
- Q2H = PARMDL(93)*PT**2
- ELSE
- Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
- ENDIF
- XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
- XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
- DO 42 J=1,4
- P1(J) = PPH(4+J,1)
- P2(J) = PPH(4+J,2)
- 42 CONTINUE
- CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
- & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
- & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
- XSS1 = XSS1+XISR1-XHD(1,1)
- XSS2 = XSS2+XISR2-XHD(1,2)
- NINHD(1,1) = IFL1
- NINHD(1,2) = IFL2
- XHD(1,1) = XISR1
- XHD(1,2) = XISR2
- ELSE
- IFL1 = NINHD(1,1)
- IFL2 = NINHD(1,2)
- ENDIF
- NIVAL(1,1) = IVAL1
- NIVAL(1,2) = IVAL2
-
-C add photon/hadron remnant
-
-C incoming gluon
- IF(IFL2.EQ.0) THEN
- XMAXX = 1.D0 - XSS2 - AS
- XMAXH = MIN(XMAXX,PARMDL(44))
- CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
- IVAL2 = 1
- MSPAR1 = 0
- MSPAR2 = 2
- MHPAR1 = 1
- MHPAR2 = 1
- ELSE IF(IFL1.EQ.0) THEN
- XMAXX = 1.D0 - XSS1 - AS
- XMAXH = MIN(XMAXX,PARMDL(44))
- CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
- IVAL1 = 1
- MSPAR1 = 2
- MSPAR2 = 0
- MHPAR1 = 1
- MHPAR2 = 1
-
-C incoming quark
- ELSE IF(ABS(IFL2).LE.12) THEN
- IF(IVAL2.EQ.1) THEN
- XS2(1) = 1.D0 - XSS2
- MSPAR1 = 0
- MSPAR2 = 1
- MHPAR1 = 1
- MHPAR2 = 1
- ELSE
- XMAXX = 1.D0 - XSS2 - AS
- XMAXH = MIN(XMAXX,PARMDL(44))
- CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
- MSPAR1 = 0
- MSPAR2 = 3
- MHPAR1 = 1
- MHPAR2 = 1
- ENDIF
- ELSE IF(ABS(IFL1).LE.12) THEN
- IF(IVAL1.EQ.1) THEN
- XS1(1) = 1.D0 - XSS1
- MSPAR1 = 1
- MSPAR2 = 0
- MHPAR1 = 1
- MHPAR2 = 1
- ELSE
- XMAXX = 1.D0 - XSS1 - AS
- XMAXH = MIN(XMAXX,PARMDL(44))
- CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
- MSPAR1 = 3
- MSPAR2 = 0
- MHPAR1 = 1
- MHPAR2 = 1
- ENDIF
-
-C double direct process
- ELSE IF(MSPR.EQ.14) THEN
- MSPAR1 = 0
- MSPAR2 = 0
- MHPAR1 = 1
- MHPAR2 = 1
-
-C unknown process
- ELSE
- WRITE(LO,'(/1X,A,I3/)')
- & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
- CALL PHO_ABORT
- ENDIF
-
- IF(IREJ.NE.0) THEN
- IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
- GOTO 120
- ENDIF
-
-C soft particle momenta
- IF(MSPAR1.GT.0) THEN
- DO 50 I=1,MSPAR1
- PSOFT1(1,I) = 0.D0
- PSOFT1(2,I) = 0.D0
- PSOFT1(3,I) = XS1(I)*ECMP/2.D0
- PSOFT1(4,I) = XS1(I)*ECMP/2.D0
- 50 CONTINUE
- ENDIF
- IF(MSPAR2.GT.0) THEN
- DO 55 I=1,MSPAR2
- PSOFT2(1,I) = 0.D0
- PSOFT2(2,I) = 0.D0
- PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
- PSOFT2(4,I) = XS2(I)*ECMP/2.D0
- 55 CONTINUE
- ENDIF
-C process counting
- MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
- KSOFT = MAX(MSPAR1,MSPAR2)
- KHARD = MAX(MHPAR1,MHPAR2)
-C debug output
- IF(IDEB(25).GE.10) THEN
- WRITE(LO,'(/1X,A,2I3,3I5)')
- & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
- & IVAL1,IVAL2,MSPR,ITRY,NTRY
- IF(MSPAR1.GT.0) THEN
- WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
- DO 105 I=1,MSPAR1
- WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
- 105 CONTINUE
- ENDIF
- IF(MSPAR2.GT.0) THEN
- WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
- DO 106 I=1,MSPAR2
- WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
- 106 CONTINUE
- ENDIF
- WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
- WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
- WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
- WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
- WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
- WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
- WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
- WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
- ENDIF
- RETURN
-
- 450 CONTINUE
- IFAIL(16) = IFAIL(16)+1
- IF(IDEB(25).GE.2) THEN
- WRITE(LO,'(1X,A,3I5)')
- & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
- WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
- IF(IDEB(25).GE.5) THEN
- CALL PHO_PREVNT(0)
- ELSE
- CALL PHO_PREVNT(-1)
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_POMSCA
- SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
- & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
-C**********************************************************************
-C
-C parton orientated formulation of soft and hard inelastic events
-C
-C
-C input: II particle combiantion (1..4)
-C MSPOM number of soft pomerons
-C MHPOM number of semihard pomerons
-C MSREG number of soft reggeons
-C
-C output: IVAL1,2 0 no valence quark engaged
-C otherwise: position of valence quark engaged
-C neg.number: gluon connected to valence quark
-C by color flow
-C MSPAR1,2 number of realized soft partons
-C MHPAR1,2 number of realized hard partons
-C IREJ 1 failure
-C 0 success
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (TINY = 1.D-30 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- DIMENSION P1(4),P2(4),PD1(-6:6)
-
- IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
-
- ITRY = 0
- NTRY = 10
- IREJ = 0
- INMAX = 10
- MHARD = MHPOM
-
-C phase space limitation (single hard valence-valence quark scattering)
- IF(MHPOM.GT.0) THEN
- Emin = 2.D0*PTWANT + 0.2D0
- IF(ECMP.LT.Emin) THEN
- IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
- & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
- IREJ = 50
- IFAIL(6) = IFAIL(6) + 1
- RETURN
- ENDIF
- ENDIF
-
- SAS = PARMDL(160+II)/ECMP
- SAH = 2.D0*PTWANT/ECMP
- AS = SAS**2
- AH = SAH**2
-
-C save energy for leading particle effect
- XMAXP1 = 1.D0
- if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
- XMAXP2 = 1.D0
- if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
-
-C
-C main loop to select hard and soft parton kinematics
-C -----------------------------------------------------
- IFAIL(31) = IFAIL(31)+MHARD
- 20 CONTINUE
- IREJ = 0
- IHARD = 0
- LSC1HD = 0
- ITRY = ITRY+1
- IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
- IF(ITRY.GE.NTRY) THEN
- IREJ = 1
- GOTO 450
- ENDIF
- LINE = 0
- LSCAHD = 0
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
- XSS1 = MAX(0.D0,1.D0-XPSUB)
- XSS2 = MAX(0.D0,1.D0-XTSUB)
- ELSE
- XSS1 = 0.D0
- XSS2 = 0.D0
- ENDIF
- 22 continue
-
-C partons needed to construct soft/hard interactions
- MSPAR1 = 2*MSPOM+MSREG+MHPOM
- MSPAR2 = MSPAR1
- MHPAR1 = MHPOM
- MHPAR2 = MHPOM
-
-C number of strings
- MSCHA = 2*MSPOM+MSREG
- MHCHA = 2*MHPOM
-
- KSOFT = MSCHA
- KHARD = MHCHA
-
-C check actual phase space limit
- XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
- IF(XX.GE.1.D0) THEN
- IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
- & 'PHO_POMSCA: internal kin. rejection ',
- & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
- & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
- if(MSPOM+MSREG+MHPOM.gt.1) then
- if(MSREG.gt.0) then
- MSREG = MSREG-1
- else if(MSPOM.gt.0) THEN
- MSPOM = MSPOM-1
- else if(MHPOM.gt.1) then
- MHPOM = MHPOM-1
- endif
- goto 22
- endif
- IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
- & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
- IREJ = 50
- IFAIL(6) = IFAIL(6) + 1
- RETURN
- ENDIF
-
- XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
- XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
-
-C very low energy phase space restriction
- if(MHARD.gt.0) then
- if((XMAXX1*XMAXX2.le.AH)) then
- IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
- & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
- IREJ = 50
- IFAIL(6) = IFAIL(6) + 1
- RETURN
- endif
- endif
-
- AS = MAX(AS,PSOMIN/PCMP)
- ALNS = LOG(AS)
- ALNH = LOG(AH)
- Z1MAX = LOG(XMAXX1)
- Z2MAX = LOG(XMAXX2)
- Z1DIF = Z1MAX+Z2MAX-ALNH
- Z2DIF = Z1DIF
- PTMAX = 0.D0
-C
-C select hard parton momenta
-C ------------------- begin of inner loop -------------------
- IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
-
- IF(MHARD.GT.MSCAHD) THEN
- WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
- & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
- IREJ = 1
- RETURN
- ENDIF
-
- DO 11 NN=1,MHARD
-C
-C generate one resolved hard scattering
-C
-C high-pt option
- IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
- CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
- & -1,Max_pro_2,1,4,MSPOM+MHPOM)
- XSCUT = HSig(9)
- AHS = AH
- ALNHS = ALNH
- Z1DIFS = Z1DIF
- Z2DIFS = Z2DIF
- AH = (2.D0*PTWANT/ECMP)**2
- ALNH = LOG(AH)
- Z1DIF = Z1MAX+Z2MAX-ALNH
- Z2DIF = Z1DIF
- IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
- IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
- & 'PHO_POMSCA: kin.rejection, high-pt option ',
- & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
- IREJ = 5
- RETURN
- ENDIF
- CALL PHO_HARSCA(2,II)
- CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
- & -1,Max_pro_2,1,4,MSPOM+MHPOM)
- AH = AHS
- ALNH = ALNHS
- Z1DIF = Z1DIFS
- Z2DIF = Z2DIFS
- IPOWGC(4+II) = IPOWGC(4+II)+1
- HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
-C minimum bias option
- ELSE
- CALL PHO_HARSCA(2,II)
- ENDIF
-
-C fill /POHSLT/
- LSIDX(NN) = NN
- LSCAHD = NN
- XHD(NN,1) = X1
- XHD(NN,2) = X2
- X0HD(NN,1) = X1
- X0HD(NN,2) = X2
- VHD(NN) = V
- ETAHD(NN,1) = ETAC
- ETAHD(NN,2) = ETAD
- PTHD(NN) = PT
- NPROHD(NN) = MSPR
- Q2SCA(NN,1) = QQPD
- Q2SCA(NN,2) = QQPD
- PDFVA(NN,1) = PDF1(IA)
- PDFVA(NN,2) = PDF2(IB)
- NINHD(NN,1) = IA
- NINHD(NN,2) = IB
- N0INHD(NN,1) = IA
- N0INHD(NN,2) = IB
- NIVAL(NN,1) = IV1
- NIVAL(NN,2) = IV2
- N0IVAL(NN,1) = IV1
- N0IVAL(NN,2) = IV2
- NOUTHD(NN,1) = IC
- NOUTHD(NN,2) = ID
- NBRAHD(NN,1) = IDPDG1
- NBRAHD(NN,2) = IDPDG2
- I3 = 8*(NN-1)
- I4 = 8*(NN-1)+4
- DO 50 I=1,4
- PPH(I3+I,1) = PHI1(I)
- PPH(I3+I,2) = PHI2(I)
- PPH(I4+I,1) = PHO1(I)
- PPH(I4+I,2) = PHO2(I)
- 50 CONTINUE
-
- 11 CONTINUE
-
-C sort according to pt-hat
- DO 12 NN=1,MHARD
- PTMX = PTHD(LSIDX(NN))
- IPTM = NN
- DO 13 I=NN+1,MHARD
- IF(PTHD(LSIDX(I)).GT.PTMX) THEN
- IPTM = I
- PTMX = PTHD(LSIDX(I))
- ENDIF
- 13 CONTINUE
- IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
- 12 CONTINUE
- IPTM = LSIDX(1)
-
-C copy partons, generate ISR
- DO 15 L=1,MHARD
- NN = LSIDX(L)
- XSSS1 = XSS1+XHD(NN,1)
- XSSS2 = XSS2+XHD(NN,2)
-C debug output
- IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
- & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
- & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
-C check phase space
- IF( (XSSS1.GT.XMAXX1)
- & .OR.(XSSS2.GT.XMAXX2)
- & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
- IF(IHARD.EQ.0) THEN
- IF(ISWMDL(2).NE.1) GOTO 20
- MHPOM = 0
- MSPOM = 1
- MSREG = 0
- ENDIF
- GOTO 199
- ENDIF
-
-C reweight according to photon virtuality
- IF(IPAMDL(115).GE.1) THEN
- QQPD = Q2SCA(NN,1)
- WGX = 1.D0
- IF(IDPDG1.EQ.22) THEN
- IF(IPAMDL(115).EQ.1) THEN
- IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
- WG1 = 0.D0
- ELSE
- WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
- & /LOG(QQPD/PARMDL(144))
- ENDIF
- IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
- ELSE IF(IPAMDL(115).EQ.2) THEN
- CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
- WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
- ENDIF
- WGX = WG1
- ENDIF
- QQPD = Q2SCA(NN,2)
- IF(IDPDG2.EQ.22) THEN
- IF(IPAMDL(115).EQ.1) THEN
- IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
- WG1 = 0.D0
- ELSE
- WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
- & /LOG(QQPD/PARMDL(144))
- ENDIF
- IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
- ELSE IF(IPAMDL(115).EQ.2) THEN
- CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
- WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
- ENDIF
- WGX = WGX*WG1
- ENDIF
-
- IF(IDEB(24).GE.25)
- & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
- & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
- & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
-
- IF(WGX.LT.DT_RNDM(WGX)) THEN
- IF(L.EQ.1) THEN
- IREJ = 50
- RETURN
- ELSE
- GOTO 199
- ENDIF
- ENDIF
-
- IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
- & 'PHO_POMSCA: ',
- & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
- & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
-
- ENDIF
-
-C generate ISR
- IF((ISWMDL(8).GE.2)
- & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
- IF(IPAMDL(109).EQ.1) THEN
- Q2H = PARMDL(93)*PTHD(NN)**2
- ELSE
- Q2H = -PARMDL(93)*VHD(NN)
- & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
- ENDIF
- XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
- XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
- I3 = 8*NN-4
- DO 42 J=1,4
- P1(J) = PPH(I3+J,1)
- P2(J) = PPH(I3+J,2)
- 42 CONTINUE
- IF(IDEB(24).GE.10)
- & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
- & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
- & L,NN,XHD(NN,1),XHD(NN,2),Q2H
- J = NN
- IF(L.EQ.1) J = -NN
- CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
- & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
- & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
- & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
- XSSS1 = XSSS1+XISR1-XHD(NN,1)
- XSSS2 = XSSS2+XISR2-XHD(NN,2)
- NINHD(NN,1) = IFL1
- NINHD(NN,2) = IFL2
- XHD(NN,1) = XISR1
- XHD(NN,2) = XISR2
- ENDIF
-
-C check phase space
- IF( (XSSS1.GT.XMAXX1)
- & .OR.(XSSS2.GT.XMAXX2)
- & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
- IF(IHARD.EQ.0) THEN
- IF(ISWMDL(2).NE.1) GOTO 20
- MHPOM = 0
- MSPOM = 1
- MSREG = 0
- ENDIF
- GOTO 199
- ENDIF
-
-C leave energy for leading particle effect
- IF((IHARD.GT.0).AND.
- & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
- GOTO 199
- endif
-
-C hard scattering accepted
- IHARD = IHARD+1
- XSS1 = XSSS1
- XSS2 = XSSS2
- IFAIL(31) = IFAIL(31)-1
-
- 15 CONTINUE
-
-C ------------------- end of inner (hard) loop -------------------
- 199 CONTINUE
-
- MHPOM = IHARD
- MHPAR1 = IHARD
- MHPAR2 = IHARD
-
-C count valences involved in hard scattering
- IVAL1 = 0
- IVAL2 = 0
- DO 17 L=1,IHARD
- NN = LSIDX(L)
- IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
- IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
- 17 CONTINUE
-
- IQUA1 = 0
- IQUA2 = 0
- IVGLU1 = 0
- IVGLU2 = 0
- DO 18 L=1,IHARD
- NN = LSIDX(L)
-
-C photon, pomeron valences
- IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- NIVAL(NN,1) = 1
- IVAL1 = NN
- ENDIF
- ENDIF
- IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- NIVAL(NN,2) = 1
- IVAL2 = NN
- ENDIF
- ENDIF
-
-C total number of quarks
- IF(NINHD(NN,1).NE.0) THEN
- IQUA1 = IQUA1+1
- ELSE IF(IVGLU1.EQ.0) THEN
- IVGLU1 = NN
- ENDIF
- IF(NINHD(NN,2).NE.0) THEN
- IQUA2 = IQUA2+1
- ELSE IF(IVGLU2.EQ.0) THEN
- IVGLU2 = NN
- ENDIF
- 18 CONTINUE
-
-C gluons emitted by valence quarks
- VALPRO = 1.D0
- IF(II.EQ.1) VALPRO = VALPRG(1)
- IVQ1 = 1
- IVG1 = 0
- IVAL1 = MAX(IVAL1,0)
- IF(IVAL1.EQ.0) THEN
- IVQ1 = 0
- IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
- IVAL1 = -IVGLU1
- IVG1 = 1
- ENDIF
- ENDIF
- VALPRO = 1.D0
- IF(II.EQ.1) VALPRO = VALPRG(2)
- IVQ2 = 1
- IVG2 = 0
- IVAL2 = MAX(IVAL2,0)
- IF(IVAL2.EQ.0) THEN
- IVQ2 = 0
- IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
- IVAL2 = -IVGLU2
- IVG2 = 1
- ENDIF
- ENDIF
- MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
-C debug output
- IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
- & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
- & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
-
-C select soft X values
- 25 CONTINUE
-C number of soft/remnant quarks
- IF(MSPOM.EQ.0) THEN
- IF(IPAMDL(18).EQ.0) THEN
- MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
- MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
- ELSE
- MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
- MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
- ENDIF
- ELSE
- IF(IPAMDL(18).EQ.0) THEN
- MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
- MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
- ELSE
- MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
- MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
- ENDIF
- ENDIF
-C debug output
- IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
- & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
- & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
-
- XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
- XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
- I1 = IVQ1
- I2 = IVQ2
- IF(IVAL1.LE.0) I1 = 0
- IF(IVAL2.LE.0) I2 = 0
- IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
- MSDIFF = 2*MSPOM
- ELSE
- MSDIFF = 2*MAX(0,MSPOM-1)
- ENDIF
- MSG1 = MSPAR1
- MSG2 = MSPAR2
- MSM1 = MSPAR1-MSDIFF
- MSM2 = MSPAR2-MSDIFF
- XMAXH1 = MIN(XMAX1,PARMDL(44))
- XMAXH2 = MIN(XMAX2,PARMDL(44))
- CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
- & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
-
-C correct for proper simulation of high pt tail
- IF(IREJ.NE.0) THEN
- IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
- & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
- & MSPOM,MHPOM,I1,I2
- IF(MSPOM*MHPOM.GT.0) THEN
- MSPOM = MSPOM-1
- GOTO 25
- ELSE IF(MSPOM.GT.1) THEN
- MSPOM = MSPOM-1
- GOTO 25
- ELSE IF(MHPOM.GT.1) THEN
- IHARD = IHARD-1
- IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
- & .AND.(IPROCE.EQ.1)) THEN
- XSS1 = MAX(0.D0,1.D0-XPSUB)
- XSS2 = MAX(0.D0,1.D0-XTSUB)
- ELSE
- XSS1 = 0.D0
- XSS2 = 0.D0
- ENDIF
- DO 103 K=1,IHARD
- I = LSIDX(K)
- XSS1 = XSS1+ XHD(I,1)
- XSS2 = XSS2+ XHD(I,2)
- 103 CONTINUE
- GOTO 199
- ENDIF
- IREJ = 4
- GOTO 450
- ENDIF
-C accepted
- MSPOM = MSPOM-(MSPAR1-MSG1)/2
- MSPAR1 = MSG1
- MSPAR2 = MSG2
-C ------------ kinematics sampled ---------------
-C debug output
- IF(IDEB(24).GE.10) THEN
- WRITE(LO,'(1X,A,I3)')
- & 'PHO_POMSCA: soft x values, ITRY',ITRY
- DO 104 I=2,MAX(MSPAR1,MSPAR2)
- WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
- 104 CONTINUE
- ENDIF
- IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
-
-C end of loop
- XS1(1) = 1.D0 - XSS1
- XS2(1) = 1.D0 - XSS2
-
-C process counting
- DO 30 N=1,LSCAHD
- MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
- 30 CONTINUE
-
-C soft particle momenta
-
- IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
- WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
- & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
- IREJ = 1
- RETURN
- ENDIF
-
- DO 55 I=1,MSPAR1
- PSOFT1(1,I) = 0.D0
- PSOFT1(2,I) = 0.D0
- PSOFT1(3,I) = XS1(I)*ECMP/2.D0
- PSOFT1(4,I) = XS1(I)*ECMP/2.D0
- 55 CONTINUE
- DO 60 I=1,MSPAR2
- PSOFT2(1,I) = 0.D0
- PSOFT2(2,I) = 0.D0
- PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
- PSOFT2(4,I) = XS2(I)*ECMP/2.D0
- 60 CONTINUE
-
- KSOFT = MAX(MSPAR1,MSPAR2)
- KHARD = MAX(MHPAR1,MHPAR2)
- KSPOM = MSPOM
- KSREG = MSREG
- KHPOM = MHPOM
-
-C debug output
- IF(IDEB(24).GE.10) THEN
- WRITE(LO,'(/1X,A,2I3,2I5)')
- & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
- & IVAL1,IVAL2,ITRY,NTRY
- IF(MSPAR1+MSPAR2.GT.0) THEN
- WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
- XTMP1 = 0.D0
- XTMP2 = 0.D0
- DO 105 I=1,MAX(MSPAR1,MSPAR2)
- IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
- WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
- XTMP1 = XTMP1+XS1(I)
- XTMP2 = XTMP2+XS2(I)
- ELSE IF(I.LE.MSPAR1) THEN
- WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
- XTMP1 = XTMP1+XS1(I)
- ELSE IF(I.LE.MSPAR2) THEN
- WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
- XTMP2 = XTMP2+XS2(I)
- ENDIF
- 105 CONTINUE
- WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
- ENDIF
- IF(MHPAR1.GT.0) THEN
- WRITE(LO,'(5X,A)')
- & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
- DO 107 K=1,MHPAR1
- I = LSIDX(K)
- WRITE(LO,'(5X,3I3,4E12.3,2I3)')
- & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
- & NINHD(I,1),NINHD(I,2)
- XTMP1 = XTMP1+XHD(I,1)
- XTMP2 = XTMP2+XHD(I,2)
- 107 CONTINUE
- WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
- WRITE(LO,'(5X,A)') 'hard momenta particle1:'
- DO 108 K=1,MHPAR1
- I = LSIDX(K)
- I3 = 8*I-4
- WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
- & NOUTHD(I,1)
- 108 CONTINUE
- WRITE(LO,'(5X,A)') 'hard momenta particle2:'
- DO 110 K=1,MHPAR2
- I = LSIDX(K)
- I3 = 8*I-4
- WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
- & NOUTHD(I,2)
- 110 CONTINUE
- ENDIF
- ENDIF
- RETURN
-
-C event rejected, print debug information
- 450 CONTINUE
- IFAIL(4) = IFAIL(4)+1
- IF(IDEB(24).GE.2) THEN
- WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
- & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
- & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
- WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
- IF(IDEB(24).GE.5) THEN
- CALL PHO_PREVNT(0)
- ELSE
- CALL PHO_PREVNT(-1)
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_HARX12
- SUBROUTINE PHO_HARX12
-C**********************************************************************
-C
-C selection of x1 and x2 according to 1/x1*1/x2
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-
-10 CONTINUE
- Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
- Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
- IF ( (Z1+Z2).LT.ALNH ) GOTO 10
- X1 = EXP(Z1)
- X2 = EXP(Z2)
- AXX = AH/(X1*X2)
- W = SQRT(MAX(TINY,1.D0-AXX))
- W1 = AXX/(1.D0+W)
-
- END
-
-CDECK ID>, PHO_HARDX1
- SUBROUTINE PHO_HARDX1
-C**********************************************************************
-C
-C selection of x1 according to 1/x1
-C ( x2 = 1 )
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-
- Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
- X2 = 1.D0
- X1 = EXP(Z1)
- AXX = AH/X1
- W = SQRT(MAX(TINY,1.D0-AXX))
- W1 = AXX/(1.D0+W)
-
- END
-
-CDECK ID>, PHO_HARKIN
- SUBROUTINE PHO_HARKIN(IREJ)
-C***********************************************************************
-C
-C selection of kinematic variables
-C (resolved and direct processes)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C internal cross check information on hard scattering limits
- DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
- COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
-
- PARAMETER ( Max_pro_2 = 16 )
- DIMENSION RM(-1:Max_pro_2)
- DATA RM / 3.31D0, 0.0D0,
- & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
- & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
- & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
- & 1.0D0 /
-
- IREJ = 0
- M = MSPR
-
-C------------- resolved processes -----------
- IF ( M.EQ.1 ) THEN
-10 CALL PHO_HARX12
- V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
- U =-1.D0-V
- R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
- ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
-20 CALL PHO_HARX12
- WL = LOG(W1)
- V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
- U =-1.D0-V
- R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
- ELSEIF ( M.EQ.3 ) THEN
-30 CALL PHO_HARX12
- V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
- U =-1.D0-V
- R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
- ELSEIF ( M.EQ.5 ) THEN
-50 CALL PHO_HARX12
- V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
- U =-1.D0-V
- R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
- ELSEIF ( M.EQ.6 ) THEN
-60 CALL PHO_HARX12
- V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
- U =-1.D0-V
- R = (4.D0/9.D0)*(U*U+V*V)*AXX
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
- ELSEIF ( M.EQ.7 ) THEN
-70 CALL PHO_HARX12
- V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
- U =-1.D0-V
- R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
- & -(4.D0/27.D0)*V/U)
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
- ELSEIF ( M.EQ.8 ) THEN
-80 CALL PHO_HARX12
- V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
- U =-1.D0-V
- R = (4.D0/9.D0)*(1.D0+U*U)
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
- ELSEIF ( M.EQ.-1 ) THEN
-90 CALL PHO_HARX12
- WL = LOG(W1)
- V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
- U =-1.D0-V
- R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
- IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
-C------------- direct / single-resolved processes -----------
- ELSEIF ( M.EQ.10 ) THEN
-100 CALL PHO_HARDX1
- WL = LOG(AXX/(1.D0+W)**2)
- U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
- R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
- IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
- V =-1.D0-U
- X2 = X1
- X1 = 1.D0
- ELSEIF ( M.EQ.11) THEN
-110 CALL PHO_HARDX1
- WL = LOG(W1)
- U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
- V =-1.D0-U
- R = (U*U+V*V)/V*WL*AXX
- IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
- X2 = X1
- X1 = 1.D0
- ELSEIF ( M.EQ.12 ) THEN
-120 CALL PHO_HARDX1
- WL = LOG(AXX/(1.D0+W)**2)
- V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
- R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
- IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
- ELSEIF ( M.EQ.13) THEN
-130 CALL PHO_HARDX1
- WL = LOG(W1)
- V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
- U =-1.D0-V
- R = (U*U+V*V)/U*WL*AXX
- IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
-C------------- (double) direct process -----------
- ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
- X1 = 1.D0
- X2 = 1.D0
- AXX= AH
- W = SQRT(MAX(TINY,1.D0-AXX))
- W1 = AXX/(1.D0+W)
- WL = LOG(W1)
- 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
- U =-1.D0-V
- R = -(U*U+V*V)/U
- IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
- & 'PHO_HARKIN:weight error',M
- IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
- IF ( DT_RNDM(V).LE.0.5D0 ) V = U
-C---------------------------------------------
- ELSE
- WRITE(LO,'(/1X,A,I3)')
- & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
- CALL PHO_ABORT
- ENDIF
-
- V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
- U = -1.D0-V
- U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
- PT = SQRT(U*V*X1*X2)*ECMP
- ETAC = 0.5D0*LOG((U*X1)/(V*X2))
- ETAD = 0.5D0*LOG((V*X1)/(U*X2))
-
-***************************************************************
- MM = M
- IF(M.EQ.-1) MM = 3
- ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
- ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
- ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
- ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
- XXMI(1,MM) = MIN(XXMI(1,MM),X1)
- XXMA(1,MM) = MAX(XXMA(1,MM),X1)
- XXMI(2,MM) = MIN(XXMI(2,MM),X2)
- XXMA(2,MM) = MAX(XXMA(2,MM),X2)
-***************************************************************
-
- IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
- & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
-
- END
-
-CDECK ID>, PHO_HARWGH
- SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
-C***********************************************************************
-C
-C calculate product of PDFs and coupling constants
-C according to selected MSPR (process type)
-C
-C input: /POCKIN/
-C
-C output: PDS resulting from PDFs alone
-C FDISTR complete weight function
-C PDA,PDB fields containing the PDFs
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DOUBLE PRECISION PHO_ALPHAS,pho_alphae
- DIMENSION PDA(-6:6),PDB(-6:6)
-
- FDISTR = 0.D0
-C set hard scale QQ for alpha and partondistr.
- IF ( NQQAL.EQ.1 ) THEN
- QQAL = AQQAL*PT*PT
- ELSEIF ( NQQAL.EQ.2 ) THEN
- QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
- ELSEIF ( NQQAL.EQ.3 ) THEN
- QQAL = AQQAL*X1*X2*ECMP*ECMP
- ELSEIF ( NQQAL.EQ.4 ) THEN
- QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
- ENDIF
- IF ( NQQPD.EQ.1 ) THEN
- QQPD = AQQPD*PT*PT
- ELSEIF ( NQQPD.EQ.2 ) THEN
- QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
- ELSEIF ( NQQPD.EQ.3 ) THEN
- QQPD = AQQPD*X1*X2*ECMP*ECMP
- ELSEIF ( NQQPD.EQ.4 ) THEN
- QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
- ENDIF
-C coupling constants, PDFs
- IF(MSPR.LT.9) THEN
- ALPHA1 = PHO_ALPHAS(QQAL,3)
- ALPHA2 = ALPHA1
- CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
- CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
- IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
- PDS = PDA(0)*PDB(0)
- ELSE
- S2 = 0.D0
- S3 = 0.D0
- S4 = 0.D0
- S5 = 0.D0
- DO 10 I=1,NF
- S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
- S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
- S4 = S4+PDA(I)+PDA(-I)
- S5 = S5+PDB(I)+PDB(-I)
- 10 CONTINUE
- IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
- PDS = S2
- ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
- PDS = PDA(0)*S5+PDB(0)*S4
- ELSE IF(MSPR.EQ.7) THEN
- PDS = S3
- ELSE IF(MSPR.EQ.8) THEN
- PDS = S4*S5-(S2+S3)
- ENDIF
- ENDIF
- ELSE IF(MSPR.LT.12) THEN
- ALPHA2 = PHO_ALPHAS(QQAL,2)
- IF(IDPDG1.EQ.22) THEN
- ALPHA1 = pho_alphae(QQAL)
- ELSE IF(IDPDG1.EQ.990) THEN
- ALPHA1 = PARMDL(74)
- ENDIF
- CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
- S4 = 0.D0
- S6 = 0.D0
- DO 15 I=1,NF
- S4 = S4+PDB(I)+PDB(-I)
-C charge counting
-* IF(MOD(I,2).EQ.0) THEN
-* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
-* ELSE
-* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
-* ENDIF
- S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
- 15 CONTINUE
- IF(MSPR.EQ.10) THEN
- IF(IDPDG1.EQ.990) THEN
- PDS = S4
- ELSE
- PDS = S6
- ENDIF
- ELSE
- PDS = PDB(0)
- ENDIF
- ELSE IF(MSPR.LT.14) THEN
- ALPHA1 = PHO_ALPHAS(QQAL,1)
- IF(IDPDG2.EQ.22) THEN
- ALPHA2 = pho_alphae(QQAL)
- ELSE IF(IDPDG2.EQ.990) THEN
- ALPHA2 = PARMDL(74)
- ENDIF
- CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
- S4 = 0.D0
- S6 = 0.D0
- DO 20 I=1,NF
- S4 = S4+PDA(I)+PDA(-I)
-C charge counting
-* IF(MOD(I,2).EQ.0) THEN
-* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
-* ELSE
-* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
-* ENDIF
- S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
- 20 CONTINUE
- IF(MSPR.EQ.12) THEN
- IF(IDPDG2.EQ.990) THEN
- PDS = S4
- ELSE
- PDS = S6
- ENDIF
- ELSE
- PDS = PDA(0)
- ENDIF
- ELSE IF(MSPR.EQ.14) THEN
- SSR = X1*X2*ECMP*ECMP
- IF(IDPDG1.EQ.22) THEN
- ALPHA1 = pho_alphae(SSR)
- ELSE IF(IDPDG1.EQ.990) THEN
- ALPHA1 = PARMDL(74)
- ENDIF
- IF(IDPDG2.EQ.22) THEN
- ALPHA2 = pho_alphae(SSR)
- ELSE IF(IDPDG2.EQ.990) THEN
- ALPHA2 = PARMDL(74)
- ENDIF
- PDS = 1.D0
- ELSE
- WRITE(LO,'(/1X,A,I4)')
- & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
- CALL PHO_ABORT
- ENDIF
-
-C complete weight
- FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
-
-C debug output
- IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
- & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
- & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
-
- END
-
-CDECK ID>, PHO_HARSCA
- SUBROUTINE PHO_HARSCA(IMODE,IP)
-C***********************************************************************
-C
-C PHO_HARSCA determines the type of hard subprocess, the partons
-C taking part in this subprocess and the kinematic variables
-C
-C input: IMODE 1 direct processes
-C 2 resolved processes
-C -1 initialization
-C -2 output of statistics
-C IP 1-4 particle combination (hadron/photon)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER( EPS = 1.D-10,
- & DEPS = 1.D-30 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- 111 CONTINUE
-
-C resolved processes
- IF(IMODE.EQ.2) THEN
-
- MH_pro_on(0,IP) = 0
- HWgx(9) = 0.D0
- DO 15 M=-1,8
- IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
- 15 CONTINUE
- IF(HWgx(9).LT.DEPS) THEN
- WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
- & 'no resolved process possible for IP',IP,HWgx(9)
- CALL PHO_ABORT
- ENDIF
-C
-C ----------------------------------------------I
-C begin of iteration loop (resolved processes) I
-C I
- IREJSC = 0
- 10 CONTINUE
- IREJSC = IREJSC+1
- IF(IREJSC.GT.1000) THEN
- WRITE(LO,'(/1X,A,I10)')
- & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
- CALL PHO_ABORT
- ENDIF
-
-C find subprocess
- B = DT_RNDM(X1)*HWgx(9)
- MSPR =-2
- SUM = 0.D0
- 20 MSPR = MSPR+1
- IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
- IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
-
- IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
- & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
-
-C find kin. variables X1,X2 and V
- CALL PHO_HARKIN(IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(29) = IFAIL(29)+1
- GOTO 10
- ENDIF
-C calculate remaining distribution
- CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
-C actualize counter for cross-section calculation
- if(F.LE.1.D-15) then
- F = 0.D0
- goto 10
- endif
-* XSECT(5,MSPR) = XSECT(5,MSPR)+F
-* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
- MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
-C check F against FMAX
- WEIGHT = F/(HWgx(MSPR)+DEPS)
- IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
-C-------------------------------------------------------------------
- IF(WEIGHT.GT.1.D0) THEN
- WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
- 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
- & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
- WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
- & ECMP,PTWANT,AS,AH,PT
- WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
- & ETAC,ETAD,X1,X2,V
- CALL PHO_PREVNT(-1)
- ENDIF
-C-------------------------------------------------------------------
-C I
-C end of iteration loop (resolved processes) I
-C --------------------------------------------I
-C
-C*********************************************************************
-C
-C direct processes
-
- ELSE IF(IMODE.EQ.1) THEN
-
-C single-resolved processes kinematically forbidden
- if(Z1DIF.lt.0.D0) then
- HWgx(10) = 0.D0
- HWgx(11) = 0.D0
- HWgx(12) = 0.D0
- HWgx(13) = 0.D0
- endif
-
- HWgx(15) = 0.D0
- if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
- DO M= 10,14
- IF(MH_pro_on(M,IP).EQ.1) then
- if((M.eq.10).or.(M.eq.11)) then
- fac = FSUH(1)*FSUP(2)
- else if((M.eq.12).or.(M.eq.13)) then
- fac = FSUP(1)*FSUH(2)
- else
- fac = FSUH(1)*FSUH(2)
- endif
- HWgx(15) = HWgx(15)+HWgx(M)*fac
- endif
- ENDDO
- else
- DO M= 10,14
- IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
- ENDDO
- endif
- IF(HWgx(15).LT.DEPS) THEN
- WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
- & 'no direct/single-resolved process possible (IP)',IP
- CALL PHO_ABORT
- ENDIF
-C
-C ----------------------------------------------I
-C begin of iteration loop (direct processes) I
-C I
- IREJSC = 0
- 100 CONTINUE
- IREJSC = IREJSC+1
- IF(IREJSC.GT.1000) THEN
- WRITE(LO,'(/1X,A,I10)')
- & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
- CALL PHO_ABORT
- ENDIF
-
-C find subprocess
- B = DT_RNDM(X1)*HWgx(15)
- MSPR = 9
- SUM = 0.D0
- if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
- 150 continue
- MSPR = MSPR+1
- IF(MH_pro_on(MSPR,IP).EQ.1) then
- if((MSPR.eq.10).or.(MSPR.eq.11)) then
- fac = FSUH(1)*FSUP(2)
- else if((MSPR.eq.12).or.(MSPR.eq.13)) then
- fac = FSUP(1)*FSUH(2)
- else
- fac = FSUH(1)*FSUH(2)
- endif
- SUM = SUM+HWgx(MSPR)*fac
- endif
- IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
- else
- 200 continue
- MSPR = MSPR+1
- IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
- IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
- endif
-
- IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
- & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
-
-C find kin. variables X1,X2 and V
- CALL PHO_HARKIN(IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(28) = IFAIL(28)+1
- GOTO 100
- ENDIF
-
-C calculate remaining distribution
- CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
-
-C counter for cross-section calculation
- if(F.LE.1.D-15) then
- F=0.D0
- goto 100
- endif
-* XSECT(5,MSPR) = XSECT(5,MSPR)+F
-* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
- MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
-C check F against FMAX
- WEIGHT = F/(HWgx(MSPR)+DEPS)
- IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
-C-------------------------------------------------------------------
- IF(WEIGHT.GT.1.D0) THEN
- WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
- 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
- & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
- WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
- & ECMP,PTWANT,AS,AH,PT
- WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
- & ETAC,ETAD,X1,X2,V
- CALL PHO_PREVNT(-1)
- ENDIF
-C-------------------------------------------------------------------
-C I
-C end of iteration loop (direct processes) I
-C --------------------------------------------I
-
- ELSE IF(IMODE.EQ.-1) THEN
-
-C initialize cross section calculations
-
- DO 40 M=-1,Max_pro_2
-* DO 30 I=5,6
-* XSECT(I,M) = 0.D0
-*30 CONTINUE
-C reset counters
- DO 35 J=1,4
- MH_tried(M,J) = 0
- MH_acc_1(M,J) = 0
- MH_acc_2(M,J) = 0
- 35 CONTINUE
- 40 CONTINUE
- IF(IDEB(78).GE.0) THEN
-C *** Commented by Chiara
-C WRITE(LO,'(/1X,A,/1X,A)')
-C & 'PHO_HARSCA: activated hard processes',
-C & '------------------------------------'
-C WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
- DO 42 M=1,Max_pro_2
-C WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
-C & (MH_pro_on(M,J),J=1,4)
- 42 CONTINUE
- ENDIF
- RETURN
-
- ELSE IF(IMODE.EQ.-2) THEN
-
-C calculation of process statistics
-
- do K=1,4
-
- MH_tried(0,K) = 0
- MH_acc_1(0,K) = 0
- MH_acc_2(0,K) = 0
- MH_tried(9,K) = 0
- MH_acc_1(9,K) = 0
- MH_acc_2(9,K) = 0
- MH_tried(15,K) = 0
- MH_acc_1(15,K) = 0
- MH_acc_2(15,K) = 0
-
- MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
- MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
- MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
-
- do M=1,8
- MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
- MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
- MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
- enddo
- do M=10,14
- MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
- MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
- MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
- enddo
- MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
- MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
- MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
- enddo
-
- IF(IDEB(78).GE.1) THEN
- WRITE(LO,'(/1X,A,/1X,A)')
- & 'PHO_HARSCA: internal rejection statistics',
- & '-----------------------------------------'
- do K=1,4
- IF(MH_tried(0,K).GT.0) THEN
- WRITE(LO,'(5X,A,I3)')
- & 'process (sampled/accepted) for IP:',K
- do M=0,Max_pro_2
- WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
- & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
- & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
- enddo
- ENDIF
- enddo
- ENDIF
- RETURN
-
- ELSE
- WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
- & 'unsupported mode',IMODE
- CALL PHO_ABORT
- ENDIF
-
-C the event is accepted now
-C actualize counter for accepted events
- MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
- IF(MSPR.EQ.-1) MSPR = 3
-C
-C find flavor of initial partons
-C
- SUM = 0.D0
- SCHECK = DT_RNDM(SUM)*PDS-EPS
- IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
- IA = 0
- IB = 0
- ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
- DO 610 IA=-NF,NF
- IF ( IA.EQ.0 ) GOTO 610
- SUM = SUM+PDF1(IA)*PDF2(-IA)
- IF ( SUM.GE.SCHECK ) GOTO 620
- 610 CONTINUE
- 620 IB =-IA
- ELSEIF ( MSPR.EQ.3 ) THEN
- IB = 0
- DO 630 IA=-NF,NF
- IF ( IA.EQ.0 ) GOTO 630
- SUM = SUM+PDF1(0)*PDF2(IA)
- IF ( SUM.GE.SCHECK ) GOTO 640
- SUM = SUM+PDF1(IA)*PDF2(0)
- IF ( SUM.GE.SCHECK ) GOTO 650
- 630 CONTINUE
- 640 IB = IA
- IA = 0
- 650 CONTINUE
- ELSEIF ( MSPR.EQ.7 ) THEN
- DO 660 IA=-NF,NF
- IF ( IA.EQ.0 ) GOTO 660
- SUM = SUM+PDF1(IA)*PDF2(IA)
- IF ( SUM.GE.SCHECK ) GOTO 670
- 660 CONTINUE
- 670 IB = IA
- ELSEIF ( MSPR.EQ.8 ) THEN
- DO 690 IA=-NF,NF
- IF ( IA.EQ.0 ) GOTO 690
- DO 680 IB=-NF,NF
- IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
- SUM = SUM+PDF1(IA)*PDF2(IB)
- IF ( SUM.GE.SCHECK ) GOTO 700
- 680 CONTINUE
- 690 CONTINUE
- 700 CONTINUE
- ELSEIF ( MSPR.EQ.10 ) THEN
- IA = 0
- DO 710 IB=-NF,NF
- IF ( IB.NE.0 ) THEN
- IF(IDPDG1.EQ.22) THEN
-* IF(MOD(ABS(IB),2).EQ.0) THEN
-* SUM = SUM+PDF2(IB)*4.D0/9.D0
-* ELSE
-* SUM = SUM+PDF2(IB)*1.D0/9.D0
-* ENDIF
- SUM = SUM+PDF2(IB)*Q_ch2(IB)
- ELSE
- SUM = SUM+PDF2(IB)
- ENDIF
- IF ( SUM.GE.SCHECK ) GOTO 720
- ENDIF
- 710 CONTINUE
- 720 CONTINUE
- ELSEIF ( MSPR.EQ.12 ) THEN
- IB = 0
- DO 810 IA=-NF,NF
- IF ( IA.NE.0 ) THEN
- IF(IDPDG2.EQ.22) THEN
-* IF(MOD(ABS(IA),2).EQ.0) THEN
-* SUM = SUM+PDF1(IA)*4.D0/9.D0
-* ELSE
-* SUM = SUM+PDF1(IA)*1.D0/9.D0
-* ENDIF
- SUM = SUM+PDF1(IA)*Q_ch2(IA)
- ELSE
- SUM = SUM+PDF1(IA)
- ENDIF
- IF ( SUM.GE.SCHECK ) GOTO 820
- ENDIF
- 810 CONTINUE
- 820 CONTINUE
- ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
- IA = 0
- IB = 0
- ENDIF
-C final check
- IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
- print LO,'PHO_HARSCA: rejection, final check IA,IB',IA,IB
- print LO,'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
- GOTO 111
- ENDIF
-C
-C find flavour of final partons
-C
- IC = IA
- ID = IB
- IF ( MSPR.EQ.2 ) THEN
- IC = 0
- ID = 0
- ELSEIF ( MSPR.EQ.4 ) THEN
- IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
- IF ( IC.GT.NF ) IC = NF-IC
- ID =-IC
- ELSEIF ( MSPR.EQ.6 ) THEN
- IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
- IF ( IC.GT.NF-1 ) IC = NF-1-IC
- IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
- ID =-IC
- ELSEIF ( MSPR.EQ.11) THEN
- SUM = 0.D0
- DO 730 IC=-NF,NF
- IF ( IC.NE.0 ) THEN
- IF(IDPDG1.EQ.22) THEN
-* IF(MOD(ABS(IC),2).EQ.0) THEN
-* SUM = SUM + 4.D0
-* ELSE
-* SUM = SUM + 1.D0
-* ENDIF
- SUM = SUM + Q_ch2(IC)
- ELSE
- SUM = SUM + 1.D0
- ENDIF
- ENDIF
- 730 CONTINUE
- SCHECK = DT_RNDM(SUM)*SUM-EPS
- SUM = 0.D0
- DO 740 IC=-NF,NF
- IF ( IC.NE.0 ) THEN
- IF(IDPDG1.EQ.22) THEN
-* IF(MOD(ABS(IC),2).EQ.0) THEN
-* SUM = SUM + 4.D0
-* ELSE
-* SUM = SUM + 1.D0
-* ENDIF
- SUM = SUM + Q_ch2(IC)
- ELSE
- SUM = SUM + 1.D0
- ENDIF
- IF ( SUM.GE.SCHECK ) GOTO 750
- ENDIF
- 740 CONTINUE
- 750 CONTINUE
- ID = -IC
- ELSEIF ( MSPR.EQ.12) THEN
- IC = 0
- ID = IA
- ELSEIF ( MSPR.EQ.13) THEN
- SUM = 0.D0
- DO 830 IC=-NF,NF
- IF ( IC.NE.0 ) THEN
- IF(IDPDG2.EQ.22) THEN
-* IF(MOD(ABS(IC),2).EQ.0) THEN
-* SUM = SUM + 4.D0
-* ELSE
-* SUM = SUM + 1.D0
-* ENDIF
- SUM = SUM + Q_ch2(IC)
- ELSE
- SUM = SUM + 1.D0
- ENDIF
- ENDIF
- 830 CONTINUE
- SCHECK = DT_RNDM(SUM)*SUM-EPS
- SUM = 0.D0
- DO 840 IC=-NF,NF
- IF ( IC.NE.0 ) THEN
- IF(IDPDG2.EQ.22) THEN
-* IF(MOD(ABS(IC),2).EQ.0) THEN
-* SUM = SUM + 4.D0
-* ELSE
-* SUM = SUM + 1.D0
-* ENDIF
- SUM = SUM + Q_ch2(IC)
- ELSE
- SUM = SUM + 1.D0
- ENDIF
- IF ( SUM.GE.SCHECK ) GOTO 850
- ENDIF
- 840 CONTINUE
- 850 CONTINUE
- ID = -IC
- ELSEIF ( MSPR.EQ.14) THEN
- SUM = 0.D0
- DO 930 IC=1,NF
- FAC1 = 1.D0
- FAC2 = 1.D0
- IF(MOD(ABS(IC),2).EQ.0) THEN
- IF(IDPDG1.EQ.22) FAC1 = 4.D0
- IF(IDPDG2.EQ.22) FAC2 = 4.D0
- ENDIF
- SUM = SUM + FAC1*FAC2
- 930 CONTINUE
- IF(IPAMDL(64).NE.0) THEN
- IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
- ENDIF
- SCHECK = DT_RNDM(SUM)*SUM-EPS
- SUM = 0.D0
- DO 940 IC=1,NF
- FAC1 = 1.D0
- FAC2 = 1.D0
- IF(MOD(ABS(IC),2).EQ.0) THEN
- IF(IDPDG1.EQ.22) FAC1 = 4.D0
- IF(IDPDG2.EQ.22) FAC2 = 4.D0
- ENDIF
- SUM = SUM + FAC1*FAC2
- IF ( SUM.GE.SCHECK ) GOTO 950
- 940 CONTINUE
- IC = 15
- 950 CONTINUE
- ID = -IC
- IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
- ENDIF
- if(IC.eq.0) then
- XM3 = 0.D0
- else
- XM3 = PHO_PMASS(IC,3)
- endif
- if(ID.eq.0) then
- XM4 = 0.D0
- else
- XM4 = PHO_PMASS(ID,3)
- endif
- IF(ABS(IC).EQ.15) GOTO 955
-
-C valence quarks involved?
- IV1 = 0
- IF(IA.NE.0) THEN
- IF(IDPDG1.EQ.22) THEN
- CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
- IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
- ELSE
- IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
- ENDIF
- ENDIF
- IV2 = 0
- IF(IB.NE.0) THEN
- IF(IDPDG2.EQ.22) THEN
- CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
- IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
- ELSE
- IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
- ENDIF
- ENDIF
-C
-C fill event record
-C
- 955 CONTINUE
- CALL PHO_SFECFE(SINPHI,COSPHI)
- ECM2 = ECMP/2.D0
-C incoming partons
- PHI1(1) = 0.D0
- PHI1(2) = 0.D0
- PHI1(3) = ECM2*X1
- PHI1(4) = PHI1(3)
- PHI1(5) = 0.D0
- PHI2(1) = 0.D0
- PHI2(2) = 0.D0
- PHI2(3) = -ECM2*X2
- PHI2(4) = -PHI2(3)
- PHI2(5) = 0.D0
-C outgoing partons
- PHO1(1) = PT*COSPHI
- PHO1(2) = PT*SINPHI
- PHO1(3) = -ECM2*(U*X1-V*X2)
- PHO1(4) = -ECM2*(U*X1+V*X2)
- PHO1(5) = XM3
- PHO2(1) = -PHO1(1)
- PHO2(2) = -PHO1(2)
- PHO2(3) = -ECM2*(V*X1-U*X2)
- PHO2(4) = -ECM2*(V*X1+U*X2)
- PHO2(5) = XM4
-
-C convert to mass shell
- CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
- IF(IREJ.NE.0) THEN
- IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
- & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
- & PT,XM3,XM4
- GOTO 111
- ENDIF
- PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
-
-C debug output
- IF(IDEB(78).GE.20) THEN
- SHAT = X1*X2*ECMP*ECMP
- WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
- & MSPR,IA,IB,IC,ID
- WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
- WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
- WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
- WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
- WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
- WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
- ENDIF
-
- END
-
-CDECK ID>, PHO_HARFAC
- SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
-C*********************************************************************
-C
-C initialization: find scaling factors and maxima of remaining
-C weights
-C
-C input: PTCUT transverse momentum cutoff
-C ECMI cms energy
-C
-C output: Hfac(-1:Max_pro_2) field for sampling hard processes
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( MXABWT = 96 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
- DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
- DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
- & F124(-1:Max_pro_2)
- DATA F124 / 1.D0,0.D0,
- & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
- & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
-
- SS = ECMI*ECMI
- AH = (2.D0*PTCUT/ECMI)**2
- ALN = LOG(AH)
- HLN = LOG(0.5D0)
- NPOINT = NGAUIN
- CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
- DO 10 M=-1,Max_pro_2
- S1(M) = 0.D0
-10 CONTINUE
-
-C resolved processes
- DO 80 I1=1,NPOINT
- Z1 = ABSZ(I1)
- X1 = EXP(ALN*Z1)
- DO 20 M=-1,9
- S2(M) = 0.D0
-20 CONTINUE
-
- DO 60 I2=1,NPOINT
- Z2 = (1.D0-Z1)*ABSZ(I2)
- X2 = EXP(ALN*Z2)
- FAXX = AH/(X1*X2)
- W = SQRT(1.D0-FAXX)
- W1 = FAXX/(1.+W)
- WLOG = LOG(W1)
- FWW = FAXX*WLOG/W
- DO 30 M=-1,9
- S(M) = 0.D0
-30 CONTINUE
-
- DO 40 I=1,NPOINT
- Z = ABSZ(I)
- VA =-0.5D0*W1/(W1+Z*W)
- UA =-1.D0-VA
- VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
- UB =-1.D0-VB
- VC =-EXP(HLN+Z*WLOG)
- UC =-1.D0-VC
- VE =-0.5D0*(1.D0+W)+Z*W
- UE =-1.D0-VE
- S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
- & WEIG(I)
- S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
- & WEIG(I)
- S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
- S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
- & (8./27.)*UA*UA*VA)*WEIG(I)
- S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
- S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
- & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
- S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
- S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
-40 CONTINUE
- S(4) = S(2)*(9./32.)
- DO 50 M=-1,8
- S2(M) = S2(M)+S(M)*WEIG(I2)*W
-50 CONTINUE
-60 CONTINUE
- DO 70 M=-1,8
- S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
-70 CONTINUE
-80 CONTINUE
- S1(4) = S1(4)*NF
- S1(6) = S1(6)*MAX(0,NF-1)
-C
-C direct processes
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
- & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- DO 180 I1=1,NPOINT
- Z2 = ABSZ(I1)
- X2 = EXP(ALN*Z2)
- FAXX = AH/X2
- W = SQRT(1.D0-FAXX)
- W1 = FAXX/(1.D0+W)
- WLOG = LOG(W1)
- WL = LOG(FAXX/(1.D0+W)**2)
- FWW1 = FAXX*WL/ALN
- FWW2 = FAXX*WLOG/ALN
- DO 130 M=10,12
- S(M) = 0.D0
- 130 CONTINUE
-C
- DO 140 I=1,NPOINT
- Z = ABSZ(I)
- UA =-(1.D0+W)/2.D0*EXP(Z*WL)
- VA =-1.D0-UA
- VB =-EXP(HLN+Z*WLOG)
- UB =-1.D0-VB
- S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
- S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
- 140 CONTINUE
- DO 170 M=10,11
- S1(M) = S1(M)+S(M)*WEIG(I1)
- 170 CONTINUE
- 180 CONTINUE
- S1(12) = S1(10)
- S1(13) = S1(11)
-C quark charges fractions
- IF(IDPDG1.EQ.22) THEN
- CHRNF = 0.D0
- DO 100 I=1,NF
- CHRNF = CHRNF + Q_ch2(I)
- 100 CONTINUE
- S1(11) = S1(11)*CHRNF
- ELSE IF(IDPDG1.EQ.990) THEN
- S1(11) = S1(11)*NF
- ELSE
- S1(11) = 0.D0
- ENDIF
- IF(IDPDG2.EQ.22) THEN
- CHRNF = 0.D0
- DO 200 I=1,NF
- CHRNF = CHRNF + Q_ch2(I)
- 200 CONTINUE
- S1(13) = S1(13)*CHRNF
- ELSE IF(IDPDG2.EQ.990) THEN
- S1(13) = S1(13)*NF
- ELSE
- S1(13) = 0.D0
- ENDIF
- ENDIF
-C
-C global factors
- FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
- DO 90 M=-1,Max_pro_2
- Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
-90 CONTINUE
-C
-C double direct process
- IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
- & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
- FAC = 0.D0
- DO 300 I=1,NF
- IF(IDPDG1.EQ.22) THEN
- F1 = Q_ch2(I)
- ELSE
- F1 = 1.D0
- ENDIF
- IF(IDPDG2.EQ.22) THEN
- F2 = Q_ch2(I)
- ELSE
- F2 = 1.D0
- ENDIF
- FAC = FAC+F1*F2*3.D0
- 300 CONTINUE
- ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
- Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
- & *GEV2MB*FAC
- ENDIF
- END
-
-CDECK ID>, PHO_HARWGX
- SUBROUTINE PHO_HARWGX(PTCUT,ECM)
-C**********************************************************************
-C
-C find maximum of remaining weight for MC sampling
-C
-C input: PTCUT transverse momentum cutoff
-C ECM cms energy
-C
-C output: HWgx(-1:Max_pro_2) field for sampling hard processes
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( NKM = 10 )
- PARAMETER ( TINY = 1.D-20 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-
- DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
- & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
- DIMENSION IFTAB(-1:Max_pro_2)
- DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
-
-C initial settings
- AH = (2.D0*PTCUT/ECM)**2
- ALNH = LOG(AH)
- FF(0) = 0.D0
- DO 22 I=1,NKM
- FF(I) = 0.D0
- XM1(I) = 0.D0
- XM2(I) = 0.D0
- PTM(I) = 0.D0
- ZMX(1,I) = 0.D0
- ZMX(2,I) = 0.D0
- ZMX(3,I) = 0.D0
- DMX(1,I) = 0.D0
- DMX(2,I) = 0.D0
- DMX(3,I) = 0.D0
- IMX(I) = 0
- IPO(I) = 0
- 22 CONTINUE
-
- NKML = 10
- DO 40 NKON=1,NKML
-
- DO 50 IST=1,3
-C start configuration
- IF(IST.EQ.1) THEN
- Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
- Z(2) = 0.5
- Z(3) = 0.1
- D(1) =-0.5
- D(2) = 0.5
- D(3) = 0.5
- ELSE IF(IST.EQ.2) THEN
- Z(1) = 0.999D0
- Z(2) = 0.5
- Z(3) = 0.0
- D(1) =-0.5
- D(2) = 0.5
- D(3) = 0.5
- ELSE IF(IST.EQ.3) THEN
- Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
- Z(2) = 0.1
- Z(3) = 0.1
- D(1) =-0.5
- D(2) = 0.5
- D(3) = 0.5
- ELSE IF(IST.EQ.4) THEN
- Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
- Z(2) = 0.9
- Z(3) = 0.1
- D(1) =-0.5
- D(2) = 0.5
- D(3) = 0.5
- ENDIF
- IT = 0
- CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
-C process possible?
- IF(F2.LE.0.D0) GOTO 35
-
- 10 CONTINUE
- IT = IT+1
- FOLD = F2
- DO 30 I=1,3
- D(I) = D(I)/5.D0
- Z(I) = Z(I)+D(I)
- CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
- IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
- IF ( F2.GT.F3 ) D(I) =-D(I)
- 20 CONTINUE
- F1 = MIN(F2,F3)
- F2 = MAX(F2,F3)
- Z(I) = Z(I)+D(I)
- CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
- IF ( F3.GT.F2 ) GOTO 20
- ZZ = Z(I)-D(I)
- Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
- IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
- & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
- IF ( F1.LE.F2 ) Z(I) = ZZ
- F2 = MAX(F1,F2)
- 30 CONTINUE
- IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
-
- IF(F2.GT.FF(NKON)) THEN
- FF(NKON) = MAX(F2,0.D0)
- XM1(NKON) = X1
- XM2(NKON) = X2
- PTM(NKON) = PT
- ZMX(1,NKON) = Z(1)
- ZMX(2,NKON) = Z(2)
- ZMX(3,NKON) = Z(3)
- DMX(1,NKON) = D(1)
- DMX(2,NKON) = D(2)
- DMX(3,NKON) = D(3)
- IMX(NKON) = IT
- IPO(NKON) = IST
- ENDIF
-C
- 50 CONTINUE
- 35 CONTINUE
- 40 CONTINUE
-
-C debug output
- IF(IDEB(38).GE.5) THEN
- WRITE(LO,'(/1X,A)')
- & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
- DO 60 I=1,NKM
- IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
- & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
- & DMX(2,I),DMX(3,I)
- 60 CONTINUE
- ENDIF
-
- DO 70 I=-1,Max_pro_2
- HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
- 70 CONTINUE
-
-C debug output
- IF(IDEB(38).GE.5) THEN
- WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
- WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
- DO 80 I=-1,Max_pro_2
- IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
- MSPR = I
- X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
- X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
- PT = PTM(IFTAB(I))
- CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
- WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
- ENDIF
- 80 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_HARWGI
- SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
-C**********************************************************************
-C
-C auxiliary subroutine to find maximum of remaining weight
-C
-C input: ECMX current CMS energy
-C PTCUT current pt cutoff
-C NKON process label 1..5 resolved
-C 6..7 direct particle 1
-C 8..9 direct particle 2
-C 10 double direct
-C Z(3) transformed variable
-C
-C output: remaining weight
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION Z(3)
-
- PARAMETER ( NKM = 10 )
- PARAMETER ( TINY = 1.D-30,
- & TINY6 = 1.D-06 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-
- DOUBLE PRECISION PHO_ALPHAS,pho_alphae
- DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
-
- FDIS = 0.D0
-
- IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
- & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
-C check input values
- IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
- IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
- IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
-C transformations
- Y1 = EXP(ALNH*Z(1))
- IF(NKON.LE.5) THEN
-C resolved kinematic
- Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
- X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
- X2 = X1-Y2
- X1 = MIN(X1,0.999999999999D0)
- X2 = MIN(X2,0.999999999999D0)
- ELSE IF(NKON.LE.7) THEN
-C direct kinematic 1
- X1 = 1.D0
- X2 = MIN(Y1,0.999999999999D0)
- ELSE IF(NKON.LE.9) THEN
-C direct kinematic 2
- X1 = MIN(Y1,0.999999999999D0)
- X2 = 1.D0
- ELSE
-C double direct kinematic
- X1 = 1.D0
- X2 = 1.D0
- ENDIF
- W = SQRT(MAX(TINY,1.D0-AH/Y1))
- V =-0.5D0+W*(Z(3)-0.5D0)
- U =-(1.D0+V)
- PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
-
-C set hard scale QQ for alpha and partondistr.
- IF ( NQQAL.EQ.1 ) THEN
- QQAL = AQQAL*PT*PT
- ELSEIF ( NQQAL.EQ.2 ) THEN
- QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
- ELSEIF ( NQQAL.EQ.3 ) THEN
- QQAL = AQQAL*Y1*ECMX*ECMX
- ELSEIF ( NQQAL.EQ.4 ) THEN
- QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
- ENDIF
- IF ( NQQPD.EQ.1 ) THEN
- QQPD = AQQPD*PT*PT
- ELSEIF ( NQQPD.EQ.2 ) THEN
- QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
- ELSEIF ( NQQPD.EQ.3 ) THEN
- QQPD = AQQPD*Y1*ECMX*ECMX
- ELSEIF ( NQQPD.EQ.4 ) THEN
- QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
- ENDIF
-C
- IF(NKON.LE.5) THEN
- DO 10 N=1,5
- F(N) = 0.D0
- 10 CONTINUE
-C resolved processes
- ALPHA1 = PHO_ALPHAS(QQAL,3)
- ALPHA2 = ALPHA1
- CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
- CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
-C calculate full distribution FDIS
- DO 20 I=1,NF
- F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
- F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
- F(4) = F(4)+PDA(I)+PDA(-I)
- F(5) = F(5)+PDB(I)+PDB(-I)
-20 CONTINUE
- F(1) = PDA(0)*PDB(0)
- T = PDA(0)*F(5)+PDB(0)*F(4)
- F(5) = F(4)*F(5)-(F(2)+F(3))
- F(4) = T
- ELSE IF(NKON.LE.7) THEN
-C direct processes particle 1
- IF(IDPDG1.EQ.22) THEN
- ALPHA1 = pho_alphae(QQAL)
- CH1 = 4.D0/9.D0
- CH2 = 3.D0/9.D0
- ELSE IF(IDPDG1.EQ.990) THEN
- ALPHA1 = PARMDL(74)
- CH1 = 1.D0
- CH2 = 0.D0
- ELSE
- FDIS = -1.D0
- RETURN
- ENDIF
- ALPHA2 = PHO_ALPHAS(QQAL,2)
- CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
- F(6) = 0.D0
- DO 30 I=1,NF
- F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
- 30 CONTINUE
- F(7) = PDB(0)
- ELSE IF(NKON.LE.9) THEN
-C direct processes particle 2
- ALPHA1 = PHO_ALPHAS(QQAL,1)
- IF(IDPDG2.EQ.22) THEN
- ALPHA2 = pho_alphae(QQAL)
- CH1 = 4.D0/9.D0
- CH2 = 3.D0/9.D0
- ELSE IF(IDPDG2.EQ.990) THEN
- ALPHA2 = PARMDL(74)
- CH1 = 1.D0
- CH2 = 0.D0
- ELSE
- FDIS = -1.D0
- RETURN
- ENDIF
- CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
- F(8) = 0.D0
- DO 40 I=1,NF
- F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
- 40 CONTINUE
- F(9) = PDA(0)
- ELSE
-C double direct process
- SSR = ECMX*ECMX
- IF(IDPDG1.EQ.22) THEN
- ALPHA1 = pho_alphae(SSR)
- ELSE IF(IDPDG1.EQ.990) THEN
- ALPHA1 = PARMDL(74)
- ELSE
- FDIS = -1.D0
- RETURN
- ENDIF
- IF(IDPDG2.EQ.22) THEN
- ALPHA2 = pho_alphae(SSR)
- ELSE IF(IDPDG2.EQ.990) THEN
- ALPHA2 = PARMDL(74)
- ELSE
- FDIS = -1.D0
- RETURN
- ENDIF
- F(10) = 1.D0
- ENDIF
-
- FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
-
-C debug output
- IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
- & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
- & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
-
- END
-
-CDECK ID>, PHO_HARINI
- SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
-C**********************************************************************
-C
-C initialize calculation of hard cross section
-C
-C must not be called during MC generation
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-
- double precision pho_alphas
-
- CHARACTER*20 RFLAG
-
-C set local Pomeron c.m. system data
- IDPDG1 = IDP1
- IDPDG2 = IDP2
- PVIRTP(1) = PV1
- PVIRTP(2) = PV2
-C initialize PDFs
- CALL PHO_ACTPDF(IDPDG1,1)
- CALL PHO_ACTPDF(IDPDG2,2)
-C initialize alpha_s calculation
- DUMMY = PHO_ALPHAS(0.D0,-4)
-C initialize scales with defaults
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- AQQAL = PARMDL(83)
- AQQALI = PARMDL(86)
- AQQALF = PARMDL(89)
- AQQPD = PARMDL(92)
- NQQAL = IPAMDL(83)
- NQQALI = IPAMDL(86)
- NQQALF = IPAMDL(89)
- NQQPD = IPAMDL(92)
- ELSE
- AQQAL = PARMDL(82)
- AQQALI = PARMDL(85)
- AQQALF = PARMDL(88)
- AQQPD = PARMDL(91)
- NQQAL = IPAMDL(82)
- NQQALI = IPAMDL(85)
- NQQALF = IPAMDL(88)
- NQQPD = IPAMDL(91)
- ENDIF
- ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- AQQAL = PARMDL(82)
- AQQALI = PARMDL(85)
- AQQALF = PARMDL(88)
- AQQPD = PARMDL(91)
- NQQAL = IPAMDL(82)
- NQQALI = IPAMDL(85)
- NQQALF = IPAMDL(88)
- NQQPD = IPAMDL(91)
- ELSE
- AQQAL = PARMDL(81)
- AQQALI = PARMDL(84)
- AQQALF = PARMDL(87)
- AQQPD = PARMDL(90)
- NQQAL = IPAMDL(81)
- NQQALI = IPAMDL(84)
- NQQALF = IPAMDL(87)
- NQQPD = IPAMDL(90)
- ENDIF
- IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
- IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
- IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
- IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
- IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
- IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
- IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
- IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
- AQQAL = PARMDL(109+IP)
- AQQALI = PARMDL(113+IP)
- AQQALF = PARMDL(117+IP)
- AQQPD = PARMDL(121+IP)
- NQQAL = IPAMDL(64+IP)
- NQQALI = IPAMDL(68+IP)
- NQQALF = IPAMDL(72+IP)
- NQQPD = IPAMDL(76+IP)
- PTCUT(1) = PARMDL(36)
- PTCUT(2) = PARMDL(37)
- PTCUT(3) = PARMDL(38)
- PTCUT(4) = PARMDL(39)
- PTANO(1) = PARMDL(130)
- PTANO(2) = PARMDL(131)
- PTANO(3) = PARMDL(132)
- PTANO(4) = PARMDL(133)
- RFLAG = '(energy-independent)'
- IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
-
-C write out all settings
-C *** Commented by Chiara
-C IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
-C WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
-C & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
-C & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
-C & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
-C1050 FORMAT(/,
-C & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
-C & 5X,'particle 1 / particle 2:',2I8,/,
-C & 5X,'min. PT :',F7.1,2X,A,/,
-C & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
-C & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
-C & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
-C & 5X,'max. number of active flavours NF :',I3,/,
-C & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
-C ENDIF
-
- END
-
-CDECK ID>, PHO_HARINT
- SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
-C**********************************************************************
-C
-C interpolate cross sections and weights for hard scattering
-C
-C input: IPP particle combination (neg. for add. user cuts)
-C ECM CMS energy (GeV)
-C P2V1/2 particle virtualities (pos., GeV**2)
-C I1 first subprocess to calculate
-C I2 last subprocess to calculate
-C <-1 only scales and cutoffs calculated
-C K1 first variable to calculate
-C K2 last variable to calculate
-C MSPOM cross sections to use for pt distribution
-C 0 reggeon
-C >0 pomeron
-C
-C for K1 < 3 the soft pt distribution is also calculated
-C
-C output: interpolated values in HWgx, HSig, Hdpt
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-15,
- & DEPS2 = 2.D-15 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C data needed for soft-pt calculation
- DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
- COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-C parameters for DGLAP backward evolution in ISR
- INTEGER NFSISR
- DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
- COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C interpolation tables for hard cross section and MC selection weights
- INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
- PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
- INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
- DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
- & HQ2a_tab,HQ2b_tab,HEcm_tab
- COMMON /POHTAB/
- & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
- & HEcm_tab(1:Max_tab_E,0:4),
- & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
-C data on most recent hard scattering
- INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
- DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
- & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
- COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
- & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
- & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
- & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
- & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-
- DOUBLE PRECISION XP,PTS
- DIMENSION XP(2),PTS(0:2,2)
-
- INTEGER IV
- DIMENSION IV(2)
-
- IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
- & 'PHO_HARINT: called with ',
- & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
- & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
-
- IP = ABS(IPP)
- IF(IPP.GT.0) THEN
-C default minimum bias cutoff
- PTCUT(IP) = pho_ptcut(ECM,IP)
- ELSE
-C user defined additional cutoff
- PTCUT(IP) = HSWCUT(4+IP)
- ENDIF
- PTWANT = PTCUT(IP)
-
-C ISR cutoffs
- Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
- Q2MISR(1) = MAX(P2V1,Q2CUT)
- Q2MISR(2) = MAX(P2V2,Q2CUT)
-C cutoff for direct photon contribution to photon PDF
- PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
- PTA1 = PTANO(IP)
-C scales for hard scattering
- AQQAL = PARMDL(109+IP)
- AQQALI = PARMDL(113+IP)
- AQQALF = PARMDL(117+IP)
- AQQPD = PARMDL(121+IP)
- NQQAL = IPAMDL(64+IP)
- NQQALI = IPAMDL(68+IP)
- NQQALF = IPAMDL(72+IP)
- NQQPD = IPAMDL(76+IP)
- IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
- & 'PHO_HARINT: scales:',
- & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
-
- IF(I2.LT.-1) RETURN
-
- IL = IP
- IF(IPP.LT.0) IL = 0
-
-C double-log interpolation
- IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
- DO 50 M=I1,I2
- Hfac(M) = 0.D0
- HWgx(M) = 0.D0
- HSig(M) = 0.D0
- Hdpt(M) = 0.D0
- 50 CONTINUE
- ELSE
- I=1
- 310 CONTINUE
- I = I+1
- IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
-
- Ia = 1
- Ib = 1
- fac = LOG(ECM/HEcm_tab(I-1,IL))
- & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
- do M=I1,I2
-C factor due to phase space integration
- XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
- & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
- & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
- XX = EXP(XX)
- IF(XX.LT.DEPS2) XX = 0.D0
- Hfac(M) = XX
-C max. weight
- XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
- & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
- & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
- XX = EXP(XX)
- IF(XX.LT.DEPS2) XX = 0.D0
- HWgx(M) = XX*1.2D0
-C hard cross section
- XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
- & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
- & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
- XX = EXP(XX)
- IF(XX.LT.DEPS2) XX = 0.D0
- HSig(M) = XX
-C differential hard cross section
- XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
- & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
- & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
- XX = EXP(XX)
- IF(XX.LT.DEPS2) XX = 0.D0
- Hdpt(M) = XX
- enddo
- ENDIF
-
- IF((K1.LT.3).AND.(K2.GE.3)) THEN
-C cross check
- IF((I1.GT.9).OR.(I2.LT.9)) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
- & 'hard cross section not calculated ',I1,I2
- ENDIF
- SIGH = HSig(9)
- DSIGHP = Hdpt(9)
-C load soft cross sections from interpolation table
- IF(ECM.LE.SIGECM(IP,1)) THEN
- L1 = 1
- L2 = 1
- ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
- DO 55 I=2,ISIMAX
- IF(ECM.LE.SIGECM(IP,I)) GOTO 205
- 55 CONTINUE
- 205 CONTINUE
- L1 = I-1
- L2 = I
- ELSE
- WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
- & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
- & IP,ECM,SIGECM(IP,ISIMAX)
- CALL PHO_PREVNT(-1)
- L1 = ISIMAX-1
- L2 = ISIMAX
- ENDIF
- FAC2=0.D0
- IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
- & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
- FAC1=1.D0-FAC2
- SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
- & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
-
- FS = FPS(IP)
- FH = FPH(IP)
- CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
- ENDIF
-
- 300 CONTINUE
-
-C debug output
- IF(IDEB(58).GE.15) THEN
- WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
- & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
- & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
- DO 162 M=I1,I2
- WRITE(LO,'(5X,2I3,1p,4E12.3)')
- & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
- 162 CONTINUE
- ENDIF
-
- END
-
- DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
-C***********************************************************************
-C
-C calculate energy-dependent transverse momentum cutoff
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- double precision ECM
- integer IP
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
- pho_ptcut = PARMDL(35+IP)
-
- IF(IPAMDL(7).EQ.1) THEN
-C Bopp et al. type (DPMJET)
- pho_ptcut = PARMDL(35+IP)
- & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
- ELSE IF(IPAMDL(7).EQ.2) THEN
-C Gribov-Levin-Ryskin type
- pho_ptcut = PARMDL(35+IP)
- & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
- ENDIF
-
- END
-
-CDECK ID>, PHO_HARMCI
- SUBROUTINE PHO_HARMCI(IP,EMAXF)
-C**********************************************************************
-C
-C initialize MC sampling and calculate hard cross section
-C
-C input: IP particle combination (neg. number for user cut)
-C EMAXF maximum CMS energy for
-C interpolation table in reference to PTCUT(1..4)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (DEPS = 1.D-10,
- & PLARGE = 1.D20 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C names of hard scattering processes
- INTEGER Max_pro_1
- PARAMETER ( Max_pro_1 = 16 )
- CHARACTER*18 PROC
- COMMON /POHPRO/ PROC(0:Max_pro_1)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C interpolation tables for hard cross section and MC selection weights
- INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
- PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
- INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
- DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
- & HQ2a_tab,HQ2b_tab,HEcm_tab
- COMMON /POHTAB/
- & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
- & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
- & HEcm_tab(1:Max_tab_E,0:4),
- & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- COMPLEX*16 DSIG
- DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
-
-C initialization for all pt cutoffs
- I = ABS(IP)
- IL = I
- IF(IP.LT.0) THEN
- IL = 0
- PTC = HSWCUT(4+I)
- else
- PTC = pho_ptcut(parmdl(19),I)
- ENDIF
-
-C skip unassigned PTCUT
- IF(PTC.LT.0.5D0) GOTO 1000
-
- IH_Q2a_up(I) = 1
- IH_Q2b_up(I) = 1
- do ib=1,Max_tab_Q2
- do ia=1,Max_tab_Q2
- do ie=1,Max_tab_E
- do m=-1,Max_pro_2
- Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
- HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
- HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
- Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
- enddo
- enddo
- enddo
- enddo
-
- ELLOW = LOG(2.05*PTC)
- DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
-C energy too low
- IF(DELTA.LE.0.D0) GOTO 1000
-
-C switch between external particles and Pomeron
- IF(I.EQ.4) THEN
- IDP1 = 990
- PV1 = 0.D0
- IDP2 = 990
- PV2 = 0.D0
- ELSE IF(I.EQ.3) THEN
- IDP1 = IFPAP(2)
- PV1 = PVIRT(2)
- IDP2 = 990
- PV2 = 0.D0
- ELSE IF(I.EQ.2) THEN
- IDP1 = IFPAP(1)
- PV1 = PVIRT(1)
- IDP2 = 990
- PV2 = 0.D0
- ELSE
- IDP1 = IFPAP(1)
- PV1 = PVIRT(1)
- IDP2 = IFPAP(2)
- PV2 = PVIRT(2)
- ENDIF
-
-C initialize PT scales
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- FPS(I) = PARMDL(105)
- FPH(I) = PARMDL(106)
- ELSE
- FPS(I) = PARMDL(103)
- FPH(I) = PARMDL(104)
- ENDIF
- ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- FPS(I) = PARMDL(103)
- FPH(I) = PARMDL(104)
- ELSE
- FPS(I) = PARMDL(101)
- FPH(I) = PARMDL(102)
- ENDIF
-
-C initialize hard scattering
- IF(IP.GT.0) THEN
- CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
- ELSE
- CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
- ENDIF
-
-C energy/virtuality grid
- do Ie=1,IH_Ecm_up(IL)
- HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
- enddo
- do Ia=1,IH_Q2a_up(IL)
- HQ2a_tab(Ia,IL) = 0.D0
- enddo
- do Ib=1,IH_Q2b_up(IL)
- HQ2b_tab(Ib,IL) = 0.D0
- enddo
-
-C initialization for several energies and particle virtualities
- do Ie=1,IH_Ecm_up(IL)
- do Ia=1,IH_Q2a_up(IL)
- do Ib=1,IH_Q2b_up(IL)
-
- EE = HEcm_tab(IE,IL)
- Q2a = HQ2a_tab(Ia,IL)
- Q2b = HQ2b_tab(Ib,IL)
- CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
- IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
- & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
- & PTCUT(I),EE,IDPDG1,IDPDG2
- Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
- CALL PHO_HARFAC(PTCUT(I),EE)
- CALL PHO_HARWGX(PTCUT(I),EE)
- CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
- IF(IDEB(8).GE.10) THEN
- WRITE(LO,'(1X,A,/,1X,A)')
- & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
- & '------------------------------------------------'
- DO M=0,Max_pro_2
- WRITE(LO,'(10X,A,1P2E14.4)')
- & PROC(M),DREAL(DSIG(M)),DSPT(M)
- ENDDO
- ENDIF
-
-C store in interpolation tables
- Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
- HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
- do M=0,Max_pro_2
- Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
- HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
- HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
- Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
- enddo
-
-C summed quantities
- HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
- Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
- do M=1,8
- IF(MH_pro_on(M,I).GT.0) THEN
- HSig_tab(9,IE,Ia,Ib,IL) =
- & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
- Hdpt_tab(9,IE,Ia,Ib,IL) =
- & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
- ENDIF
- enddo
- HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
- Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
- do M=10,14
- IF(MH_pro_on(M,I).GT.0) THEN
- HSig_tab(15,IE,Ia,Ib,IL) =
- & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
- Hdpt_tab(15,IE,Ia,Ib,IL) =
- & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
- ENDIF
- enddo
- HSig_tab(0,IE,Ia,Ib,IL) =
- & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
- Hdpt_tab(0,IE,Ia,Ib,IL) =
- & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
-
- enddo
- enddo
- enddo
-
-C debug output of weights
- 1000 CONTINUE
- IF(IDEB(8).GE.5) THEN
- WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
- & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
- & IDPDG1,IDPDG2,IP,PTCUT(I),
- & '------------------------------------------'
- DO M=-1,Max_pro_2
- IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
- WRITE(LO,'(2X,A,I3,2I7)')
- & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
- & M,IDPDG1,IDPDG2
- do k=1,IH_Ecm_up(IL)
- do ia=1,IH_Q2a_up(IL)
- do ib=1,IH_Q2b_up(IL)
- WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
- & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
- & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
- & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
- enddo
- enddo
- enddo
- 512 CONTINUE
- ENDDO
- ENDIF
-
- END
-
-CDECK ID>, PHO_HARXR3
- SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
-C**********************************************************************
-C
-C differential cross section DSIG/(DETAC*DETAD*DPT)
-C
-C input: ECMH CMS energy
-C PT parton PT
-C ETAC pseudorapidity of parton C
-C ETAD pseudorapidity of parton D
-C
-C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
-
- PARAMETER ( Max_pro_2 = 16 )
- COMPLEX*16 DSIGMC
- DIMENSION DSIGMC(0:Max_pro_2)
- DIMENSION DSIGM(0:Max_pro_2)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-
- DOUBLE PRECISION PHO_ALPHAS
- DIMENSION PDA(-6:6),PDB(-6:6)
-
- DO 10 I=1,9
- DSIGMC(I) = CMPLX(0.D0,0.D0)
- DSIGM(I) = 0.D0
-10 CONTINUE
-
- EC = EXP(ETAC)
- ED = EXP(ETAD)
-C kinematic conversions
- XA = PT*(EC+ED)/ECMH
- XB = XA/(EC*ED)
- IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
- WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
- RETURN
- ENDIF
- SP = XA*XB*ECMH*ECMH
- UP =-ECMH*PT*EC*XB
- UP = UP/SP
- TP =-(1.D0+UP)
- UU = UP*UP
- TT = TP*TP
-C set hard scale QQ for alpha and partondistr.
- IF ( NQQAL.EQ.1 ) THEN
- QQAL = AQQAL*PT*PT
- ELSEIF ( NQQAL.EQ.2 ) THEN
- QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQAL.EQ.3 ) THEN
- QQAL = AQQAL*SP
- ELSEIF ( NQQAL.EQ.4 ) THEN
- QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
- IF ( NQQPD.EQ.1 ) THEN
- QQPD = AQQPD*PT*PT
- ELSEIF ( NQQPD.EQ.2 ) THEN
- QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQPD.EQ.3 ) THEN
- QQPD = AQQPD*SP
- ELSEIF ( NQQPD.EQ.4 ) THEN
- QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
-
- ALPHA = PHO_ALPHAS(QQAL,3)
- FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
-C parton distributions (times x)
- CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
- CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
- S1 = PDA(0)*PDB(0)
- S2 = 0.D0
- S3 = 0.D0
- S4 = 0.D0
- S5 = 0.D0
- DO 20 I=1,NF
- S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
- S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
- S4 = S4+PDA(I)+PDA(-I)
- S5 = S5+PDB(I)+PDB(-I)
-20 CONTINUE
-C partial cross sections (including color and symmetry factors)
-C resolved photon matrix elements (light quarks)
- DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
- DSIGM(6) = (4.D0/9.D0)*(UU+TT)
- DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
- DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
- DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
- DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
- DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
- DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
- & (8.D0/27.D0)/(UP*TP))
-C
- DSIGM(1) = FACTOR*DSIGM(1)*S1
- DSIGM(2) = FACTOR*DSIGM(2)*S2
- DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
- DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
- DSIGM(5) = FACTOR*DSIGM(5)*S2
- DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
- DSIGM(7) = FACTOR*DSIGM(7)*S3
- DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
-C complex part
- X=ABS(TP-UP)
- FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
-C
- DO 50 I=1,8
- IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
- DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
- DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
- 50 CONTINUE
- END
-
-CDECK ID>, PHO_HARXR2
- SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
-C**********************************************************************
-C
-C differential cross section DSIG/(DETAC*DPT)
-C
-C input: ECMH CMS energy
-C PT parton PT
-C ETAC pseudorapidity of parton C
-C
-C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY= 1.D-20 )
-
- PARAMETER ( Max_pro_2 = 16 )
- COMPLEX*16 DSIGMC
- DIMENSION DSIGMC(0:Max_pro_2)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-
- COMPLEX*16 DSIG1
- DIMENSION DSIG1(0:Max_pro_2)
- DIMENSION ABSZ(32),WEIG(32)
-
- DO 10 M=1,9
- DSIGMC(M) = CMPLX(0.D0,0.D0)
- DSIG1(M) = 0.D0
-10 CONTINUE
-C
- EC = EXP(ETAC)
- ARG = ECMH/PT
- IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
- EDU = LOG(ARG-EC)
- EDL =-LOG(ARG-1.D0/EC)
- NPOINT = NGAUET
- CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
- DO 30 I=1,NPOINT
- CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
- DO 20 M=1,9
- PCTRL= DREAL(DSIG1(M))/TINY
- IF( PCTRL.GE.1.D0 ) THEN
- DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
- ENDIF
-20 CONTINUE
-30 CONTINUE
- END
-
-CDECK ID>, PHO_HARXD2
- SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
-C**********************************************************************
-C
-C differential cross section DSIG/(DETAC*DPT) for direct processes
-C
-C input: ECMH CMS energy of scattering system
-C PT parton PT
-C ETAC pseudorapidity of parton C
-C
-C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( Max_pro_2 = 16 )
- COMPLEX*16 DSIGMC
- DIMENSION DSIGMC(0:Max_pro_2)
- PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DOUBLE PRECISION PHO_ALPHAS,pho_alphae
- DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
-
-* ONE32=1.D0/9.D0
-* TWO32=4.D0/9.D0
- DO 10 I=10,13
- DSIGMC(I) = CMPLX(0.D0,0.D0)
- DSIGM(I) = 0.D0
- 10 CONTINUE
- DSIGMC(15) = CMPLX(0.D0,0.D0)
- DSIGM(15) = 0.D0
-
-C direct particle 1
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
- EC = EXP(ETAC)
- ED = ECMH/PT-EC
-C kinematic conversions
- XA = 1.D0
- XB = 1.D0/(EC*ED)
- IF ( XB.GE.1.D0 ) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
- RETURN
- ENDIF
- SP = XA*XB*ECMH*ECMH
- UP =-ECMH*PT*EC*XB
- UP = UP/SP
- TP =-(1.D0+UP)
- UU = UP*UP
- TT = TP*TP
-C set hard scale QQ for alpha and partondistr.
- IF ( NQQAL.EQ.1 ) THEN
- QQAL = AQQAL*PT*PT
- ELSEIF ( NQQAL.EQ.2 ) THEN
- QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQAL.EQ.3 ) THEN
- QQAL = AQQAL*SP
- ELSEIF ( NQQAL.EQ.4 ) THEN
- QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
- IF ( NQQPD.EQ.1 ) THEN
- QQPD = AQQPD*PT*PT
- ELSEIF ( NQQPD.EQ.2 ) THEN
- QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQPD.EQ.3 ) THEN
- QQPD = AQQPD*SP
- ELSEIF ( NQQPD.EQ.4 ) THEN
- QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
-
- ALPHA2 = PHO_ALPHAS(QQAL,2)
- IF(IDPDG1.EQ.22) THEN
- ALPHA1 = pho_alphae(QQAL)
- ELSE IF(IDPDG1.EQ.990) THEN
- ALPHA1 = PARMDL(74)
- ENDIF
- FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
-C parton distribution (times x)
- CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
- S1 = PDB(0)
-C charge counting
- S2 = 0.D0
- S3 = 0.D0
- IF(IDPDG1.EQ.22) THEN
- DO 20 I=1,NF
-* IF(MOD(I,2).EQ.0) THEN
-* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
-* S3 = S3 + TWO32
-* ELSE
-* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
-* S3 = S3 + ONE32
-* ENDIF
- S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
- S3 = S3 + Q_ch2(I)
- 20 CONTINUE
- ELSE IF(IDPDG1.EQ.990) THEN
- DO 25 I=1,NF
- S2 = S2 + PDB(I)+PDB(-I)
- 25 CONTINUE
- S3 = NF
- ENDIF
-C partial cross sections (including color and symmetry factors)
-C direct photon matrix elements
- DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
- DSIGM(11) = (UU+TT)/(UP*TP)
-C
- DSIGM(10) = FACTOR*DSIGM(10)*S2
- DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
-C complex part
- X=ABS(TP-UP)
- FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
-C
- DO 50 I=10,11
- IF(DSIGM(I).LT.0.D0) THEN
- WRITE(LO,'(1X,A,I3,1P,2E12.4)')
- & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
- DSIGM(I) = 0.D0
- ENDIF
- DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
- DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
- 50 CONTINUE
- ENDIF
-C
-C direct particle 2
- IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- EC = EXP(ETAC)
- ED = 1.D0/(ECMH/PT-1.D0/EC)
-C kinematic conversions
- XA = PT*(EC+ED)/ECMH
- XB = 1.D0
- IF ( XA.GE.1.D0 ) THEN
- WRITE(LO,'(/1X,A,2E12.4)')
- & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
- RETURN
- ENDIF
- SP = XA*XB*ECMH*ECMH
- UP =-ECMH*PT*EC*XB
- UP = UP/SP
- TP =-(1.D0+UP)
- UU = UP*UP
- TT = TP*TP
-C set hard scale QQ for alpha and partondistr.
- IF ( NQQAL.EQ.1 ) THEN
- QQAL = AQQAL*PT*PT
- ELSEIF ( NQQAL.EQ.2 ) THEN
- QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQAL.EQ.3 ) THEN
- QQAL = AQQAL*SP
- ELSEIF ( NQQAL.EQ.4 ) THEN
- QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
- IF ( NQQPD.EQ.1 ) THEN
- QQPD = AQQPD*PT*PT
- ELSEIF ( NQQPD.EQ.2 ) THEN
- QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
- ELSEIF ( NQQPD.EQ.3 ) THEN
- QQPD = AQQPD*SP
- ELSEIF ( NQQPD.EQ.4 ) THEN
- QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
- ENDIF
-
- ALPHA1 = PHO_ALPHAS(QQAL,1)
- IF(IDPDG2.EQ.22) THEN
- ALPHA2 = pho_alphae(QQAL)
- ELSE IF(IDPDG2.EQ.990) THEN
- ALPHA2 = PARMDL(74)
- ENDIF
- FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
-C parton distribution (times x)
- CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
- S1 = PDA(0)
-C charge counting
- S2 = 0.D0
- S3 = 0.D0
- IF(IDPDG2.EQ.22) THEN
- DO 70 I=1,NF
-* IF(MOD(I,2).EQ.0) THEN
-* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
-* S3 = S3 + TWO32
-* ELSE
-* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
-* S3 = S3 + ONE32
-* ENDIF
- S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
- S3 = S3 + Q_ch2(I)
- 70 CONTINUE
- ELSE IF(IDPDG2.EQ.990) THEN
- DO 75 I=1,NF
- S2 = S2 + PDA(I)+PDA(-I)
- 75 CONTINUE
- S3 = NF
- ENDIF
-C partial cross sections (including color and symmetry factors)
-C direct photon matrix elements
- DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
- DSIGM(13) = (UU+TT)/(UP*TP)
-C
- DSIGM(12) = FACTOR*DSIGM(12)*S2
- DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
-C complex part
- X=ABS(TP-UP)
- FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
-C
- DO 80 I=12,13
- IF(DSIGM(I).LT.0.D0) THEN
- WRITE(LO,'(1X,A,I3,1P,2E12.4)')
- & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
- DSIGM(I) = 0.D0
- ENDIF
- DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
- DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
- 80 CONTINUE
- ENDIF
- END
-
-CDECK ID>, PHO_HARXPT
- SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
-C**********************************************************************
-C
-C differential cross section DSIG/DPT
-C
-C input: ECMH CMS energy of scattering system
-C PT parton PT
-C IPRO 1 resolved processes
-C 2 direct processes
-C 3 resolved and direct processes
-C
-C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( Max_pro_2 = 16 )
- COMPLEX*16 DSIGMC
- DIMENSION DSIGMC(0:Max_pro_2)
- PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-
- double precision pho_alphae
-
- COMPLEX*16 DSIG1
- DIMENSION DSIG1(0:Max_pro_2)
- DIMENSION ABSZ(32),WEIG(32)
-
- DO 10 M=0,Max_pro_2
- DSIGMC(M) = CMPLX(0.D0,0.D0)
- DSIG1(M) = CMPLX(0.D0,0.D0)
- 10 CONTINUE
-
-C resolved and direct processes
- AMT = 2.D0*PT/ECMH
- IF ( AMT.GE.1.D0 ) RETURN
- ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
- ECL = -ECU
- NPOINT = NGAUET
- CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
- DO 30 I=1,NPOINT
- DSIG1(9) = CMPLX(0.D0,0.D0)
- DSIG1(15) = CMPLX(0.D0,0.D0)
- IF(IPRO.EQ.1) THEN
- CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
- ELSE IF(IPRO.EQ.2) THEN
- CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
- ELSE
- CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
- CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
- ENDIF
- DO 20 M=1,Max_pro_2
- DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
- 20 CONTINUE
- 30 CONTINUE
-
-C direct processes
- IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
- & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
- FAC = 0.D0
- SS = ECMH*ECMH
- ALPHAE = pho_alphae(SS)
- DO 300 I=1,NF
- IF(IDPDG1.EQ.22) THEN
-* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
- F1 = Q_ch2(I)*ALPHAE
- ELSE
- F1 = PARMDL(74)
- ENDIF
- IF(IDPDG2.EQ.22) THEN
-* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
- F2 = Q_ch2(I)*ALPHAE
- ELSE
- F2 = PARMDL(74)
- ENDIF
- FAC = FAC+F1*F2*3.D0
- 300 CONTINUE
-C direct cross sections
- ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
- T1 = -SS/2.D0*(1.D0+ZZ)
- T2 = -SS/2.D0*(1.D0-ZZ)
- XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
-C hadronic part
- DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
-
-C leptonic part (e, mu, tau)
- DSIGMC(16) = 0.D0
- IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
- DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
-C simulation of tau together with quarks
- IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
- ENDIF
- ENDIF
-
- DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
- DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
-
- END
-
-CDECK ID>, PHO_HARXTO
- SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
-C**********************************************************************
-C
-C total hard cross section (perturbative QCD, Parton Model)
-C
-C input: ECMH CMS energy of scattering system
-C PTCUTR PT cutoff for resolved processes
-C PTCUTD PT cutoff for direct processes (photon, Pomeron)
-C
-C output: DSIGMC(0:MARPR2) cross sections for given cutoff
-C DSDPTC(0:MARPR2) differential cross sections at cutoff
-C
-C note: COMPLEX*16 DSIGMC
-C DOUBLE PRECISION DSDPTC
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( Max_pro_2 = 16 )
- COMPLEX*16 DSIGMC
- DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C integration precision for hard cross sections (obsolete)
- INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
- COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-
- double precision pho_alphae
-
- COMPLEX*16 DSIG1
- DIMENSION DSIG1(0:Max_pro_2)
- DIMENSION ABSZ(32),WEIG(32)
-
- DATA FAC / 3.0D0 /
-
- DO 10 M=0,Max_pro_2
- DSIGMC(M)= CMPLX(0.D0,0.D0)
- 10 CONTINUE
- EEC=ECMH/2.001D0
-C
- IF ( PTCUTR.GE.EEC ) GOTO 100
-C
-C integration for resolved processes
- PTMIN = PTCUTR
- PTMAX = MIN(FAC*PTMIN,EEC)
- NPOINT = NGAUP1
- CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
- DO 60 M=1,9
- DSDPTC(M) = DREAL(DSIG1(M))
- 60 CONTINUE
- DSIGH = DREAL(DSIG1(9))
- PTMXX = 0.95D0*PTMAX
- CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
- DSIGL = DREAL(DSIG1(9))
- EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
- EX1 = 1.0D0-EX
- DO 50 K=1,2
- IF ( PTMIN.GE.PTMAX ) GOTO 40
- RL = PTMIN**EX1
- RU = PTMAX**EX1
- CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
- DO 30 I=1,NPOINT
- R = ABSZ(I)
- PT = R**(1.0D0/EX1)
- CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
- F = WEIG(I)*PT/(R*EX1)
- DO 20 M=1,9
- DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
- 20 CONTINUE
- 30 CONTINUE
- 40 PTMIN = PTMAX
- PTMAX = EEC
- NPOINT = NGAUP2
- 50 CONTINUE
- 100 CONTINUE
- DSIGMC(0) = DSIGMC(9)
- DSDPTC(0) = DSDPTC(9)
-C
-C integration for direct processes
- IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
-C
- IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
- & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
- PTMIN = PTCUTD
- PTMAX = MIN(FAC*PTMIN,EEC)
- NPOINT = NGAUP1
- CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
- IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
- DO 160 M=10,16
- DSDPTC(M) = DREAL(DSIG1(M))
- 160 CONTINUE
- DSIGH = DREAL(DSIG1(15)-DSIG1(14))
- PTMXX = 0.95D0*PTMAX
- CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
- DSIGL = DREAL(DSIG1(15)-DSIG1(14))
- EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
- EX1 = 1.0D0-EX
- DO 150 K=1,2
- IF ( PTMIN.GE.PTMAX ) GOTO 140
- RL = PTMIN**EX1
- RU = PTMAX**EX1
- CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
- DO 130 I=1,NPOINT
- R = ABSZ(I)
- PT = R**(1.0D0/EX1)
- CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
- F = WEIG(I)*PT/(R*EX1)
- DO 120 M=10,15
- DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
- 120 CONTINUE
- 130 CONTINUE
- 140 PTMIN = PTMAX
- PTMAX = EEC
- NPOINT = NGAUP2
- 150 CONTINUE
- ENDIF
-C
- 170 CONTINUE
-C
-C double direct process
- IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
- & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
- FACC = 0.D0
- SS = ECMH*ECMH
- ALPHAE = pho_alphae(SS)
- DO 300 I=1,NF
- IF(IDPDG1.EQ.22) THEN
-* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
- F1 = Q_ch2(I)*ALPHAE
- ELSE
- F1 = PARMDL(74)
- ENDIF
- IF(IDPDG2.EQ.22) THEN
-* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
- F2 = Q_ch2(I)*ALPHAE
- ELSE
- F2 = PARMDL(74)
- ENDIF
- FACC = FACC + F1*F2*3.D0
- 300 CONTINUE
-
- ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
- R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
-C hadronic cross section
- DSIGMC(14) = R*FACC*AKFAC
-C leptonic cross section
- IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
- DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
-C simulation of tau together with quarks
- IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
- DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
- ELSE
- DSIGMC(16) = CMPLX(0.D0,0.D0)
- ENDIF
-C sum of direct part
- DSIGMC(15) = CMPLX(0.D0,0.D0)
- DO 400 I=10,14
- DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
- 400 CONTINUE
- ENDIF
-C total sum (hadronic)
- DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
- DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
-
- END
-
-CDECK ID>, PHO_HARISR
- SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
- & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
-C********************************************************************
-C
-C initial state radiation according to DGLAP evolution equations
-C (backward evolution, no spin effects)
-C
-C input: IHPOM index of hard Pomeron
-C negative: delete all previous entries
-C P1,P2 4 momenta of hard scattered final partons
-C (in CMS of hard scattering)
-C IPF1,2 flavours of final partons
-C IPA1,2 flavours of initial partons
-C IV1,2 valence quark labels (0/1)
-C Q2H momentum transfer (squared, positive)
-C XH1,XH2 x values of initial partons
-C XHMAX1,2 max. x values allowed
-C
-C output: all emitted partons in /POPISR/, final state
-C partons are the first two entries
-C shower evolution traced in /PODGL1/
-C IPB1,2 flavours of new initial partons
-C XISR1,2 x values of new initial partons
-C IVO1,2 valence quark labels (0/1)
-C
-C attention: quark numbering according to PDG convention,
-C but 0 for gluons
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (RHOMAS = 0.766D0,
- & DEPS = 1.D-10,
- & TINY = 1.D-10)
-
- DIMENSION P1(4),P2(4)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C data of c.m. system of Pomeron / Reggeon exchange
- INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
- DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
- & SIDP,CODP,SIFP,COFP
- COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
- & SIDP,CODP,SIFP,COFP,NPOSP(2),
- & IDPDG1,IDBAM1,IDPDG2,IDBAM2
-C some hadron information, will be deleted in future versions
- INTEGER NFS
- DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
- COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C scale parameters for parton model calculations
- INTEGER NQQAL,NQQALI,NQQALF,NQQPD
- DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
- COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
- & NQQAL,NQQALI,NQQALF,NQQPD
-C parameters for DGLAP backward evolution in ISR
- INTEGER NFSISR
- DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
- COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
-C initial state parton radiation (internal part)
- INTEGER MXISR3,MXISR4
- PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
- INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
- DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
- COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
- & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
- & IFL1(2,MXISR3),IFL2(2,MXISR3),
- & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C particles created by initial state evolution
- INTEGER MXISR1,MXISR2
- PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
- INTEGER IFLISR,IPOISR,IMXISR
- DOUBLE PRECISION PHISR
- COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
- & IPOISR(2,2,MXISR2),IMXISR(2)
-
- DOUBLE PRECISION PYP,EER,THER,QMAXR
- INTEGER PYK
-
- DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
- & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
- & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
-
- IREJ = 0
- NTRY = 1000
- NITER = 0
-C debug output
- IF(IDEB(79).GE.10) THEN
- WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
- & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
- & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
- ENDIF
- IF(IHPOM.EQ.0) RETURN
-C
- 10 CONTINUE
- NACC = 0
- IDMO(1) = IDPDG1
- IDMO(2) = IDPDG2
-C
-C copy final state partons to local fields
- IHIDX = ABS(IHPOM)
-
- IF(IHIDX.GT.MXISR2) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
- & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
- & IHIDX,MXISR2
- IREJ = 1
- ENDIF
-
- DO 50 K=1,2
- IF(IHPOM.LT.0) IMXISR(K) = 0
- IPOISR(K,1,IHIDX) = IMXISR(K)+1
- IPAL(K) = IPOISR(K,1,IHIDX)
- 50 CONTINUE
- DO 55 I=1,4
- PHISR(1,I,IPAL(1)) = P1(I)
- PHISR(2,I,IPAL(2)) = P2(I)
- 55 CONTINUE
- IFLISR(1,IPAL(1)) = IPF1
- IFLISR(2,IPAL(2)) = IPF2
-C
-C check limitations, initialize /PODGL1/
- IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
- NEXT(1) = 1
- Q2SH(1,1) = Q2H
- ELSE
- NEXT(1) = 0
- Q2SH(1,1) = 0.D0
- ENDIF
- IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
- NEXT(2) = 1
- Q2SH(2,1) = Q2H
- ELSE
- NEXT(2) = 0
- Q2SH(2,1) = 0.D0
- ENDIF
-C
- ISH(1) = 1
- ISH(2) = 1
- XPSH(1,1) = XH1
- XPSH(2,1) = XH2
-C
- IFL1(1,1) = IPA1
- IVAL(1) = IV1
- IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
- IFL1(2,1) = IPA2
- IVAL(2) = IV2
- IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
-C
- IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
- & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
- IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
-C
-C initialize parton shower loop
- B0QCD = (33.D0-2.D0*NFSISR)/6.D0
- AL2ISR(1) = PDFLAM(1)
- AL2ISR(2) = PDFLAM(2)
- XHMA(1) = XHMAX1
- XHMA(2) = XHMAX2
- XHMI(1) = PMISR(1)/PCMP
- XHMI(2) = PMISR(2)/PCMP
- ZPSH(1,1) = 1.D0
- ZPSH(2,1) = 1.D0
- SHAT1 = XH1*XH2*ECMP**2
- IF(IPAMDL(109).EQ.1) THEN
- PT2SH(1,1) = Q2H
- ELSE
- PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
- ENDIF
- PT2SH(2,1) = PT2SH(1,1)
- IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
- IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
- THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
- THSH(2,1) = THSH(1,1)
- IFANO(1) = 0
- IFANO(2) = 0
- ZZ = 1.D0
- IF(IREJ.NE.0) GOTO 800
-C
-C main generation loop
-C -------------------------------------------------
- 100 CONTINUE
-C choose parton side to become solved
- IF((NEXT(1)+NEXT(2)).EQ.2) THEN
- IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
- IP = 1
- ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
- IP = 2
- ELSE
- IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
- ENDIF
- ELSE IF(NEXT(1).EQ.1) THEN
- IP = 1
- ELSE IF(NEXT(2).EQ.1) THEN
- IP = 2
- ELSE
- GOTO 800
- ENDIF
- INDX = ISH(IP)
-C INDX now parton position of parton to become solved
-C IP now side to be treated
- XP = XPSH(IP,INDX)
- Q2P = Q2SH(IP,INDX)
- PT2 = PT2SH(IP,INDX)
- IFLB = IFL1(IP,INDX)
-C check available x
- XMIP = XHMI(IP)
-C cutoff by x limitation: no further development
- IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
- NEXT(IP) = 0
- Q2SH(IP,INDX) = 0.D0
- IF(IDEB(79).GE.17) THEN
- WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
- & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
- & XP,XMIP,XHMA(IP),IP,INDX
- ENDIF
- GOTO 100
- ENDIF
-C initial value of evolution variable t
- TT = LOG(AQQALI*Q2P/AL2ISR(IP))
- DO 110 I=-NFSISR,NFSISR
- WGGAP(I) = 0.D0
- WGPDF(I) = 0.D0
- 110 CONTINUE
-C DGLAP weights
- ZMIN = XP/XHMA(IP)
- ZMAX = XP/(XP+XMIP)
- CF = 4./3.
-C q --> q g, g --> g g
- IF(IFLB.EQ.0) THEN
- WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
- & +2.D0*LOG(ZMAX/ZMIN))
- DO 120 I=1,NFSISR
- WGGAP(I) = WGGAP(0)
- WGGAP(-I) = WGGAP(0)
- 120 CONTINUE
- WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
- & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
-C q --> g q, g --> q qb
- ELSE IF(ABS(IFLB).LE.6) THEN
- WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
- & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
- IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
- & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
- ELSE
- WRITE(LO,'(/1X,A,I7)')
- & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
- CALL PHO_ABORT
- ENDIF
-C anomalous/resolved evolution
- IPDFC = 0
- IF(IPAMDL(110).GE.1) THEN
- IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
- & .AND.(IFLB.NE.21)) THEN
- WGDIR = 0.D0
- IF(NQQALI.EQ.1) THEN
- SCALE2 = PT2*AQQPD
- ELSE
- SCALE2 = Q2P*AQQPD
- ENDIF
- CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
- IPDFC = 1
- CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
- XI = DT_RNDM(XP)*PD1(IFLB)
- IF(WGDIR.GT.XI) THEN
-C debug output
- IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
- & 'PHO_HARISR: ',
- & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
- & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
- Q2SH(IP,INDX) = 0.D0
- NEXT(IP) = 0
- IFANO(IP) = INDX
- GOTO 100
- ENDIF
- ENDIF
- ENDIF
-C
-C rejection loop for z,t sampling
-C ------------------------------------
- 200 CONTINUE
- NITER = NITER+1
- IF(NITER.GE.NTRY) THEN
- WRITE(LO,'(1X,A,2I6)')
- & 'PHO_HARISR: too many rejections',NITER,NTRY
- CALL PHO_PREVNT(-1)
-C clean up event
- IREJ = 1
- GOTO 10
- ENDIF
-C PDF weights
- IF(IPDFC.EQ.0) THEN
- IF(NQQALI.EQ.1) THEN
- SCALE2 = PT2*AQQPD
- ELSE
- SCALE2 = Q2P*AQQPD
- ENDIF
- CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
- ENDIF
- IPDFC = 0
-C
- WGTOT = 0.D0
- DO 210 I=-NFSISR,NFSISR
- WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
- WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
- 210 CONTINUE
-C
- 215 CONTINUE
-C sample new t value
- TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
- Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
-C debug output
- IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
- & 'PHO_HARISR: pre-selected Q2:',Q2NEW
-C compare to limits
- IF(Q2NEW.LT.Q2MISR(IP)) THEN
- Q2SH(IP,INDX) = 0.D0
- NEXT(IP) = 0
- IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
- & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
- & Q2NEW,Q2MISR(IP),IP,INDX
- GOTO 100
- ENDIF
- Q2SH(IP,INDX) = Q2NEW
- TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
-C selection of flavours
- XI = WGTOT*DT_RNDM(TT)
- IFLA = -NFSISR-1
- 220 CONTINUE
- IFLA = IFLA+1
- XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
- IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
-C debug output
- IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
- & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
-C selection of z
- CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
-C debug output
- IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
- & 'PHO_HARISR: pre-selected ZZ',ZZ
-C angular ordering
- THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
- IF(THETA.GT.THSH(IP,INDX)) THEN
- IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
- & 'PHO_HARISR: reject by angle (NEW/OLD)',
- & THETA,THSH(IP,INDX)
- GOTO 215
- ENDIF
-C rejection weight given by new PDFs
- XNEW = XP/ZZ
- PT2NEW = Q2NEW*(1.D0-ZZ)
- IF(NQQALI.EQ.1) THEN
- SCALE2 = PT2NEW*AQQPD
- ELSE
- SCALE2 = Q2NEW*AQQPD
- ENDIF
- IF(SCALE2.LT.Q2MISR(IP)) THEN
- Q2SH(IP,INDX) = 0.D0
- NEXT(IP) = 0
- IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
- & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
- & Q2NEW,Q2MISR(IP),IP,INDX
- GOTO 100
- ENDIF
- CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
- IF(PD2(IFLA).LT.1.D-10) GOTO 200
- CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
- PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
- WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
- IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
- & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
- IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
- WRITE(LO,'(1X,A,E12.3)')
- & 'PHO_HARISR: final weight:',WGF
- WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
- & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
- ENDIF
- IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
-
- IF(IDEB(79).GE.15) THEN
- WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
- & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
- & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
- ENDIF
-
- IF(INDX.GE.MXISR3) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
- & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
- IREJ = 1
- RETURN
- ENDIF
-
-C branching accepted, registration
- Q2SH(IP,INDX) = Q2NEW
- PT2SH(IP,INDX) = PT2NEW
- ZPSH(IP,INDX) = ZZ
- IFL2(IP,INDX) = IFLA-IFLB
- Q2SH(IP,INDX+1) = Q2NEW
- PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
- XPSH(IP,INDX+1) = XNEW
- THSH(IP,INDX+1) = THETA
- IFL1(IP,INDX+1) = IFLA
- ISH(IP) = ISH(IP)+1
-
- NACC = NACC+1
-
- IF(NACC.GT.MXISR4) THEN
- WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
- & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
- IREJ = 1
- RETURN
- ENDIF
-
- SHAT(NACC) = SHAT1
- IBRA(1,NACC) = IP
- IBRA(2,NACC) = INDX
- SHAT1 = SHAT1/ZZ
-
-C generation of next branching
- IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
-
- 800 CONTINUE
-
-C new initial flavours, x values
- IPB1 = IFL1(1,ISH(1))
- IPB2 = IFL1(2,ISH(2))
- XISR1 = XPSH(1,ISH(1))
- XISR2 = XPSH(2,ISH(2))
- IVO1 = IVAL(1)
- IVO2 = IVAL(2)
-C valence flavours
- IF(IPB1.NE.0) THEN
- IF(ISH(1).GT.1) THEN
- CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
- IF(IDPDG1.EQ.22) THEN
- CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
- IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
- ELSE
- CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
- IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
- ENDIF
- ENDIF
- ENDIF
- IF(IPB2.NE.0) THEN
- IF(ISH(2).GT.1) THEN
- CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
- IF(IDPDG2.EQ.22) THEN
- CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
- IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
- ELSE
- IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
- ENDIF
- ENDIF
- ENDIF
-
-C parton kinematics
- IF(NACC.GT.0) THEN
-C final partons in CMS
- PM(3) = (XH1-XH2)*ECMP/2.D0
- PM(4) = (XH1+XH2)*ECMP/2.D0
- SH = XH1*XH2*ECMP**2
- SSH = SQRT(SH)
- GB(3) = PM(3)/SSH
- GB(4) = PM(4)/SSH
- CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
- & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
- & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
- CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
- & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
- & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
- IL(1) = 1
- IL(2) = 1
- DO 900 I=1,NACC
- IPA = IBRA(1,I)
- IPB = 3-IPA
- IL(IPA) = IBRA(2,I)
-C new initial partons in CMS
- SH = SHAT(I)
- SSH = SQRT(SH)
- SHZ = SH/ZPSH(IPA,IL(IPA))
- SSHZ = SQRT(SHZ)
- Q2(1) = Q2SH(1,IL(1))
- Q2(2) = Q2SH(2,IL(2))
- PC(1,1) = 0.D0
- PC(1,2) = 0.D0
- PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
- & /(2.D0*SSH)
- PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
- PC(2,1) = 0.D0
- PC(2,2) = 0.D0
- PC(2,3) = -PC(1,3)
- PC(2,4) = SSH-PC(1,4)
- XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
- EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
- S1 = SH+Q2(IPA)+Q2(IPB)
- S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
- R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
- R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
- IF(Q2(IPB).LT.0.1D0) THEN
- XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
- & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
- ELSE
- XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
- & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
- ENDIF
- NGEN = 1
-C max. virtuality for time-like showers
- QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
- IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
-C generate time-like parton shower
- KF = IFL2(IPA,IL(IPA))
- IF(KF.EQ.0) KF = 21
- EER = MIN(EE3-PC(IPA,4),ECMP)
- THER = 0.
-
- CALL PY1ENT(1,KF,EER,THER,THER)
- QMAXR = SQRT(QMAX)
- CALL PYSHOW(1,0,QMAXR)
-C debug output
- IF(IDEB(79).GE.25) THEN
- WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
- & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
- & EER,QMAX,XMS4M,Q2(IPA)
- CALL PYLIST(1)
- ENDIF
- NGEN = PYK(0,1)
-
- IF(NGEN.GT.1) THEN
- PJX = 0.D0
- PJY = 0.D0
- PJZ = 0.D0
- PJE = 0.D0
- KK = IPAL(IPA)
- DO 820 K=3,NGEN
-
- IF(PYK(K,1).LE.4) THEN
- KK = KK+1
-
- IF(KK.GT.MXISR1) THEN
- WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
- & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
- IREJ = 1
- RETURN
- ENDIF
-
- PHISR(IPA,1,KK) = PYP(K,1)
- PJX = PJX+PHISR(IPA,1,KK)
- PHISR(IPA,2,KK) = PYP(K,2)
- PJY = PJY+PHISR(IPA,2,KK)
- PHISR(IPA,3,KK) = PYP(K,3)
- PJZ = PJZ+PHISR(IPA,3,KK)
- PHISR(IPA,4,KK) = PYP(K,4)
- PJE = PJE+PHISR(IPA,4,KK)
- IFLISR(IPA,KK) = PYK(K,2)
-
- IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
- IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
- IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
- ENDIF
- 820 CONTINUE
- NGEN = KK-IPAL(IPA)
- XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
- PP4 = SQRT(PJE**2-XMS4)
- EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
-C debug output
- IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
- & 'PHO_HARISR: ',
- & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
- & PJE,PJX,PJY,PJZ,PP4,XMS4
- ENDIF
- ENDIF
- PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
- & /(2.D0*PC(IPA,3))
- PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
- IF(PT3.LT.0.D0) THEN
- IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
- & 'PHO_HARISR: rejection due to PT3',PT3
- GOTO 10
- ENDIF
- PT3 = SQRT(PT3)
- CALL PHO_SFECFE(SFE,CFE)
- PX3 = CFE*PT3
- PY3 = SFE*PT3
-C
- IF(NGEN.GT.1) THEN
-C time-like shower generated
- EE4 = EE3-PC(IPA,4)
- PZ4 = PZ3-PC(IPA,3)
- PP4 = SQRT(PT3**2+PZ4**2)
-C Lorentz boost
- GAM = (EE4*PJE-PP4*PJZ)/XMS4
- BEG = (PJE*PP4-EE4*PJZ)/XMS4
-C rotation angles
- CODD = PZ4/PP4
- SIDD = SQRT(PX3**2+PY3**2)/PP4
- COFD = 1.D0
- SIFD = 0.D0
- IF(PP4*SIDD.GT.1.D-5) THEN
- COFD = PX3/(SIDD*PP4)
- SIFD = PY3/(SIDD*PP4)
- ANORF = SQRT(COFD*COFD+SIFD*SIFD)
- COFD = COFD/ANORF
- SIFD = SIFD/ANORF
- ENDIF
-C copy partons back
- KK = IPAL(IPA)
- DO 830 K=1,NGEN
- KK = KK+1
- PX = PHISR(IPA,1,KK)
- PY = PHISR(IPA,2,KK)
- PZ = PHISR(IPA,3,KK)
- COH= PHISR(IPA,4,KK)
- EE = GAM*COH+BEG*PZ
- PZ = GAM*PZ +BEG*COH
- PHISR(IPA,4,KK) = EE
- CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
- & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
- 830 CONTINUE
- IPAL(IPA) = KK
- ELSE
-C no time-like shower generated
- IPAL(IPA) = IPAL(IPA)+1
- PHISR(IPA,1,IPAL(IPA)) = PX3
- PHISR(IPA,2,IPAL(IPA)) = PY3
- PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
- PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
- IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
- ENDIF
- PC(IPA,1) = PX3
- PC(IPA,2) = PY3
- PC(IPA,3) = PZ3
- PC(IPA,4) = EE3
-C boost / rotate into new CMS
- DO 842 K=1,4
- GB(K) = (PC(1,K)+PC(2,K))/SSHZ
- 842 CONTINUE
- CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
- & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
- COG= PM(3)/PTOT1
- SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
- COH=1.D0
- SIH=0.D0
- IF(PTOT1*SIG.GT.1.D-5) THEN
- COH=PM(1)/(SIG*PTOT1)
- SIH=PM(2)/(SIG*PTOT1)
- ANORF=SQRT(COH*COH+SIH*SIH)
- COH=COH/ANORF
- SIH=SIH/ANORF
- ENDIF
- DO 845 K=1,2
- DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
- CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
- & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
- & PTOT1,PM(1),PM(2),PM(3),PM(4))
- CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
- & PN(2),PN(3))
- CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
- & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
- PHISR(K,4,L) = PM(4)
- 844 CONTINUE
- 845 CONTINUE
- 900 CONTINUE
-C boost back to global CMS
- PM(3) = (XISR1-XISR2)/2.D0
- PM(4) = (XISR1+XISR2)/2.D0
- SSH = SQRT(XISR1*XISR2)
- GB(3) = PM(3)/SSH
- GB(4) = PM(4)/SSH
- DO 945 K=1,2
- DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
- CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
- & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
- & PM(2),PM(3),PM(4))
- PHISR(K,1,L) = PM(1)
- PHISR(K,2,L) = PM(2)
- PHISR(K,3,L) = PM(3)
- PHISR(K,4,L) = PM(4)
- 944 CONTINUE
- 945 CONTINUE
- ENDIF
- IPOISR(1,2,IHIDX) = IPAL(1)
- IPOISR(2,2,IHIDX) = IPAL(2)
- IMXISR(1) = IPAL(1)
- IMXISR(2) = IPAL(2)
-C
-C debug output
- IF(IDEB(79).GE.10) THEN
- WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
- & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
- IF(NACC.GT.0) THEN
- WRITE(LO,'(1X,A,2I5,/6X,A)')
- & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
- & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
- DO 600 II=1,NACC
- K = IBRA(1,II)
- I = IBRA(2,II)
- WRITE(LO,'(5X,4I5,4E11.3)')
- & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
- & ZPSH(K,I)
- 600 CONTINUE
- ENDIF
-C check of final configuration
- PX3 = 0.D0
- PY3 = 0.D0
- PZ3 = 0.D0
- EE3 = 0.D0
- IFSUM(1) = 0
- IFSUM(2) = 0
- WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
- DO 745 K=1,2
- DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
- WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
- & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
- IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
- PX3 = PX3 + PHISR(K,1,L)
- PY3 = PY3 + PHISR(K,2,L)
- PZ3 = PZ3 + PHISR(K,3,L)
- EE3 = EE3 + PHISR(K,4,L)
- 744 CONTINUE
- 745 CONTINUE
- IFSUM(1) = IFSUM(1)-IPB1
- IFSUM(2) = IFSUM(2)-IPB2
- PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
- EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
- WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
- & IFSUM,PX3,PY3,PZ3,EE3
- ENDIF
- END
-
-CDECK ID>, PHO_HARZSP
- SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
-C*********************************************************************
-C
-C sampling of z values from DGLAP kernels
-C
-C input: IFLA,IFLB parton flavours
-C NFSH flavours involved in hard processes
-C ZMIN minimal ZZ allowed
-C ZMAX maximal ZZ allowed
-C
-C output: ZZ z value
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-
- IF(ZMAX.LE.ZMIN) THEN
- WRITE(LO,'(1X,A,2E12.3)')
- & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
- CALL PHO_PREVNT(-1)
- ZZ = 0.D0
- RETURN
- ENDIF
-C
- IF(IFLB.EQ.0) THEN
- IF(IFLA.EQ.0) THEN
-C g --> g g
- C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
- C2 = (1.D0-ZMIN)/ZMIN
- 100 CONTINUE
- ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
- IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
- ELSE IF(ABS(IFLA).LE.NFSH) THEN
-C q --> q g
- C1 = ZMAX/ZMIN
- 200 CONTINUE
- ZZ = ZMIN*C1**DT_RNDM(ZMIN)
- IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
- ELSE
- GOTO 900
- ENDIF
- ELSE IF(ABS(IFLB).LE.NFSH) THEN
- IF(IFLA.EQ.0) THEN
-C g --> q qb
- C1 = ZMAX-ZMIN
- 300 CONTINUE
- ZZ = ZMIN+C1*DT_RNDM(ZMIN)
- IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
- ELSE IF(ABS(IFLA).LE.NFSH) THEN
-C q --> g q
- C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
- C2 = 1.D0-ZMIN
- 400 CONTINUE
- ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
- IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
- ELSE
- GOTO 900
- ENDIF
- ELSE
- GOTO 900
- ENDIF
-C debug output
- IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
- & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
- & IFLA,IFLB,ZZ,ZMIN,ZMAX
- RETURN
-
- 900 CONTINUE
- WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
- & IFLA,IFLB
- CALL PHO_ABORT
-
- END
-
-CDECK ID>, PHO_ALPHAE
- DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
-C**********************************************************************
-C
-C calculation of ALPHA_em
-C
-C input: Q2 scale in GeV**2
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- DOUBLE PRECISION Q2
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
- DOUBLE PRECISION PYALEM
-
- pho_alphae = 1.D0/137.D0
-
- if(ipamdl(120).eq.1) then
-
- pho_alphae = PYALEM(Q2)
-
- endif
-
- END
-
-CDECK ID>, PHO_ALPHAS
- DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
-C**********************************************************************
-C
-C calculation of ALPHA_S
-C
-C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
-C 2 lambda_QCD**2 for PDF 2 evolution
-C 3 lambda_QCD**2 for hard scattering
-C Q2 scale in GeV**2
-C
-C initialization needed:
-C IMODE = 0 lambda values taken from PDF table
-C -1 given Q2 is 4-flavour lambda 1
-C -2 given Q2 is 4-flavour lambda 2
-C -3 given Q2 is 4-flavour lambda 3
-C
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- DOUBLE PRECISION Q2
- INTEGER IMODE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C hard scattering parameters used for most recent hard interaction
- INTEGER NFbeta,NF
- DOUBLE PRECISION ALQCD2,BQCD
- COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-
- INTEGER I
-
- PHO_ALPHAS = 0.D0
-
- IF(IMODE.GT.0) THEN
-
- IF(Q2.LT.PARMDL(148)) THEN
- NFbeta = 1
- ELSE IF(Q2.LT.PARMDL(149)) THEN
- NFbeta = 2
- ELSE IF(Q2.LT.PARMDL(150)) THEN
- NFbeta = 3
- ELSE
- NFbeta = 4
- ENDIF
-
- PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
- NFbeta = NFbeta+2
-
- ELSE IF(IMODE.EQ.0) THEN
-
- DO I=1,3
- if(I.EQ.3) then
- ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
- else
- ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
- endif
- ALQCD2(I,1) = PARMDL(148)
- & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
- ALQCD2(I,3) = PARMDL(149)
- & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
- ALQCD2(I,4) = PARMDL(150)
- & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
-
- ENDDO
-
- ELSE IF(IMODE.LT.0) THEN
-
- if(IMODE.eq.-4) then
- I = 3
- ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
- else
- I = -IMODE
- ALQCD2(I,2) = Q2
- endif
- ALQCD2(I,1) = PARMDL(148)
- & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
- ALQCD2(I,3) = PARMDL(149)
- & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
- ALQCD2(I,4) = PARMDL(150)
- & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_DFWRAP
- SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
-C**********************************************************************
-C
-C wrapper for diffraction dissociation in hadron-nucleus and
-C nucleus-nucleus collisions with DPMJET
-C
-C input: MODE 1: transformation into CMS
-C 2: transformation into Lab
-C JM1/2 indices of old mother particles
-C JM1/2N indices of new mother particles
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- INTEGER MODE,JM1,JM2
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
- DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
- DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
-
- INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
-
-C transformation into CMS
-
- IF(MODE.EQ.1) THEN
-
- JM1S = JM1
- JM2S = JM2
- NHEPS = NHEP
-
- XM1 = PHEP(5,JM1)
- XM2 = PHEP(5,JM2)
-
-C boost into CMS
- P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
- P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
- P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
- P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
- SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
- ECMD = SQRT(SS)
- DO 10 I=1,4
- GAMBED(I) = P1(I)/ECMD
- 10 CONTINUE
- CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
- & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
- & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
-C rotation angles
- CODD = P1(3)/PTOT1
- SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
- COFD = 1.D0
- SIFD = 0.D0
- IF(PTOT1*SIDD.GT.1.D-5) THEN
- COFD = P1(1)/(SIDD*PTOT1)
- SIFD = P1(2)/(SIDD*PTOT1)
- ANORF= SQRT(COFD*COFD+SIFD*SIFD)
- COFD = COFD/ANORF
- SIFD = SIFD/ANORF
- ENDIF
-
-C initial particles in CMS
-
- P1(1) = 0.D0
- P1(2) = 0.D0
- P1(3) = ECMD/2.D0*XPSUB
- P1(4) = P1(3)
-
- P2(1) = 0.D0
- P2(2) = 0.D0
- P2(3) = -ECMD/2.D0*XTSUB
- P2(4) = -P2(3)
-
- CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
-
- CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
- & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
- & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
-
- CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
- & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
- & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
-
- JM1 = JM1N
- JM2 = JM2N
-
-C transformation into lab.
-
- ELSE IF(MODE.EQ.2) THEN
-
- CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
- & GAMBED(1),GAMBED(2),GAMBED(3))
-
- JM1 = JM1S
- JM2 = JM2S
-
-C clean up after rejection
-
- ELSE IF(MODE.EQ.-2) THEN
-
- NHEP = NHEPS
-
- JM1 = JM1S
- JM2 = JM2S
-
- ELSE
-
- WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_DIFDIS
- SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
- & MSOFT,MHARD,IREJ)
-C***********************************************************************
-C
-C sampling of diffractive events of different kinds,
-C (produced particles stored in /POEVT1/)
-C
-C input: IDIF1/2 diffractive process particle 1/2
-C 0 elastic/quasi-elastic scattering
-C 1 diffraction dissociation
-C IMOTH1/2 index of mother particles in /POEVT1/
-C SPROB suppression factor (survival probability) for
-C resolved diffraction dissociation
-C IMODE mode of operation
-C 0 sampling of diffractive cut
-C 1 sampling of enhanced cut
-C 2 sampling of diffractive cut without
-C scattering (needed for double-pomeron)
-C -1 initialization
-C -2 output of statistics
-C
-C output: MSOFT number of generated soft strings
-C MHARD number of generated hard strings
-C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
-C 0 quasi elastic scattering
-C 1 low-mass diffractive dissociation
-C 2 soft high-mass diffractive dissociation
-C 3 hard resolved diffractive dissociation
-C 4 hard direct diffractive dissociation
-C IREJ rejection label
-C 0 successful generation of partons
-C 1 failure
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-7,
- & DEPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C c.m. kinematics of diffraction
- INTEGER NPOSD
- DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
- & SIDD,CODD,SIFD,COFD,PDCMS
- COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
- & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
-C obsolete cut-off information
- DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
- COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C event weights and generated cross section
- INTEGER IPOWGC,ISWCUT,IVWGHT
- DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
- COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
- & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
-
- DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
- DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
- DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
- & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
- & IDIR(2),IPROC(2)
-
- IF(IMODE.EQ.-1) THEN
-C initialization
- RETURN
- ELSE IF(IMODE.EQ.-2) THEN
-C output of statistics
- RETURN
- ENDIF
-
- IREJ = 0
-C mass cuts
- PIMASS = 0.140D0
-C debug output
- IF(IDEB(45).GE.10) THEN
- WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
- & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
- & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
- ENDIF
- IPAR(1) = IDIF1
- IPAR(2) = IDIF2
-C save current status
- MSOFT = 0
- MHARD = 0
- KHPOMS = KHPOM
- KSPOMS = KSPOM
- KSREGS = KSREG
- KHDIRS = KHDIR
- IPOIS1 = IPOIX1
- IPOIS2 = IPOIX2
- IPOIS3 = IPOIX3
- JDA11 = JDAHEP(1,IMOTH1)
- JDA21 = JDAHEP(2,IMOTH1)
- JDA12 = JDAHEP(1,IMOTH2)
- JDA22 = JDAHEP(2,IMOTH2)
- ISTH1 = ISTHEP(IMOTH1)
- ISTH2 = ISTHEP(IMOTH2)
- NHEPS = NHEP
-C get mother data
- NPOSD(1) = IMOTH1
- NPOSD(2) = IMOTH2
- DO 20 I=1,2
- IDPDG(I) = IDHEP(NPOSD(I))
- IDBAM(I) = IMPART(NPOSD(I))
- AMP(I) = PHO_PMASS(IDBAM(I),0)
- IF(IDPDG(I).EQ.22) THEN
- PMASSD(I) = 0.765D0
- PVIRTD(I) = PHEP(5,NPOSD(I))**2
- ELSE
- PMASSD(I) = PHO_PMASS(IDBAM(I),0)
- PVIRTD(I) = 0.D0
- ENDIF
- 20 CONTINUE
-C get CM system
- P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
- P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
- P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
- P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
- SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
- ECMD = SQRT(SS)
- IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
- & 'PHO_DIFDIS: availabe energy',ECMD
-C check total available energy
- IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
- IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
- & 'PHO_DIFDIS: ',
- & 'not enough energy for inelastic diffraction',
- & 'ECM, particle masses:',ECMD,AMP
- IFAIL(7) = IFAIL(7)+1
- IREJ = 1
- RETURN
- ENDIF
-C boost into CMS
- DO 10 I=1,4
- GAMBED(I) = P1(I)/ECMD
- 10 CONTINUE
- CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
- & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
- & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
-C rotation angles
- CODD = P1(3)/PTOT1
- SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
- COFD = 1.D0
- SIFD = 0.D0
- IF(PTOT1*SIDD.GT.1.D-5) THEN
- COFD = P1(1)/(SIDD*PTOT1)
- SIFD = P1(2)/(SIDD*PTOT1)
- ANORF= SQRT(COFD*COFD+SIFD*SIFD)
- COFD = COFD/ANORF
- SIFD = SIFD/ANORF
- ENDIF
-C initial particles in CMS
- PDCMS(1,1) = 0.D0
- PDCMS(2,1) = 0.D0
- PDCMS(3,1) = PTOT1
- PDCMS(4,1) = P1(4)
- PDCMS(1,2) = 0.D0
- PDCMS(2,2) = 0.D0
- PDCMS(3,2) = -PTOT1
- PDCMS(4,2) = ECMD-P1(4)
-C get new CM momentum
- AM12 = PMASSD(1)**2
- AM22 = PMASSD(2)**2
- PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
-
-C coherence constraint (min/max diffractive mass allowed)
- IF(IMODE.EQ.2) THEN
- THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
- THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
- THRM2 = SQRT(1-PARMDL(72))*ECMD
- THRM2 = MIN(THRM2,ECMD/PARMDL(70))
- ELSE
- THRM1 = PARMDL(46)
- THRM2 = PARMDL(45)*ECMD
-C check kinematic limits
- IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
- IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
- ENDIF
-
-C check energy vs. coherence constraints
- IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
- IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
-
-C no phase space available
- IF(IPAR(1)+IPAR(2).EQ.0) THEN
- IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
- & 'PHO_DIFDIS: ',
- & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
- & 'side 1: min. mass, upper mass limit:',
- & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
- & 'side 2: min. mass, upper mass limit:',
- & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
- IFAIL(7) = IFAIL(7)+1
- IREJ = 1
- RETURN
- ENDIF
-
- ITRY = 0
- ITRYM = 10
- IPARS1 = IPAR(1)
- IPARS2 = IPAR(2)
-
-C main rejection loop
-C -------------------------------
- 50 CONTINUE
- ITRY = ITRY+1
- IF(ITRY.GT.1) THEN
- IFAIL(13) = IFAIL(13)+1
- IF(ITRY.GE.ITRYM) THEN
- IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
- & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
- IFAIL(7) = IFAIL(7)+1
- IREJ = 1
- RETURN
- ENDIF
- ENDIF
- KSPOM = KSPOMS
- KHPOM = KHPOMS
- KHDIR = KHDIRS
- KSREG = KSREGS
- IPAR(1) = IPARS1
- IPAR(2) = IPARS2
-C reset mother-daugther relations
- NHEP = NHEPS
- JDAHEP(1,IMOTH1) = JDA11
- JDAHEP(2,IMOTH1) = JDA21
- JDAHEP(1,IMOTH2) = JDA12
- JDAHEP(2,IMOTH2) = JDA22
- ISTHEP(IMOTH1) = ISTH1
- ISTHEP(IMOTH2) = ISTH2
- IPOIX1 = IPOIS1
- IPOIX2 = IPOIS2
- IPOIX3 = IPOIS3
-C
- NSLP = 0
- NCOR = 0
- 55 CONTINUE
-
-C calculation of kinematics
- DO 100 I=1,2
-C sampling of masses
- IRPDG(I) = 0
- IRBAM(I) = 0
- IFL1P(I) = IDPDG(I)
- IFL2P(I) = IDBAM(I)
- IVEC(I) = 0
- IDIR(I) = 0
- ISAM(I) = 0
- JSAM(I) = 0
- KSAM(I) = 0
- IF(IPAR(I).EQ.0) THEN
-C vector meson dominance assumed
- XMASS(I) = AMP(I)
- CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
-C diffraction dissociation
- ELSE IF(IPAR(I).EQ.1) THEN
- XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
- PREF2 = PMASSD(I)**2
- XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
- ELSE
- WRITE(LO,'(/1X,A,2I3)')
- & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
- CALL PHO_ABORT
- ENDIF
- 100 CONTINUE
-
-C sampling of momentum transfer
- CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
- & THRM2,TT,SLWGHT,IREJ)
- IF(IREJ.NE.0) THEN
- NSLP=NSLP+1
- IF(NSLP.LT.100) GOTO 55
- WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
- & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
- IREJ = 5
- RETURN
- ENDIF
-
-C correct for t-M^2 correlation in diffraction
- IF(DT_RNDM(TT).GT.SLWGHT) THEN
- NCOR=NCOR+1
- IF(NCOR.LT.100) GOTO 55
- WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
- & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
- IREJ = 5
- RETURN
- ENDIF
-
-C debug output
- IF(IDEB(45).GE.5) THEN
- WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
- & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
- ENDIF
-C not double pomeron scattering
- IF(IMODE.NE.2) THEN
-C sample diffractive interaction processes
- DO 120 I=1,2
- IF(IPAR(I).NE.0) THEN
-C find particle combination
- IF(IDPDG(I).EQ.IFPAP(1)) THEN
- IP = 2
- ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
- IP = 3
- ELSE IF(IDPDG(I).EQ.990) THEN
- IP = 4
- ELSE
- IP = I+1
- ENDIF
-C sample dissociation process
- CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
- & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
- & KSAM(I),IDIR(I))
- IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
-C store process label
- IF(IDIR(I).GT.0) THEN
- IPAR(I) = 4
- ELSE IF(KSAM(I).GT.0) THEN
- IPAR(I) = 3
- ELSE IF(ISAM(I).GT.0) THEN
- IPAR(I) = 2
- ELSE
- IPAR(I) = 1
-C mass fine correction
- CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
- & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
- XMASS(I) = XMNEW
- ENDIF
- ELSE
-C diffractive pomeron-hadron interaction
- IPAR(I) = 10+IPROC(I)
- ENDIF
-C debug output
- IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
- & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
- & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
- ENDIF
- 120 CONTINUE
- ENDIF
-C actualize debug information
- IF(IMODE.EQ.1) THEN
- IDIFR1 = IPAR(1)
- IDIFR2 = IPAR(2)
- ENDIF
-C calculate new momenta in CMS
- CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
- IF(IREJ.NE.0) GOTO 50
- DO 130 I=1,4
- PP(I,1) = P1(I)
- PP(I,2) = P2(I)
- 130 CONTINUE
-
-C comment line for diffraction
- CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
- & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
-C write diffractive strings/particles
- DO 200 I=1,2
- I1 = I
- I2 = 3-I1
- DO K=1,4
- PD1(K) = PP(K,I1)
- PD2(K) = PP(K,I2)
- ENDDO
- PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
- PP(7,I1) = TT
- IGEN = IPHIST(2,NPOSD(I1))
- if(IGEN.eq.0) IGEN = -I1*10
- CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
- & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(7+I) = IFAIL(7+I)+1
- IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
- & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
- & I,IPAR(I),XMASS(I)
- GOTO 50
- ENDIF
- ICOLOR(I1,ICPOS) = IPOSP(1,I1)
- 200 CONTINUE
-C double-pomeron scattering?
- IF(IMODE.EQ.2) GOTO 150
-
-C diffractive final states
- DO 300 I=1,2
- 110 CONTINUE
- IF(IPAR(I).EQ.0) THEN
-C vector meson production
- IF(IDPDG(I).EQ.22) THEN
- IF(ISWMDL(21).GE.0) THEN
- ISP = IPAMDL(3)
- IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
- CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
- ENDIF
-C hadronic state of multi-pomeron coupling
- ELSE IF(IDPDG(I).EQ.990) THEN
- CALL PHO_SDECAY(IPOSP(1,I),0,2)
- ENDIF
- ELSE
- IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
- IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
- IF(IDIR(I).GT.0) THEN
- IPAR(I) = 4
- ELSE IF(KSAM(I).GT.0) THEN
- IPAR(I) = 3
- ELSE IF(ISAM(I).GT.0) THEN
- IPAR(I) = 2
- ELSE
- IPAR(I) = 1
- ENDIF
- ELSE
- IPAR(I) = 10+IPROC(I)
- ENDIF
- IPHIST(I,ICPOS) = IPAR(I)
-C update debug informantion
- KSPOM = ISAM(I)
- KSREG = JSAM(I)
- KHPOM = KSAM(I)
- KHDIR = IDIR(I)
- IDIFR1 = IPAR(1)
- IDIFR2 = IPAR(2)
- IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
-
-C resonance decay, pi+pi- background
- P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
- P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
- P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
- P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
- CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
- & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
-C decay
- IF(IDPDG(I).EQ.22) THEN
- IPHIST(2,IPOS) = 3
- IF(ISWMDL(21).GE.0) THEN
- ISP = IPAMDL(3)
- IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
- CALL PHO_SDECAY(IPOS,ISP,2)
- ENDIF
- ELSE
- CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
- ENDIF
- IREJ = 0
- ELSE
-
-C particle-pomeron scattering
- IF(IPAR(I).LE.4) THEN
-C non-diffractive particle-pomeron scattering
- IGEN = IPHIST(2,NPOSD(I))
- if(IGEN.eq.0) then
- if(I.eq.1) then
- IGEN = 5
- else
- IGEN = 6
- endif
- endif
- CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
- & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
- ELSE
-C diffractive particle-pomeron scattering
- IPOIX2 = IPOIX2+1
- IPORES(IPOIX2) = IPROC(I)
- IPOPOS(1,IPOIX2) = IPOSP(1,I)
- IPOPOS(2,IPOIX2) = IPOSP(2,I)
- ENDIF
- ENDIF
- ENDIF
-
-C rejection?
- IF(IREJ.NE.0) THEN
- IFAIL(20+I) = IFAIL(20+I)+1
- IF(IPAR(I).GT.1) THEN
- IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
- IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
- IF(IDIR(I).GT.0) THEN
- IDIR(I) = 0
- ELSE IF(KSAM(I).GT.0) THEN
- KSAM(I) = KSAM(I)-1
- ELSE IF(ISAM(I).GT.0) THEN
- ISAM(I) = ISAM(I)-1
- ENDIF
- GOTO 110
- ELSE
- IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
- & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
- & I,IPAR(I),XMASS(I)
- GOTO 50
- ENDIF
- ENDIF
- 300 CONTINUE
-
- IDIF1 = IPAR(1)
- IDIF2 = IPAR(2)
-C update debug information
- KSPOM = KSPOMS+ISAM(1)+ISAM(2)
- KSREG = KSREGS+JSAM(1)+JSAM(2)
- KHPOM = KHPOMS+KSAM(1)+KSAM(2)
- KHDIR = KHDIRS+IDIR(1)+IDIR(2)
-
- 150 CONTINUE
-
-C debug output
- IF(IDEB(45).GE.10) THEN
- WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
- & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
- & IPAR,NPOSD,MSOFT,MHARD,IMODE
- ENDIF
- IF(IDEB(45).GE.15) THEN
- WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
- & '------------------------------'
- CALL PHO_PREVNT(0)
- ENDIF
-
- END
-
-CDECK ID>, PHO_DIFPRO
- SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
- & IPROC,ISAM,JSAM,KSAM,IDIR)
-C*********************************************************************
-C
-C sampling of diffraction dissociation process
-C
-C input: IP particle combination
-C ICUT user imposed limitations
-C ID1/2 PDG particle code of scattering particles
-C XMASS diffractively produced mass (GeV)
-C P2V1/2 virtuality of scattering particles (Gev**2)
-C SPROB suppression factor for resolved single and
-C double diffraction dissociation
-C
-C output: IRPOC process ID
-C ISAM number of cut pomerons (soft)
-C JSAM number of cut reggeons
-C KSAM number of cut pomerons (hard)
-C IDIR direct hard interaction
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-
- ISAM = 0
- JSAM = 0
- KSAM = 0
- IDIR = 0
-
- IF(XMASS.GT.3.D0) THEN
-C rapidity gap survival probability
- SPRO = 1.D0
- IF(ISWMDL(28).GE.1) SPRO = SPROB
-C sample interaction
- IPROC = 0
- CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
- ELSE
- IPROC = 1
- ENDIF
- IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
-C non-diffractive hadron-pomeron interaction
- IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
-C option for suppression of multiple interaction
- IF(ICUT.EQ.0) THEN
- IPROC = 1
- IF(ISAM+KSAM+IDIR.GT.0) THEN
- ISAM = 1
- JSAM = 0
- ELSE
- JSAM = 1
- ENDIF
- KSAM = 0
- IDIR = 0
- ELSE IF(ICUT.EQ.1) THEN
- IF(IDIR.GT.0) THEN
- ELSE IF(KSAM.GT.0) THEN
- KSAM = 1
- ISAM = 0
- JSAM = 0
- ELSE IF(ISAM.GT.0) THEN
- ISAM = 1
- JSAM = 0
- ELSE
- JSAM = 1
- ENDIF
- ELSE IF(ICUT.EQ.2) THEN
- KSAM = MIN(KSAM,1)
- ELSE IF(ICUT.EQ.3) THEN
- ISAM = MIN(ISAM,1)
- ENDIF
- ENDIF
- END
-
-CDECK ID>, PHO_DIFPAR
- SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
- & IPOSH1,IPOSH2,IMODE,IREJ)
-C***********************************************************************
-C
-C perform string construction for diffraction dissociation
-C
-C input: IMOTH1,2 index of mother particles in POEVT1
-C IGENM production process of mother particles
-C IFL1,IFL2 particle numbers
-C (IDPDG,IDBAM for quasi-elas. hadron)
-C IPAR 0 quasi-elasic scattering
-C 1 single string configuration
-C 2 two string configuration
-C P1 massive 4 momentum of first
-C P1(6) virtuality/squ.mass of particle (GeV**2)
-C P1(7) virtuality of Pomeron (neg, GeV**2)
-C P2 massive 4 momentum of second particle
-C IMODE 1 diffraction dissociation
-C 2 double-pomeron scattering
-C
-C output: IPOSH1,2 index of the particles in /POEVT1/
-C IREJ 0 successful string construction
-C 1 no string construction possible
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION P1(7),P2(7)
-
- PARAMETER ( EPS = 1.D-7,
- & DEPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C c.m. kinematics of diffraction
- INTEGER NPOSD
- DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
- & SIDD,CODD,SIFD,COFD,PDCMS
- COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
- & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DIMENSION PCH1(2,4)
- data IC1 /0/
- data IC2 /0/
-
- IREJ = 0
- ILTR1 = NHEP+1
- IGEN = IGENM
- if(IGENM.le.-10) IGEN = 0
-
-C elastic part
- IF(IPAR.EQ.0) THEN
- IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
- if(IGEN.eq.0) IGEN = 3
-C pi+/pi- isotropic background
- CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
- & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
- CALL PHO_SDECAY(IPOSH1,0,-2)
- ELSE
- if(IGEN.eq.0) then
- IGEN = 2
- if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
- endif
-C registration of particle or resonance
- CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
- & P1(4),0,IGEN,0,0,IPOSH1,1)
- ENDIF
-
-C diffraction dissociation
- ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
-C calculation of resulting particle momenta
- IF(IMOTH1.EQ.NPOSD(1)) THEN
- K = 2
- ELSE
- K = 1
- ENDIF
- DO 100 I=1,4
- PCH1(2,I) = PDCMS(I,K)-P2(I)
- PCH1(1,I) = P1(I)-PCH1(2,I)
- 100 CONTINUE
-
-C registration
- if(IMODE.LT.2) then
- if(IGEN.eq.0) IGEN = -IGENM/10+4
- CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
- & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
- else
- if(IGEN.eq.0) IGEN = 4
- endif
- CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
- & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
-
-C invalid IPAR
- ELSE
- WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
- CALL PHO_ABORT
- ENDIF
-
-C back transformation
- CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
- & GAMBED(1),GAMBED(2),GAMBED(3))
-
- END
-
-CDECK ID>, PHO_QELAST
- SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
-C**********************************************************************
-C
-C sampling of quasi elastic processes
-C
-C input: IPROC 2 purely elastic scattering
-C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
-C IPROC 4 double pomeron scattering
-C IPROC -1 initialization
-C IPROC -2 output of statistics
-C JM1/2 index of initial particle 1/2
-C
-C output: initial and final particles in /POEVT1/ involving
-C polarized resonances in /POEVT1/ and decay
-C products
-C
-C IREJ 0 successful
-C 1 failure
-C 50 user rejection
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( NTAB = 20,
- & EPS = 1.D-10,
- & PIMASS = 0.13D0,
- & DEPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C c.m. kinematics of diffraction
- INTEGER NPOSD
- DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
- & SIDD,CODD,SIFD,COFD,PDCMS
- COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
- & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
- DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
- DIMENSION IFL(2),IDPRO(4)
- character*15 pho_pname
- CHARACTER*8 VMESA(0:4),VMESB(0:4)
- DIMENSION ISAMVM(4,4)
- DATA IDPRO / 113,223,333,92 /
- DATA VMESA / 'vmeson ','rho ','omega ','phi ',
- & 'pi+pi- ' /
- DATA VMESB / 'vmeson ','rho ','omega ','phi ',
- & 'pi+pi- ' /
-
-C sampling of elastic/quasi-elastic processes
- IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
- IREJ = 0
- NPOSD(1) = JM1
- NPOSD(2) = JM2
- DO 55 I=1,2
- PMI(I) = PHEP(5,NPOSD(I))
- IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
- 55 CONTINUE
-C get CM system
- PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
- PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
- PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
- PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
- SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
- ECMD = SQRT(SS)
-
- IF(ECMD.LE.PMI(1)+PMI(2)) THEN
- IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
- & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
- & ECMD,PMI
- IREJ = 5
- RETURN
- ENDIF
-
- DO 60 I=1,4
- GAMBED(I) = PK1(I)/ECMD
- 60 CONTINUE
- CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
- & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
- & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
-C rotation angles
- CODD = PK1(3)/PTOT1
- SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
- COFD = 1.D0
- SIFD = 0.D0
- IF(PTOT1*SIDD.GT.1.D-5) THEN
- COFD = PK1(1)/(SIDD*PTOT1)
- SIFD = PK1(2)/(SIDD*PTOT1)
- ANORF = SQRT(COFD*COFD+SIFD*SIFD)
- COFD = COFD/ANORF
- SIFD = SIFD/ANORF
- ENDIF
-C get CM momentum
- AM12 = PMI(1)**2
- AM22 = PMI(2)**2
- PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
-
-C production process of mother particles
- IGEN = IPHIST(2,NPOSD(1))
- if(IGEN.eq.0) IGEN = IPROC
-
- ICALL = ICALL + 1
-C main rejection label
- 50 CONTINUE
-C determine process and final particles
- IFL(1) = IDHEP(NPOSD(1))
- IFL(2) = IDHEP(NPOSD(2))
- IF(IPROC.EQ.3) THEN
- ITRY = 0
- 100 CONTINUE
- ITRY = ITRY+1
- IF(ITRY.GT.50) THEN
- IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
- & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
- & ITRY,ECMD
- IREJ = 5
- RETURN
- ENDIF
- XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
- DO 110 I=1,4
- DO 120 J=1,4
- XI = XI-SIGVM(I,J)
- IF(XI.LE.0.D0) GOTO 130
- 120 CONTINUE
- 110 CONTINUE
- 130 CONTINUE
- IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
- IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
- ISAMVM(I,J) = ISAMVM(I,J)+1
- ISAMQE = ISAMQE+1
-C sample new masses
- CALL PHO_SAMASS(IFL(1),RMASS(1))
- CALL PHO_SAMASS(IFL(2),RMASS(2))
- IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
- ELSE IF(IPROC.EQ.2) THEN
- I = 0
- J = 0
- ISAMEL = ISAMEL+1
- RMASS(1) = PHO_PMASS(NPOSD(1),2)
- RMASS(2) = PHO_PMASS(NPOSD(2),2)
- ELSE
- WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
- CALL PHO_ABORT
- ENDIF
-C sample momentum transfer
- CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
- & SLWGHT,IREJ)
- IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
- & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
-C calculate new momenta
- CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
- IF(IREJ.NE.0) GOTO 50
- DO K=1,4
- P(K,1) = PK1(K)
- P(K,2) = PK2(K)
- ENDDO
-C comment line for elastic/quasi-elastic scattering
- CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
- & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
-
- I1 = NHEP+1
-C fill /POEVT1/
- DO 200 I=1,2
- K = 3-I
- IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
-C pi+/pi- isotropic background
- IGEN = 3
- CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
- & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
- ICOLOR(I,ICPOS) = IPOS
- CALL PHO_SDECAY(IPOS,0,-2)
- ELSE
-C registration
- IGEN = 2
- if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
- CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
- & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
- ICOLOR(I,ICPOS) = IPOS
- ENDIF
- 200 CONTINUE
- I2 = NHEP
-C search for vector mesons
- DO 300 I=I1,I2
-C decay according to polarization
- IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
- ISP = IPAMDL(3)
- IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
- CALL PHO_SDECAY(I,ISP,2)
- ENDIF
- 300 CONTINUE
- I2 = NHEP
-C back transformation
- CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
- & GAMBED(2),GAMBED(3))
-
-C initialization of tables
- ELSE IF(IPROC.EQ.-1) THEN
- DO 10 I=1,4
- DO 20 J=1,4
- ISAMVM(I,J) = 0
- 20 CONTINUE
- 10 CONTINUE
- ISAMEL = 0
- ISAMQE = 0
- IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
- IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
- CALL PHO_SAMASS(-1,RMASS(1))
- ICALL = 0
-
-C output of statistics
- ELSE IF(IPROC.EQ.-2) THEN
- IF(ICALL.LT.10) RETURN
- WRITE(LO,'(/,1X,A,I10/,1X,A)')
- & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
- & '---------------------------------------------------'
- WRITE(LO,'(1X,A,I10)')
- & 'sampled elastic processes:',ISAMEL
- WRITE(LO,'(1X,A,I10)')
- & 'sampled quasi-elastic vectormeson production:',ISAMQE
- WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
- DO 30 I=1,4
- WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
- 30 CONTINUE
- CALL PHO_SAMASS(-2,RMASS(1))
- ELSE
- WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
- & 'unknown process ID',IPROC
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_CDIFF
- SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
-C**********************************************************************
-C
-C preparation of /POEVT1/ for double-pomeron scattering
-C
-C input: IMOTH1/2 index of mother particles in /POEVT1/
-C
-C IMODE 1 sampling of pomeron-pomeron scattering
-C -1 initialization
-C -2 output of statistics
-C
-C output: MSOFT number of generated soft strings
-C MHARD number of generated hard strings
-C IREJ 0 accepted
-C 1 rejected
-C 50 user rejection
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-10,
- & DEPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C energy-interpolation table
- INTEGER IEETA2
- PARAMETER ( IEETA2 = 20 )
- INTEGER ISIMAX
- DOUBLE PRECISION SIGTAB,SIGECM
- COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
-C table of particle indices for recursive PHOJET calls
- INTEGER MAXIPX
- PARAMETER ( MAXIPX = 100 )
- INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
- COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
- & IPOIX1,IPOIX2,IPOIX3
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DIMENSION PD(4)
-
- if(IMODE.ne.1) return
-
- IREJ = 0
- IP = 4
-C select first diffraction
- IF(DT_RNDM(DUM).GT.0.5D0) THEN
- IPAR1 = 1
- IPAR2 = 0
- ELSE
- IPAR1 = 0
- IPAR2 = 1
- ENDIF
- ITRY2 = 0
- ITRYM = 1000
-
-C save current status
- MSOFT = 0
- MHARD = 0
- KHPOMS = KHPOM
- KSPOMS = KSPOM
- KSREGS = KSREG
- KHDIRS = KHDIR
- IPOIS1 = IPOIX1
- IPOIS2 = IPOIX2
- IPOIS3 = IPOIX3
- JDA11 = JDAHEP(1,IMOTH1)
- JDA21 = JDAHEP(2,IMOTH1)
- JDA12 = JDAHEP(1,IMOTH2)
- JDA22 = JDAHEP(2,IMOTH2)
- ISTH1 = ISTHEP(IMOTH1)
- ISTH2 = ISTHEP(IMOTH2)
- NHEPS = NHEP
-
-C find mother particle production process
- IGEN = IPHIST(2,IMOTH1)
- if(IGEN.eq.0) IGEN = 4
-
-C main generation loop
- 60 CONTINUE
-
- KSPOM = KSPOMS
- KHPOM = KHPOMS
- KHDIR = KHDIRS
- KSREG = KSREGS
- I1 = IPAR1
- I2 = IPAR2
-C reset mother-daugther relations
- NHEP = NHEPS
- JDAHEP(1,IMOTH1) = JDA11
- JDAHEP(2,IMOTH1) = JDA21
- JDAHEP(1,IMOTH2) = JDA12
- JDAHEP(2,IMOTH2) = JDA22
- ISTHEP(IMOTH1) = ISTH1
- ISTHEP(IMOTH2) = ISTH2
- IPOIX1 = IPOIS1
- IPOIX2 = IPOIS2
- IPOIX3 = IPOIS3
-C rejection counter
- ITRY2 = ITRY2+1
- IF(ITRY2.GT.1) THEN
- IFAIL(39) = IFAIL(39)+1
- IF(ITRY2.GE.ITRYM) GOTO 50
- ENDIF
-C generate two diffractive events
- CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
- IF(IREJ.NE.0) GOTO 50
- CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
- IF(IREJ.NE.0) GOTO 50
-C mass of pomeron-pomeron system
- DO 100 I2 = NHEP,1,-1
- IF(IDHEP(I2).EQ.990) GOTO 110
- 100 CONTINUE
- 110 CONTINUE
- DO 120 I1 = I2-1,1,-1
- IF(IDHEP(I1).EQ.990) GOTO 130
- 120 CONTINUE
- 130 CONTINUE
- DO 140 I=1,4
- PD(I) = PHEP(I,I1)+PHEP(I,I2)
- 140 CONTINUE
- XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
- IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
- & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
- IF(XMASS.LT.0.1D0) GOTO 60
- XMASS = SQRT(XMASS)
- IF(XMASS.LT.PARMDL(71)) GOTO 60
-
-C sample pomeron-pomeron interaction process
- CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
- & IPROC,ISAM,JSAM,KSAM,IDIR)
-
-C non-diffractive pomeron-pomeron interactions
- IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
- 200 CONTINUE
- IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
-C debug output
- IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
- & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
- & IP,XMASS,ISAM,JSAM,KSAM,IDIR
-C store debug information
- IF(IDIR.GT.0) THEN
- IPAR = 4
- ELSE IF(KSAM.GT.0) THEN
- IPAR = 3
- ELSE IF(ISAM.GT.0) THEN
- IPAR = 2
- ELSE
- IPAR = 1
- ENDIF
- IDDPOM = IPAR
- IF(ISAM+JSAM.GT.0) KSDPO = 1
- IF(KSAM+IDIR.GT.0) KHDPO = 1
- KSPOM = ISAM
- KSREG = JSAM
- KHPOM = KSAM
- KHDIR = IDIR
- KSTRG = 0
- KSLOO = 0
-C generate pomeron-pomeron interaction
- CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
- IF(IREJ.NE.0) THEN
- IFAIL(3) = IFAIL(3)+1
- IF(IPAR.GT.1) THEN
- IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
- IF(IDIR.GT.0) THEN
- IFAIL(10) = IFAIL(10)+1
- IDIR = 0
- ELSE IF(KSAM.GT.0) THEN
- KSAM = KSAM-1
- ELSE IF(ISAM.GT.0) THEN
- ISAM = ISAM-1
- ENDIF
- GOTO 200
- ELSE
- IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
- & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
- & I,IPAR,XMASS
- GOTO 50
- ENDIF
- ENDIF
-
-C diffractive pomeron-pomeron interactions
- ELSE
- IPOIX2 = IPOIX2+1
- IPORES(IPOIX2) = IPROC
- IPOPOS(1,IPOIX2) = I1
- IPOPOS(2,IPOIX2) = I2
- IPAR = 10+IPROC
- IDDPOM = IPAR
- ENDIF
-
-C update debug information
- KSPOM = KSPOMS+ISAM
- KSREG = KSREGS+JSAM
- KHPOM = KHPOMS+KSAM
- KHDIR = KHDIRS+IDIR
-C comment line for central diffraction
- CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
- & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
- PHEP(5,IPOS) = XMASS
-C debug output
- IF(IDEB(59).GE.15) THEN
- WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
- & '-----------------------------'
- CALL PHO_PREVNT(0)
- ENDIF
- RETURN
-
-C treatment of rejection
- 50 CONTINUE
- IREJ = 1
- IFAIL(40) = IFAIL(40)+1
- IF(IDEB(59).GE.3) THEN
- WRITE(LO,'(1X,A)')
- & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
- IF(IDEB(59).GE.10) THEN
- CALL PHO_PREVNT(0)
- ELSE
- CALL PHO_PREVNT(-1)
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_SAMASS
- SUBROUTINE PHO_SAMASS(IFLA,RMASS)
-C**********************************************************************
-C
-C resonance mass sampling of quasi elastic processes
-C
-C input: IFLA PDG number of particle
-C IFLA -1 initialization
-C IFLA -2 output of statistics
-C
-C output: RMASS particle mass (in GeV)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(EPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C parameters of the "simple" Vector Dominance Model
- DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
- COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
-
- PARAMETER(NTABM=50)
- DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
- DIMENSION SUM(4),ICALL(4)
-
-C*****************************************************************
-C initialization of tables
- IF(IFLA.EQ.-1) THEN
-C
- NSTEP = NTABM
- DO 102 I=1,4
- ICALL(I) = 0
-
- DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
- DO 105 K=1,NSTEP
- RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
- 105 CONTINUE
- 102 CONTINUE
-C calculate table of dsig/dm
- CALL PHO_DSIGDM(RMA,XMA,NSTEP)
-C output of table
- IF(IDEB(35).GE.1) THEN
- WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
- WRITE(LO,'(1X,A,/1X,A)')
- & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
- & ' -------------------------------------------------------'
- DO 106 K=1,NSTEP
- WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
- & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
- 106 CONTINUE
- ENDIF
-C make second table for sampling
- DO 109 I=1,4
- SUM(I) = 0.D0
- DO 108 K=2,NSTEP
- SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
- XMC(I,K) = SUM(I)
- 108 CONTINUE
- 109 CONTINUE
-C normalization
- DO 118 K=1,NSTEP
- DO 119 I=1,4
- XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
- 119 CONTINUE
- 118 CONTINUE
- IF(IDEB(35).GE.10) THEN
- WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
- WRITE(LO,'(1X,A,/1X,A)')
- & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
- & ' -------------------------------------------------------'
- DO 120 K=1,NSTEP
- WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
- & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
- 120 CONTINUE
- ENDIF
-C
-C**************************************************
-C output of statistics
- ELSE IF(IFLA.EQ.-2) THEN
- WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
- & '----------------------'
- WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
- & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
-
-C
-C********************************************************
-C sampling of RMASS
- ELSE
-C quasi-elastic vector meson production
- IF(IFLA.EQ.113) THEN
- KP = 1
- ELSE IF(IFLA.EQ.223) THEN
- KP = 2
- ELSE IF(IFLA.EQ.333) THEN
- KP = 3
- ELSE IF(IFLA.EQ.92) THEN
- KP = 4
-C quasi-elastic production of h*
- ELSE IF(IFLA.EQ.91) THEN
- RMASS = 0.35D0
- RETURN
-C elastic hadron scattering
- ELSE
- RMASS = PHO_PMASS(IFLA,1)
- IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
- & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
- RETURN
- ENDIF
-C
-C sample mass of vector mesonsn / two-pi background
- XI = DT_RNDM(RMASS) + EPS
-C binary search
- IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
- KMIN=1
- KMAX=NSTEP
- 300 CONTINUE
- IF((KMAX-KMIN).EQ.1) GOTO 400
- KK=(KMAX+KMIN)/2
- IF(XI.LE.XMC(KP,KK)) THEN
- KMAX=KK
- ELSE
- KMIN=KK
- ENDIF
- GOTO 300
- 400 CONTINUE
- ELSE
- WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
- WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
- & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
- CALL PHO_ABORT
- ENDIF
-C fine interpolation
- RMASS = RMA(KP,KMIN)+
- & (RMA(KP,KMAX)-RMA(KP,KMIN))/
- & (XMC(KP,KMAX)-XMC(KP,KMIN))
- & *(XI-XMC(KP,KMIN))
- IF(IDEB(35).GE.20) THEN
- IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
- & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
- & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
- WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
- & IFLA,RMASS
- ENDIF
- ICALL(KP) = ICALL(KP)+1
-
- ENDIF
- END
-
-CDECK ID>, PHO_DSIGDM
- SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
-C**********************************************************************
-C
-C differential cross section DSIG/DM of low mass enhancement
-C
-C input: RMA(4,NTABM) mass values
-C output: XMA(4,NTABM) DSIG/DM of resonances
-C 1 rho production
-C 2 omega production
-C 3 phi production
-C 4 pi-pi continuum
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-10 )
-
- PARAMETER(NTABM=50)
- DIMENSION XMA(4,NTABM),RMA(4,NTABM)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C parameters of the "simple" Vector Dominance Model
- DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
- COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
-
- PIMASS = 0.135
-C rho meson shape (mass dependent width)
- QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
- DO 100 I=1,NSTEP
- XMASS = RMA(1,I)
- QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
- GAMMA = GAMM(1)*(QQ/QRES)**3
- XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
- & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
- 100 CONTINUE
-C omega/phi meson (constant width)
- DO 200 K=2,3
- DO 300 I=1,NSTEP
- XMASS = RMA(K,I)
- XMA(K,I) = XMASS*GAMM(K)
- & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
- 300 CONTINUE
- 200 CONTINUE
-C pi-pi continuum
- DO 400 I=1,NSTEP
- XMASS = RMA(4,I)
- XMA(4,I) = (XMASS-0.29D0)**2/XMASS
- 400 CONTINUE
-
- END
-
-CDECK ID>, PHO_SDECAY
- SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
-C**********************************************************************
-C
-C decay of single resonance of /POEVT1/:
-C decay in helicity frame according to polarization, isotropic
-C decay and decay with limited transverse phase space possible
-C
-C ATTENTION:
-C reference to particle number of CPC has to exist
-C
-C input: NPOS position in /POEVT1/
-C ISP 0 decay according to phase space
-C 1 decay according to transversal polarization
-C 2 decay according to longitudinal polarization
-C 3 decay with limited phase space
-C ILEV decay mode to use
-C 1 strong only
-C 2 strong and ew of tau, charm, and bottom
-C 3 strong and electro-weak decays
-C negative: remove mother resonance after decay
-C
-C output: /POEVT1/,/POEVT2/ final particles according to decay mode
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( EPS = 1.D-15,
- & DEPS = 1.D-10 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-C particle decay data
- double precision wg_sec_list
- integer idec_list,isec_list
- COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
- & isec_list(3,500)
-C auxiliary data for three particle decay
- DOUBLE PRECISION ECM,PCM,COD,COF,SIF
- COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
-
- DIMENSION WGHD(20),KCH(20),ID(3)
-
- IMODE = ABS(ILEV)
- IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
- & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
-
-C comment entry
- IF(ISTHEP(NPOS).GT.11) RETURN
-
-C particle stable?
- IDcpc = IMPART(NPOS)
- IF(IDcpc.EQ.0) return
- if(idec_list(1,IDcpc).eq.0) return
- IDabs = iabs(IDcpc)
-
-C different decay modi (times)
- IF(IMODE.EQ.1) THEN
- if(idec_list(1,IDabs).ne.1) return
- ELSE IF(IMODE.EQ.2) THEN
- if(idec_list(1,IDabs).gt.2) return
- ELSE IF(IMODE.EQ.3) THEN
- if(idec_list(1,IDabs).gt.3) return
- ELSE
- WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
- CALL PHO_ABORT
- ENDIF
-
-C decay products, check for mass limitations
- K = 0
- WGSUM = 0.D0
- AMIST = PHEP(5,NPOS)
- DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
- AMSUM = 0.D0
- DO 200 L=1,3
- ID(L) = isec_list(L,I)
- IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
- 200 CONTINUE
- IF(AMSUM.LT.AMIST) THEN
- K = K+1
- WGHD(K) = wg_sec_list(I)
- KCH(K) = I
- ENDIF
- 100 CONTINUE
- IF(K.EQ.0)THEN
- WRITE(LO,'(/1X,A,I6,3E12.4)')
- & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
- & NPOS,AMIST,AMSUM
- CALL PHO_PREVNT(0)
- RETURN
- ENDIF
-
-C sample new decay channel
- XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
- K = 0
- WGSUM = 0.D0
- 500 CONTINUE
- K = K+1
- WGSUM = WGSUM+WGHD(K)
- IF(XI.GT.WGSUM) GOTO 500
- IK = KCH(K)
- ID(1) = isec_list(1,IK)
- ID(2) = isec_list(2,IK)
- ID(3) = isec_list(3,IK)
- if(IDcpc.lt.0) then
- ID(1) = ipho_anti(ID(1))
- ID(2) = ipho_anti(ID(2))
- ID(3) = ipho_anti(ID(3))
- endif
-
-C rotation
- PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
- CXS = PHEP(1,NPOS)/PTOT
- CYS = PHEP(2,NPOS)/PTOT
- CZS = PHEP(3,NPOS)/PTOT
-C boost
- GBET = PTOT/AMIST
- GAM = PHEP(4,NPOS)/AMIST
-
- IF(ID(3).EQ.0) THEN
-C two particle decay
- CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
- ELSE
-C three particle decay
- CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
- & pho_pmass(ID(3),0),ISP)
- ENDIF
-
- IF(ILEV.LT.0) THEN
- IF(NHEP.NE.NPOS) THEN
- WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
- & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
- CALL PHO_ABORT
- ENDIF
- IMO1 = JMOHEP(1,NPOS)
- IMO2 = JMOHEP(2,NPOS)
- NHEP = NHEP-1
- ELSE
- IMO1 = NPOS
- IMO2 = 0
- ENDIF
- IPH1 = IPHIST(1,NPOS)
- IPH2 = IPHIST(2,NPOS)
-
-C back transformation and registration
- DO 300 I=1,3
- IF(ID(I).NE.0) THEN
- CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
- & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
- XX = PTOT*CX
- YY = PTOT*CY
- ZZ = PTOT*CZ
- CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
- & IPH1,IPH2,0,0,IPOS,1)
- ENDIF
- 300 CONTINUE
-
- 400 CONTINUE
-C debug output
- IF(IDEB(36).GE.20) THEN
- WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
- & '--------------------'
- CALL PHO_PREVNT(0)
- ENDIF
-
- END
-
-CDECK ID>, PHO_SDECY2
- SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
-C**********************************************************************
-C
-C isotropic/anisotropic two particle decay in CM system,
-C (transversely/longitudinally polarized boson into two
-C pseudo-scalar mesons)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C auxiliary data for three particle decay
- DOUBLE PRECISION ECM,PCM,COD,COF,SIF
- COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
-
- UMO2=UMO*UMO
- AM11=AM1*AM1
- AM22=AM2*AM2
- ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
- ECM(2)=UMO-ECM(1)
- WAU=ECM(1)*ECM(1)-AM11
- IF(WAU.LT.0.D0) THEN
- WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
- CALL PHO_ABORT
- ENDIF
- PCM(1)=SQRT(WAU)
- PCM(2)=PCM(1)
-
- CALL PHO_SFECFE(SIF(1),COF(1))
- IF(ISP.EQ.0) THEN
-C no polarization
- COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
- ELSE IF(ISP.EQ.1) THEN
-C transverse polarization
- 400 CONTINUE
- COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
- SID12 = 1.D0-COD(1)*COD(1)
- IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
- ELSE IF(ISP.EQ.2) THEN
-C longitudinal polarization
- 500 CONTINUE
- COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
- COD12 = COD(1)*COD(1)
- IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
- ELSE
- WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
- & 'invalid polarization',ISP
- CALL PHO_ABORT
- ENDIF
-
- COD(2) = -COD(1)
- COF(2) = -COF(1)
- SIF(2) = -SIF(1)
-
- END
-
-CDECK ID>, PHO_SDECY3
- SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
-C**********************************************************************
-C
-C isotropic/anisotropic three particle decay in CM system,
-C (transversely/longitudinally polarized boson into three
-C pseudo-scalar mesons)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-30,
- & EPS = 1.D-15 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C auxiliary data for three particle decay
- DOUBLE PRECISION ECM,PCM,COD,COF,SIF
- COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
-
- DIMENSION F(5),XX(5)
-
-C calculation of maximum of S2 phase space weight
- UMOO=UMO+UMO
- GU=(AM2+AM3)**2
- GO=(UMO-AM1)**2
- UFAK=1.0000000000001D0
- IF (GU.GT.GO) UFAK=0.99999999999999D0
- OFAK=2.D0-UFAK
- GU=GU*UFAK
- GO=GO*OFAK
- DS2=(GO-GU)/99.D0
- AM11=AM1*AM1
- AM22=AM2*AM2
- AM33=AM3*AM3
- UMO2=UMO*UMO
- RHO2=0.D0
- S22=GU
- DO 124 I=1,100
- S21=S22
- S22=GU+(I-1.D0)*DS2
- RHO1=RHO2
- RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
- IF(RHO2.LT.RHO1) GOTO 125
- 124 CONTINUE
-
- 125 CONTINUE
- S2SUP=(S22-S21)/2.D0+S21
- SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
- & /(S2SUP+EPS)
- SUPRHO=SUPRHO*1.05D0
- XO=S21-DS2
- IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
- IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
- XX(1)=XO
- XX(3)=S22
- X1=(XO+S22)*0.5D0
- XX(2)=X1
- F(3)=RHO2
- F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
- F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
- DO 126 I=1,16
- X4=(XX(1)+XX(2))*0.5D0
- X5=(XX(2)+XX(3))*0.5D0
- F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
- F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
- XX(4)=X4
- XX(5)=X5
- DO 128 II=1,5
- IA=II
- DO 131 III=IA,5
- IF(F(II).LT.F(III)) THEN
- FH=F(II)
- F(II)=F(III)
- F(III)=FH
- FH=XX(II)
- XX(II)=XX(III)
- XX(III)=FH
- ENDIF
- 131 CONTINUE
- 128 CONTINUE
- SUPRHO=F(1)
- S2SUP=XX(1)
- DO 129 II=1,3
- IA=II
- DO 130 III=IA,3
- IF (XX(II).LT.XX(III)) THEN
- FH=F(II)
- F(II)=F(III)
- F(III)=FH
- FH=XX(II)
- XX(II)=XX(III)
- XX(III)=FH
- ENDIF
- 130 CONTINUE
- 129 CONTINUE
- 126 CONTINUE
-
- AM23=(AM2+AM3)**2
-
-C selection of S1
- ITH=0
- 200 CONTINUE
- ITH=ITH+1
- IF(ITH.GT.200) THEN
- WRITE(LO,'(/1X,A,I10)')
- & 'PHO_SDECY3:ERROR: too many iterations',ITH
- CALL PHO_ABORT
- ENDIF
- S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
- Y=DT_RNDM(AM23)*SUPRHO
- RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
- IF(Y.GT.RHO) GOTO 200
-
-C selection of S2
- S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
- & /(2.D0*S2)-RHO/2.D0
- S3=UMO2+AM11+AM22+AM33-S1-S2
- ECM(1)=(UMO2+AM11-S2)/UMOO
- ECM(2)=(UMO2+AM22-S3)/UMOO
- ECM(3)=(UMO2+AM33-S1)/UMOO
- PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
- PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
- PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
-
-C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
- IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
- COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
- ELSE
- COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
- ENDIF
- COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
- & /(2.D0*PCM(2)*PCM(3))
- SINTH2=SQRT(1.D0-COSTH2*COSTH2)
- SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
- COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
-
-C selection of the sperical coordinates of particle 3
- CALL PHO_SFECFE(SIF(3),COF(3))
- IF(ISP.EQ.0) THEN
-C no polarization
- COD(3) = 2.D0*DT_RNDM(S2)-1.D0
- ELSE IF(ISP.EQ.1) THEN
-C transverse polarization
- 400 CONTINUE
- COD(3) = 2.D0*DT_RNDM(S1)-1.D0
- SID32 = 1.D0-COD(3)*COD(3)
- IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
- ELSE IF(ISP.EQ.2) THEN
-C longitudinal polarization
- 500 CONTINUE
- COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
- COD32 = COD(3)*COD(3)
- IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
- ELSE
- WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
- & 'invalid polarization',ISP
- CALL PHO_ABORT
- ENDIF
-
-C selection of the rotation angle of p1-p2 plane along p3
- IF(ISP.EQ.0) THEN
- CALL PHO_SFECFE(SFE,CFE)
- ELSE
- SFE = 0.D0
- CFE = 1.D0
- ENDIF
- CX11=-COSTH1
- CY11=SINTH1*CFE
- CZ11=SINTH1*SFE
- CX22=-COSTH2
- CY22=-SINTH2*CFE
- CZ22=-SINTH2*SFE
-
- SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
- COD(1)=CX11*COD(3)+CZ11*SID3
- IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
- WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
- & COD(1),COF(3),SID3,CX11,CZ11
- CALL PHO_PREVNT(-1)
- ENDIF
-
- SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
- COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
- SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
- COD(2)=CX22*COD(3)+CZ22*SID3
- SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
- COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
- SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
-
- END
-
-CDECK ID>, PHO_DFMASS
- DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
-C**********************************************************************
-C
-C sampling of Mx diffractive mass distribution within
-C limits XMIN, XMAX
-C
-C input: XMIN,XMAX mass limitations (GeV)
-C PREF2 original particle mass/ reference mass
-C (squared, GeV**2)
-C PVIRT2 particle virtuality
-C IMODE M**2 mass distribution
-C 1 1/(M**2+Q**2)
-C 2 1/(M**2+Q**2)**alpha
-C -1 1/(M**2-Mref**2+Q**2)
-C -2 1/(M**2-Mref**2+Q**2)**alpha
-C
-C output: diffractive mass (GeV)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(EPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
- WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
- & 'invalid mass limits',XMIN,XMAX,PREF2
- CALL PHO_PREVNT(-1)
- PHO_DFMASS = 0.135D0
- RETURN
- ENDIF
-
- IF(IMODE.GT.0) THEN
- PM2 = -PVIRT2
- ELSE
- PM2 = PREF2 - PVIRT2
- ENDIF
-
-C critical pomeron
- IF(ABS(IMODE).EQ.1) THEN
- XMIN2 = LOG(XMIN**2-PM2)
- XMAX2 = LOG(XMAX**2-PM2)
- XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
- XMA2 = EXP(XI)+PM2
-
-C supercritical pomeron
- ELSE IF(ABS(IMODE).EQ.2) THEN
- DDELTA = 1.D0-PARMDL(48)
- XMIN2 = (XMIN**2-PM2)**DDELTA
- XMAX2 = (XMAX**2-PM2)**DDELTA
- XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
- XMA2 = XI**(1.D0/DDELTA)+PM2
- ELSE
- WRITE(LO,'(/,1X,A,I3)')
- & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
- CALL PHO_ABORT
- ENDIF
-
- PHO_DFMASS = SQRT(XMA2)
-C debug output
- IF(IDEB(43).GE.15) THEN
- WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
- & XMIN,XMAX,PREF2,SQRT(XMA2)
- ENDIF
-
- END
-
-CDECK ID>, PHO_DIFSLP
- SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
- & TT,SLWGHT,IREJ)
-C**********************************************************************
-C
-C sampling of T (Mandelstam variable) distribution within
-C certain limits TMIN, TMAX
-C
-C input: IDF1,2 type of diffractive vertex
-C 0 elastic/quasi-elastic scattering
-C 1 diffraction dissociation
-C IVEC1,2 vector meson IDs in case of quasi-elastic
-C scattering, otherwise 0
-C XM1 mass of diffractive system 1 (GeV)
-C XM2 mass of diffractive system 2 (GeV)
-C XMX max. mass of diffractive system (GeV)
-C
-C output: TT squared momentum transfer ( < 0, GeV**2)
-C SLWGHT weight to allow for mass-dependent slope
-C IREJ 0 successful sampling
-C 1 masses too big for given T range
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(EPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C c.m. kinematics of diffraction
- INTEGER NPOSD
- DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
- & SIDD,CODD,SIFD,COFD,PDCMS
- COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
- & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
-C cross sections
- INTEGER IPFIL,IFAFIL,IFBFIL
- DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
- & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
- & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
- & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
- & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
- COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
- & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
- & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
- & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
- & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
- & IPFIL,IFAFIL,IFBFIL
-C Reggeon phenomenology parameters
- DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
- & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
- COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
- & ALREG,ALREGP,GR(2),B0REG(2),
- & GPPP,GPPR,B0PPP,B0PPR,
- & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
-C parameters of 2x2 channel model
- DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
- COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
-C parameters of the "simple" Vector Dominance Model
- DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
- COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- IREJ = 0
- XM12 = XM1**2
- XM22 = XM2**2
- SS = ECMD**2
-C
-C range of momentum transfer t
- TMIN = -PARMDL(68)
- TMAX = -PARMDL(69)
-C determine min. abs(t) necessary to produce masses
- PCM2 = PCMD**2
- PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
- IF(PCMP2.LE.0.D0) THEN
- IREJ = 1
- TT = 0.D0
- RETURN
- ENDIF
- TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
- & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
-C
- IF(TMINP.LT.TMAX) THEN
- IF(IDEB(44).GE.3) THEN
- WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
- & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
- & XM1,XM2,TMIN,TMAX,TMINP
- ENDIF
- IFAIL(32) = IFAIL(32)+1
- IREJ = 1
- TT = 0.D0
- RETURN
- ENDIF
- TMINA = MIN(TMIN,TMINP)
-C
-C calculation of slope (mass-dependent parametrization)
- IF(IDF1+IDF2.GT.0) THEN
-C diffraction dissociation
- XMP12 = XM1**2+PVIRTD(1)
- XMP22 = XM2**2+PVIRTD(2)
- XMX1 = SQRT(XMP12)
- XMX2 = SQRT(XMP22)
- CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
- FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
- SLOPE = DBLE(IDF1+IDF2)*B0PPP
- & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
- & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
- SLOPE = MAX(SLOPE,1.D0)
-C
- XMA1 = XMX
- XMA2 = XMX
- IF(IDF1.EQ.0) THEN
- XMA1 = XM1
- ELSE IF(IDF1.EQ.0) THEN
- XMA2 = XM2
- ENDIF
- XMP12 = XMA1**2+PVIRTD(1)
- XMP22 = XMA2**2+PVIRTD(2)
- XMX1 = SQRT(XMP12)
- XMX2 = SQRT(XMP22)
- CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
- SLMIN = DBLE(IDF1+IDF2)*B0PPP
- & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
- & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
- SLMIN = MAX(SLMIN,1.D0)
- ELSE
-C elastic/quasi-elastic scattering
- IF(ISWMDL(13).EQ.0) THEN
-C external slope values
- PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
- CALL PHO_ABORT
- ELSE IF(ISWMDL(13).EQ.1) THEN
-C model slopes
- IF(IVEC1*IVEC2.EQ.0) THEN
- SLOPE = SLOEL
- ELSE
- SLOPE = SLOVM(IVEC1,IVEC2)
- ENDIF
- SLMIN = SLOPE
- ELSE
- WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
- & ISWMDL(13)
- CALL PHO_ABORT
- ENDIF
- ENDIF
-C
-C determine max. abs(t) to avoid underflows
- TMAXP = -25.D0/SLOPE
- TMAXA = MAX(TMAX,TMAXP)
-C
- IF(TMINA.LT.TMAXA) THEN
- IF(IDEB(44).GE.3) THEN
- WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
- & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
- & XM1,XM2,TMINA,TMAXA,SLOPE
- ENDIF
- IFAIL(32) = IFAIL(32)+1
- IREJ = 1
- TT = 0.D0
- RETURN
- ENDIF
-C
-C sampling from corrected range of T
- TMINE = EXP(SLMIN*TMINA)
- TMAXE = EXP(SLMIN*TMAXA)
- XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
- TT = LOG(XI)/SLMIN
- SLWGHT = EXP((SLOPE-SLMIN)*TT)
-C
-C debug output
- IF(IDEB(44).GE.15) THEN
- WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
- & 'PHO_DIFSLP: sampled momentum transfer:',TT,
- & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
- & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
- ENDIF
- END
-
-CDECK ID>, PHO_DIFKIN
- SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
-C**********************************************************************
-C
-C calculation of diffractive kinematics
-C
-C input: XMP1 mass of outgoing particle system 1 (GeV)
-C XMP2 mass of outgoing particle system 2 (GeV)
-C TT momentum transfer (GeV**2, negative)
-C
-C output: PMOM1(5) four momentum of outgoing system 1
-C PMOM2(5) four momentum of outgoing system 2
-C IREJ 0 kinematics consistent
-C 1 kinematics inconsistent
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(EPS = 1.D-10,
- & DEPS = 0.001)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C c.m. kinematics of diffraction
- INTEGER NPOSD
- DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
- & SIDD,CODD,SIFD,COFD,PDCMS
- COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
- & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DOUBLE PRECISION PMOM1,PMOM2
- DIMENSION PMOM1(5),PMOM2(5)
-
-C debug output
- IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
- & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
- & ECMD,PCMD,XMP1,XMP2,TT
-
-C general kinematic constraints
- IREJ = 1
- IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
-
-C new squared cms momentum
- XMP12 = XMP1**2
- XMP22 = XMP2**2
- SS = ECMD**2
- PCM2 = PCMD**2
- PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
-
-C new longitudinal/transverse momentum
- E1I = SQRT(PCM2+PMASSD(1)**2)
- E1F = SQRT(PCMP2+XMP12)
- E2F = SQRT(PCMP2+XMP22)
- PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
- PTRAN = PCMP2-PLONG**2
-
-C check consistency of kinematics
- IF(PTRAN.LT.0.D0) THEN
- IF(IDEB(49).GE.1) THEN
- WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
- & 'inconsistent kinematics in event call: ',KEVENT
- WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
- & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
- & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
- ENDIF
- IREJ = 1
- RETURN
- ELSE
- PTRAN = SQRT(PTRAN)
- ENDIF
- XI = PI2*DT_RNDM(PTRAN)
-
-C outgoing momenta in cm. system
- PMOM1(4) = E1F
- PMOM1(1) = PTRAN*COS(XI)
- PMOM1(2) = PTRAN*SIN(XI)
- PMOM1(3) = PLONG
- PMOM1(5) = XMP1
-
- PMOM2(4) = E2F
- PMOM2(1) = -PMOM1(1)
- PMOM2(2) = -PMOM1(2)
- PMOM2(3) = -PLONG
- PMOM2(5) = XMP2
- IREJ = 0
-
-C debug output / precision check
- IF(IDEB(49).GE.0) THEN
-C check kinematics
- XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
- & -PMOM1(1)**2-PMOM1(2)**2
- XM1 = SIGN(SQRT(ABS(XM1)),XM1)
- XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
- & -PMOM2(1)**2-PMOM2(2)**2
- XM2 = SIGN(SQRT(ABS(XM2)),XM2)
- IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
- WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
- & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
- & XMP1,XM1,XMP2,XM2
- CALL PHO_PREVNT(-1)
- ENDIF
-C output
- IF(IDEB(49).GT.10) THEN
- WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
- & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_VECRES
- SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
-C**********************************************************************
-C
-C sampling of vector meson resonance in diffractive processes
-C (nothing done for hadrons)
-C
-C input: /POSVDM/ VDMFAC factors
-C
-C output: IVEC 0 incoming hadron
-C 1 rho 0
-C 2 omega
-C 3 phi
-C 4 pi+/pi- background
-C RMASS mass of vector meson (GeV)
-C IDPDG particle ID according to PDG
-C IDBAM particle ID according to CPC
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER(EPS = 1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C parameters of the "simple" Vector Dominance Model
- DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
- COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
-C particle code translation
- DIMENSION ITRANS(4)
-C rho0,omega,phi,pi+/pi-
- DATA ITRANS /113, 223, 333, 92 /
-
- IDPDO = IDPDG
-C
-C vector meson production
- IF(IDPDG.EQ.22) THEN
- XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
- SUM = 0.D0
- DO 55 K=1,4
- SUM = SUM + VMFA(K)
- IF(XI.LE.SUM) GOTO 65
- 55 CONTINUE
- 65 CONTINUE
-C
- IDPDG = ITRANS(K)
- IDBAM = ipho_pdg2id(IDPDG)
- IVEC = K
-C sample mass of vector meson
- CALL PHO_SAMASS(IDPDG,RMASS)
-
-C hadronic resonance of multi-pomeron coupling
- ELSE IF(IDPDG.EQ.990) THEN
- K = 4
- IDPDG = 91
- IDBAM = ipho_pdg2id(IDPDG)
- IVEC = 4
-C sample mass of two-pion system
- CALL PHO_SAMASS(IDPDG,RMASS)
-
-C hadron remnants in inucleus interactions
- ELSE IF(IDPDG.EQ.81) THEN
- IF(IHFLD(1,1).EQ.0) THEN
- CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
- CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
- ELSE
- CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
- ENDIF
- RMAS1 = PHO_PMASS(IDBA1,0)
- RMAS2 = PHO_PMASS(IDBA2,0)
- IF((IDBA2.NE.0).AND.
- & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
- IDBAM = IDBA2
- RMASS = RMAS2
- ELSE
- IDBAM = IDBA1
- RMASS = RMAS1
- ENDIF
- IDPDG = IPHO_ID2PDG(IDBAM)
- IVEC = 0
- ELSE IF(IDPDG.EQ.82) THEN
- IF(IHFLD(2,1).EQ.0) THEN
- CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
- CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
- ELSE
- CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
- ENDIF
- RMAS1 = PHO_PMASS(IDBA1,0)
- RMAS2 = PHO_PMASS(IDBA2,0)
- IF((IDBA2.NE.0).AND.
- & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
- IDBAM = IDBA2
- RMASS = RMAS2
- ELSE
- IDBAM = IDBA1
- RMASS = RMAS1
- ENDIF
- IDPDG = IPHO_ID2PDG(IDBAM)
- IVEC = 0
- ENDIF
-C debug output
- IF(IDEB(47).GE.5) THEN
- WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
- & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
- & IDPDO,IDPDG,IDBAM,RMASS
- ENDIF
-
- END
-
-CDECK ID>, PHO_DIFRES
- SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
- & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
-C**********************************************************************
-C
-C list of resonance states for low mass resonances
-C
-C input: IDMOTH PDG ID of mother particle
-C IVAL1,2 quarks (photon only)
-C
-C output: IDPDG list of PDG IDs for possible resonances
-C IDBAM list of corresponding CPC IDs
-C RMASS mass
-C RGAMS decay width
-C RMASS additional weight factor
-C LISTL entries in current list
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
-
- PARAMETER (EPS = 1.D-10,
- & DEPS = 1.D-15)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
- DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
- DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
- & 12212, 42212, -12212, -42212,
- & 8*0 /
- DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
- & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
- & 8*1.D0 /
-
- DATA init /0/
-
-C initialize table
- if(init.eq.0) then
- do i=1,20
- if(IRPDG(i).ne.0) then
- IRBAM(i) = ipho_pdg2id(IRPDG(i))
- endif
- enddo
- init = 1
- endif
-
-C copy table with particles and isospin weights
- LISTL = 0
- IF(IDMOTH.EQ.22) THEN
- I1 = 4
- I2 = 8
- ELSE IF(IDMOTH.EQ.2212) THEN
- I1 = 9
- I2 = 10
- ELSE IF(IDMOTH.EQ.-2212) THEN
- I1 = 11
- I2 = 12
- ELSE
- RETURN
- ENDIF
-
- DO 100 I=I1,I2
- LISTL = LISTL+1
- IDBAM(LISTL) = IRBAM(I)
- IDPDG(LISTL) = IRPDG(I)
- RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
- RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
- RWG(LISTL) = RWGHT(I)
- 100 CONTINUE
-
-C debug output
- IF(IDEB(85).GE.20) THEN
- WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
- & IVAL1,IVAL2
- DO 200 I=1,LISTL
- WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
- 200 CONTINUE
- ENDIF
-
- END
-
-CDECK ID>, PHO_MASSAD
- SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
- & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
-C***********************************************************************
-C
-C fine-correction of low mass strings to mass of corresponding
-C resonance or two particle threshold
-C
-C input: IFLMO PDG ID of mother particle
-C IFL1,2 requested parton flavours
-C (not used at the moment)
-C PMASS reference mass (mass of mother particle)
-C XMCON conjecture of mass
-C
-C output: XMOUT output mass (adjusted input mass)
-C moved ot nearest mass possible
-C IDPDG PDG resonance ID
-C IDcpc CPC resonance ID
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DEPS = 1.D-8 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-C particle decay data
- double precision wg_sec_list
- integer idec_list,isec_list
- COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
- & isec_list(3,500)
-
- DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
-
- XMINP = XMCON
- IDPDG = 0
- IDcpc = 0
- XMOUT = XMINP
-
-C resonance treatment activated?
- IF(ISWMDL(23).EQ.0) RETURN
-
- CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
- IF(LISTL.LT.1) THEN
- IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
- & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
- & IFLMO,IFL1,IFL2
- GOTO 50
- ENDIF
-C mass small?
- PMASSL = (PMASS+0.15D0)**2
- XMINP2 = XMINP**2
-C determine resonance probability
- DM2 = 1.1D0
- RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
- IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
-C sample new resonance
- XWGSUM = 0.D0
- DO 100 I=1,LISTL
- XWG(I) = RWG(I)/RMA(I)**2
- XWGSUM = XWGSUM+XWG(I)
- 100 CONTINUE
-
- ITER = 0
- 150 CONTINUE
- ITER = ITER+1
- IF(ITER.GE.5) THEN
- IDcpc = 0
- IDPDG = 0
- XMOUT = XMINP
- GOTO 50
- ENDIF
-
- I = 0
- XI = XWGSUM*DT_RNDM(XMOUT)
- 200 CONTINUE
- I = I+1
- XWGSUM = XWGSUM-XWG(I)
- IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
- IDPDG = IRPDG(I)
- IDcpc = IRBAM(I)
- GARES = RGA(I)
- XMRES = RMA(I)
- XMRES2 = XMRES**2
-C sample new mass (from Breit-Wigner cross section)
- ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
- AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
- XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
- XMOUT = XMRES*GARES*TAN(XI)+XMRES2
- XMOUT = SQRT(XMOUT)
-
-C check mass for decay
- AMDCY = 2.D0*XMRES
- ID = abs(IDcpc)
- DO 250 IK=idec_list(2,ID),idec_list(3,ID)
- AMSUM = 0.D0
- DO 275 I=1,3
- IF(isec_list(I,IK).NE.0)
- & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
- 275 CONTINUE
- AMDCY = MIN(AMDCY,AMSUM)
- 250 CONTINUE
- IF(AMDCY.GE.XMOUT) GOTO 150
-
-C debug output
- IF(IDEB(7).GE.10)
- & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
- & 'PHO_MASSAD: ',
- & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
- & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
- RETURN
- ENDIF
-
- 50 CONTINUE
-C debug output
- IF(IDEB(7).GE.15)
- & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
- & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
- & IFLMO,IFL1,IFL2,XMCON,XMOUT
-
- END
-
-CDECK ID>, PHO_PDF
- SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
-C***************************************************************
-C
-C call different PDF sets for different particle types
-C
-C input: NPAR 1 IGRP(1),ISET(1)
-C 2 IGRP(2),ISET(2)
-C X momentum fraction
-C SCALE2 squared scale (GeV**2)
-C P2VIR particle virtuality (positive, GeV**2)
-C
-C output PD(-6:6) field containing the x*PDF fractions
-C
-C***************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION PD(-6:6)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
- DIMENSION PARAM(20),VALUE(20)
- CHARACTER*20 PARAM
-
- REAL XR,P2R,Q2R,F2GM,XPDFGM
- DIMENSION XPDFGM(-6:6)
-
-C check of kinematic boundaries
- XI = X
- IF(X.GT.1.D0) THEN
- IF(IDEB(37).GE.0) THEN
- WRITE(LO,'(/,1X,A,E15.8/)')
- & 'PHO_PDF: x>1 (corrected to x=1)',X
- CALL PHO_PREVNT(-1)
- ENDIF
- XI = 0.99999999999D0
- ELSE IF(X.LE.0.D0) THEN
- IF(IDEB(37).GE.0) THEN
- WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
- CALL PHO_PREVNT(-1)
- ENDIF
- XI = 0.0001D0
- ENDIF
-
- DO 100 I=-6,6
- PD(I) = 0.D0
- 100 CONTINUE
- IRET = 1
-
- IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
-
-C internal PDFs
-
- IF(IEXT(NPAR).EQ.0) THEN
- IF(ITYPE(NPAR).EQ.1) THEN
-C proton PDFs
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.3) THEN
- CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
- UV = UDV-DV
- UDB = 2.D0*UDB
- DEL = 0.D0
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.4) THEN
- CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
- UV = UDV-DV
- UDB = 2.D0*UDB
- DEL = 0.D0
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.5) THEN
- CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
-C heavy quarks from GRV92-HO
- AMU2 = 0.3
- ALAM2 = 0.248 * 0.248
- S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
- SC = 0.820
- ALC = 0.98
- BEC = 0.0
- AKC = -0.625 - 0.523 * S
- AGC = 0.0
- BC = 1.896 + 1.616 * S
- DC = 4.12 + 0.683 * S
- EC = 4.36 + 1.328 * S
- ESC = 0.677 + 0.679 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
- SBO = 1.297
- ALB = 0.99
- BEB = 0.0
- AKB = 0.0 - 0.193 * S
- AGB = 0.0
- BBO = 0.0
- DB = 3.447 + 0.927 * S
- EB = 4.68 + 1.259 * S
- ESB = 1.892 + 2.199 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.6) THEN
- CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
-C heavy quarks from GRV92-LO
- AMU2 = 0.25
- ALAM2 = 0.232D0**2
- S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
- SC = 0.888
- ALC = 1.01
- BEC = 0.37
- AKC = 0.0
- AGC = 0.0
- BC = 4.24 - 0.804 * S
- DC = 3.46 + 1.076 * S
- EC = 4.61 + 1.490 * S
- ESC = 2.555 + 1.961 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
- SBO = 1.351
- ALB = 1.00
- BEB = 0.51
- AKB = 0.0
- AGB = 0.0
- BBO = 1.848
- DB = 2.929 + 1.396 * S
- EB = 4.71 + 1.514 * S
- ESB = 4.02 + 1.239 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.7) THEN
- CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
-C heavy quarks from GRV92-HO
- AMU2 = 0.3
- ALAM2 = 0.248 * 0.248
- S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
- SC = 0.820
- ALC = 0.98
- BEC = 0.0
- AKC = -0.625 - 0.523 * S
- AGC = 0.0
- BC = 1.896 + 1.616 * S
- DC = 4.12 + 0.683 * S
- EC = 4.36 + 1.328 * S
- ESC = 0.677 + 0.679 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
- SBO = 1.297
- ALB = 0.99
- BEB = 0.0
- AKB = 0.0 - 0.193 * S
- AGB = 0.0
- BBO = 0.0
- DB = 3.447 + 0.927 * S
- EB = 4.68 + 1.259 * S
- ESB = 1.892 + 2.199 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.8) THEN
- CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
- DEL = DS-US
- UDB = DS+US
-C heavy quarks from GRV92-LO
- AMU2 = 0.25
- ALAM2 = 0.232D0**2
- S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
- SC = 0.888
- ALC = 1.01
- BEC = 0.37
- AKC = 0.0
- AGC = 0.0
- BC = 4.24 - 0.804 * S
- DC = 3.46 + 1.076 * S
- EC = 4.61 + 1.490 * S
- ESC = 2.555 + 1.961 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
- SBO = 1.351
- ALB = 1.00
- BEB = 0.51
- AKB = 0.0
- AGB = 0.0
- BBO = 1.848
- DB = 2.929 + 1.396 * S
- EB = 4.71 + 1.514 * S
- ESB = 4.02 + 1.239 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.9) THEN
-* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
- DEL = DS-US
- UDB = DS+US
-C heavy quarks from GRV92-LO
- AMU2 = 0.25
- ALAM2 = 0.232D0**2
- S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
- SC = 0.888
- ALC = 1.01
- BEC = 0.37
- AKC = 0.0
- AGC = 0.0
- BC = 4.24 - 0.804 * S
- DC = 3.46 + 1.076 * S
- EC = 4.61 + 1.490 * S
- ESC = 2.555 + 1.961 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
- SBO = 1.351
- ALB = 1.00
- BEB = 0.51
- AKB = 0.0
- AGB = 0.0
- BBO = 1.848
- DB = 2.929 + 1.396 * S
- EB = 4.71 + 1.514 * S
- ESB = 4.02 + 1.239 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
- IRET = 0
- ENDIF
- PD(-5) = BB
- PD(-4) = CB
- PD(-3) = SB
- PD(-2) = 0.5D0*(UDB-DEL)
- PD(-1) = 0.5D0*(UDB+DEL)
- PD(0) = GL
- PD(1) = DV+PD(-1)
- PD(2) = UV+PD(-2)
- PD(3) = PD(-3)
- PD(4) = PD(-4)
- PD(5) = PD(-5)
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.2) THEN
-C pion PDFs (default for pi+)
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.1) THEN
- CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.2) THEN
- CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
- IRET = 0
- ENDIF
- PD(-5) = BB
- PD(-4) = CB
- PD(-3) = QB
- PD(-2) = QB
- PD(-1) = QB+VA
- PD(0) = GL
- PD(1) = QB
- PD(2) = VA+QB
- PD(3) = QB
- PD(4) = CB
- PD(5) = BB
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.3) THEN
-C photon PDFs
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.1) THEN
- CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.2) THEN
- CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
- IRET = 0
- ELSE IF(ISET(NPAR).EQ.3) THEN
- CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
- IRET = 0
- ENDIF
-C reweight with Drees-Godbole factor
- WGX = 1.D0
- IF(P2VIR.GT.0.001D0) THEN
- WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
- & /LOG(SCALE2/PARMDL(144))
- WGX = MAX(WGX,0.D0)
- ENDIF
- PD(-5) = BB*WGX/137.D0
- PD(-4) = CB*WGX/137.D0
- PD(-3) = SB*WGX/137.D0
- PD(-2) = UB*WGX/137.D0
- PD(-1) = DB*WGX/137.D0
- PD(0) = GL*WGX*WGX/137.D0
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- PD(3) = PD(-3)
- PD(4) = PD(-4)
- PD(5) = PD(-5)
- ELSE IF(IGRP(NPAR).EQ.8) THEN
- IF(ISET(NPAR).EQ.1) THEN
- CALL PHO_PHGAL (XI,SCALE2,PD)
- IRET = 0
- ENDIF
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.20) THEN
-C Pomeron PDFs
- MODE = IGRP(NPAR)
- IF(MODE.EQ.1) THEN
- PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
- IRET = 0
- ELSE IF(MODE.EQ.2) THEN
- PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
- IRET = 0
- ELSE IF(MODE.EQ.3) THEN
- PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
- IRET = 0
- ELSE IF(MODE.EQ.4) THEN
- CALL PHO_CKMTPD(990,XI,SCALE2,PD)
- DO 105 I=-4,4
- PD(I) = PD(I)*PARMDL(78)
- 105 CONTINUE
- IRET = 0
- ENDIF
- ENDIF
-
-C external PDFs
-
- ELSE IF(IEXT(NPAR).EQ.2) THEN
-C PDFLIB call: new PDF numbering
- IF(NPAR.NE.NPAOLD) THEN
- PARAM(1) = 'NPTYPE'
- PARAM(2) = 'NGROUP'
- PARAM(3) = 'NSET'
- PARAM(4) = ' '
- VALUE(1) = ITYPE(NPAR)
- VALUE(2) = ABS(IGRP(NPAR))
- VALUE(3) = ISET(NPAR)
- CALL PDFSET(PARAM,VALUE)
- ENDIF
- IF(ITYPE(NPAR).EQ.3) THEN
- IP2 = 0
- CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
- & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
- ELSE
- SCALE = SQRT(SCALE2)
- CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
- & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
- ENDIF
- DO 115 I=3,6
- PD(I) = PD(-I)
- 115 CONTINUE
- IF(ITYPE(NPAR).EQ.1) THEN
-C proton valence quarks
- PD(1) = PD(1)+PD(-1)
- PD(2) = PD(2)+PD(-2)
- ELSE IF(ITYPE(NPAR).EQ.2) THEN
-C pi+ valences
- DVAL = PD(1)
- PD(1) = PD(-1)
- PD(-1) = DVAL+PD(1)
- PD(2) = PD(2)+PD(-2)
- ELSE IF(ITYPE(NPAR).EQ.3) THEN
-C photon conventions
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- ENDIF
- IRET = 0
-
- ELSE IF(IEXT(NPAR).EQ.3) THEN
-C PHOLIB call: version 2.0
- CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
- IF(IRET.LT.0) THEN
- WRITE(LO,'(/1X,A,I2)')
- & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
- CALL PHO_ABORT
- ENDIF
- IRET = 0
-
-C photon PDFs depending on photon virtuality
-
- ELSE IF(IEXT(NPAR).EQ.4) THEN
- IF(IGRP(NPAR).EQ.1) THEN
-C Schuler/Sjostrand PDF (interface to single precision)
- XR = XI
- Q2R = SCALE2
- P2R = P2VIR
- IP2 = 0
- CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
- DO 120 I=-6,6
- PD(I) = DBLE(XPDFGM(I))
- 120 CONTINUE
- IRET = 0
- ELSE IF(IGRP(NPAR).EQ.5) THEN
-C Gluck/Reya/Stratmann
- IF(ISET(NPAR).EQ.4) THEN
- CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
- CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
- IRET = 0
- PD(-5) = 0.D0
- PD(-4) = CB
- PD(-3) = SB/137.D0
- PD(-2) = UB/137.D0
- PD(-1) = DB/137.D0
- PD(0) = GL/137.D0
- PD(1) = PD(-1)
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- PD(3) = PD(-3)
- PD(4) = PD(-4)
- PD(5) = PD(-5)
- ENDIF
- ENDIF
- ENDIF
-
-C check for errors
-
- IF(IRET.NE.0) THEN
- WRITE(LO,'(/1X,A,/10X,5I6)')
- & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
- & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
- CALL PHO_ABORT
- ENDIF
-C error in NPAR
- ELSE
- WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
- CALL PHO_ABORT
- ENDIF
- NPAOLD = NPAR
-
-C valence quark treatment
-
- IF(ITYPE(NPAR).EQ.2) THEN
-C meson conventions
- IF(IPARID(NPAR).EQ.111) THEN
-C pi0 valence quarks
- PD(-1) = (PD(1)+PD(-1))/2.D0
- PD(1) = PD(-1)
- PD(-2) = (PD(2)+PD(-2))/2.D0
- PD(2) = PD(-2)
- ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
-C K+/-
- VALS = PD(-1)-PD(1)
- PD(-1) = PD(1)
- PD(-3) = PD(-3)+VALS
- ELSE IF( (IPARID(NPAR).EQ.311)
- & .OR.(IPARID(NPAR).EQ.310)
- & .OR.(IPARID(NPAR).EQ.130)) THEN
-C neutral kaons
- VALS = PD(-1)-PD(1)
- VALU = PD(2)-PD(-2)
- PD(-1) = PD(1)
- PD(2) = PD(-2)
- PD(2) = PD(2)+VALU/2.D0
- PD(-2) = PD(-2)+VALU/2.D0
- PD(3) = PD(3)+VALS/2.D0
- PD(-3) = PD(-3)+VALS/2.D0
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.1) THEN
-C nucleon conventions
- IF(ABS(IPARID(NPAR)).EQ.2112) THEN
-C neutron valence quarks
- DUM = PD(1)
- PD(1) = PD(2)
- PD(2) = DUM
- ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
-C (anti-)sigma+
- VALS = PD(1)-PD(-1)
- PD(1) = PD(-1)
- PD(3) = PD(3)+VALS
- ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
-C (anti-)sigma-
- VALS = PD(1)-PD(-1)
- VALD = PD(2)-PD(-2)
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- PD(1) = PD(1)+VALD
- PD(3) = PD(3)+VALS
- ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
- & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
-C (anti-)sigma0 and (anti-)lambda
- VALS = PD(1)-PD(-1)
- VALD = (PD(2)-PD(-2))/2.D0
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- PD(1) = PD(1)+VALD
- PD(2) = PD(2)+VALD
- PD(3) = PD(3)+VALS
- ENDIF
- ENDIF
-
-C antiparticle
- IF(IPARID(NPAR).LT.0) THEN
- DO 190 I=1,4
- DUM=PD(I)
- PD(I)=PD(-I)
- PD(-I)=DUM
- 190 CONTINUE
- ENDIF
-
-C optionally remove valence quarks
- IF(IPAVA(NPAR).EQ.0) THEN
- DO 200 I=1,4
- PD(I) = MIN(PD(-I),PD(I))
- PD(-I) = PD(I)
- 200 CONTINUE
- ENDIF
-
-C debug information
- IF(IDEB(37).GE.30) WRITE(LO,
- & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
- & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
- & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
- & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
-
- END
-
-CDECK ID>, PHO_QPMPDF
- SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
-C***************************************************************
-C
-C contribution to photon PDF from box graph
-C (Bethe-Heitler process)
-C
-C input: IQ quark flavour
-C SCALE2 scale (GeV**2, positive)
-C PTREF reference scale (GeV, positive)
-C X parton momentum fraction
-C PVIRT photon virtuality (GeV**2, positive)
-C FXP x*f(x,Q**2), x times parton density
-C
-C***************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C internal rejection counters
- INTEGER NMXJ
- PARAMETER (NMXJ=60)
- CHARACTER*10 REJTIT
- INTEGER IFAIL
- COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DIMENSION QM(6)
- DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
-
- FXP = 0.D0
- I = ABS(IQ)
-C
-* QM2 = MAX(QM(I),PTREF)**2
-* QM2 = MAX(QM2,PVIRT)
-* BBE = (1.D0-X)*SCALE2
-* IF(BBE.LE.0.D0) THEN
-* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
-* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
-* & PVIRT,QM(I)
-* ENDIF
-* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
-* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
-C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
- QM2 = MAX(QM(I),PTREF)**2
- W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
- IF(W2.GT.4.D0*QM2) THEN
- BE = SQRT(1.D0-4.D0*QM2/W2)
- BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
- BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
-* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
- FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
- & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
- & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
- & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
- & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
- ELSE
- IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
- & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
- & PVIRT,QM(I)
- ENDIF
-C debug output
- IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
- & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
- END
-
-CDECK ID>, PHO_SETPDF
- SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
-C***************************************************************
-C
-C assigns PDF numbers to particles
-C
-C input: IDPDG PDG number of particle
-C ITYP particle type
-C IPAR PDF paramertization
-C ISET number of set
-C IEXT library number for PDF calculation
-C IPAVAL (only output)
-C 1 PDF with valence quarks
-C 0 PDF without valence quarks
-C MODE -1 add entry to table
-C 1 read from table
-C 2 output of table
-C
-C***************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
- DIMENSION IPDFS(5,50)
- DATA IENTRY / 0 /
-
- IF(MODE.EQ.1) THEN
- I = 1
- IF(IDPDG.EQ.81) THEN
- IDCMP = IDEQP(1)
- IPAVAL = IHFLS(1)
- ELSE IF(IDPDG.EQ.82) THEN
- IDCMP = IDEQP(2)
- IPAVAL = IHFLS(2)
- ELSE
- IDCMP = IDPDG
- IPAVAL = 1
- ENDIF
-200 CONTINUE
- IF(IDCMP.EQ.IPDFS(1,I)) THEN
- ITYP = IPDFS(2,I)
- IPAR = IPDFS(3,I)
- ISET = IPDFS(4,I)
- IEXT = IPDFS(5,I)
- IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
- & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
- RETURN
- ENDIF
- I = I+1
- IF(I.GT.IENTRY) THEN
- WRITE(LO,'(/1X,A,I7)')
- & 'PHO_SETPDF: no PDF assigned to ',IDCMP
- CALL PHO_ABORT
- ENDIF
- GOTO 200
- ELSE IF(MODE.EQ.-1) THEN
- DO 50 I=1,IENTRY
- IF(IDPDG.EQ.IPDFS(1,I)) THEN
- WRITE(LO,'(/1X,A,5I6)')
- & 'PHO_SETPDF: overwrite old particle PDF',
- & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
- GOTO 100
- ENDIF
- 50 CONTINUE
- I = IENTRY+1
- IF(I.GT.50) THEN
- WRITE(LO,'(/1X,A,/1x,6I6)')
- & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
- & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
- STOP
- ENDIF
- IENTRY = I
- 100 CONTINUE
- IPDFS(1,I) = IDPDG
- IF(IDPDG.EQ.990) THEN
- ITYP1 = 20
- ELSE IF(IDPDG.EQ.22) THEN
- ITYP1 = 3
- ELSE IF(ABS(IDPDG).LT.1000) THEN
- ITYP1 = 2
- ELSE
- ITYP1 = 1
- ENDIF
- IPDFS(2,I) = ITYP1
- IPDFS(3,I) = IPAR
- IPDFS(4,I) = ISET
- IPDFS(5,I) = IEXT
- ELSE IF(MODE.EQ.-2) THEN
- WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
- DO 150 I=1,IENTRY
- WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
- & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
- 150 CONTINUE
- ELSE
- WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
- ENDIF
- END
-
-CDECK ID>, PHO_GETPDF
- SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
-C***************************************************************
-C
-C get PDF information
-C
-C input: NPAR 1 first PDF in /POPPDF/
-C 2 second PDF in /POPPDF/
-C
-C output: PDFNA name of PDf parametrization
-C ALA QCD LAMBDA (4 flavours, in GeV)
-C Q2MI minimal Q2
-C Q2MA maximal Q2
-C XMI minimal X
-C XMA maximal X
-C
-C***************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- CHARACTER*8 PDFNA
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
-C PHOLIB 4.15 common
- COMMON /W50512/ QCDL4,QCDL5
- COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
-
-C PHOPDF version 2.0 common
- PARAMETER (MAXS=6,MAXP=10)
- CHARACTER*4 CHPAR
- COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
- & NSET(MAXP,2),NFL(MAXP)
- COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
-
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-
- DIMENSION PARAM(20),VALUE(20)
- CHARACTER*20 PARAM
-
- IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
- WRITE(LO,'(/1X,A,I6)')
- & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
- CALL PHO_ABORT
- ENDIF
- ALA = 0.D0
-
- IF(IEXT(NPAR).EQ.0) THEN
-
-C internal parametrizations
-
- IF(ITYPE(NPAR).EQ.1) THEN
-C proton PDFs
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.3) THEN
- ALA = 0.2D0
- Q2MI = 0.3D0
- PDFNA = 'GRV92 HO'
- ELSE IF(ISET(NPAR).EQ.4) THEN
- ALA = 0.2D0
- Q2MI = 0.25D0
- PDFNA = 'GRV92 LO'
- ELSE IF(ISET(NPAR).EQ.5) THEN
- ALA = 0.2D0
- Q2MI = 0.4D0
- PDFNA = 'GRV94 HO'
- ELSE IF(ISET(NPAR).EQ.6) THEN
- ALA = 0.2D0
- Q2MI = 0.4D0
- PDFNA = 'GRV94 LO'
- ELSE IF(ISET(NPAR).EQ.7) THEN
- ALA = 0.2D0
- Q2MI = 0.4D0
- PDFNA = 'GRV94 DI'
- ELSE IF(ISET(NPAR).EQ.8) THEN
- ALA = 0.175D0
- Q2MI = 0.8D0
- PDFNA = 'GRV98 LO'
- ELSE IF(ISET(NPAR).EQ.9) THEN
- ALA = 0.175D0
- Q2MI = 0.8D0
- PDFNA = 'GRV98 SC'
- ENDIF
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.2) THEN
-C pion PDFs
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.1) THEN
- ALA = 0.2D0
- Q2MI = 0.3D0
- PDFNA = 'GRV-P HO'
- ELSE IF(ISET(NPAR).EQ.2) THEN
- ALA = 0.2D0
- Q2MI = 0.25D0
- PDFNA = 'GRV-P LO'
- ENDIF
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.3) THEN
-C photon PDFs
- IF(IGRP(NPAR).EQ.5) THEN
- IF(ISET(NPAR).EQ.1) THEN
- ALA = 0.2D0
- Q2MI = 0.3D0
- PDFNA = 'GRV-G LH'
- ELSE IF(ISET(NPAR).EQ.2) THEN
- ALA = 0.2D0
- Q2MI = 0.3D0
- PDFNA = 'GRV-G HO'
- ELSE IF(ISET(NPAR).EQ.3) THEN
- ALA = 0.2D0
- Q2MI = 0.25D0
- PDFNA = 'GRV-G LO'
- ENDIF
- ELSE IF(IGRP(NPAR).EQ.8) THEN
- IF(ISET(NPAR).EQ.1) THEN
- ALA = 0.2D0
- Q2MI = 4.D0
- PDFNA = 'AGL-G LO'
- ENDIF
- ENDIF
- ELSE IF(ITYPE(NPAR).EQ.20) THEN
-C pomeron PDFs
- IF(IGRP(NPAR).EQ.4) THEN
- CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
- ELSE
- ALA = 0.3D0
- Q2MI = 2.D0
- PDFNA = 'POM-PDF1'
- ENDIF
- ENDIF
-
-C external parametrizations
-
- ELSE IF(IEXT(NPAR).EQ.1) THEN
-C PDFLIB call: old numbering
- PARAM(1) = 'MODE'
- PARAM(2) = ' '
- VALUE(1) = IGRP(NPAR)
- CALL PDFSET(PARAM,VALUE)
- Q2MI = Q2MIN
- Q2MA = Q2MAX
- XMI = XMIN
- XMA = XMAX
- ALA = QCDL4
- PDFNA = 'PDFLIB1'
- ELSE IF(IEXT(NPAR).EQ.2) THEN
-C PDFLIB call: new numbering
- PARAM(1) = 'NPTYPE'
- PARAM(2) = 'NGROUP'
- PARAM(3) = 'NSET'
- PARAM(4) = ' '
- VALUE(1) = ITYPE(NPAR)
- VALUE(2) = IGRP(NPAR)
- VALUE(3) = ISET(NPAR)
- CALL PDFSET(PARAM,VALUE)
- Q2MI = Q2MIN
- Q2MA = Q2MAX
- XMI = XMIN
- XMA = XMAX
- ALA = QCDL4
- PDFNA = 'PDFLIB2'
- ELSE IF(IEXT(NPAR).EQ.3) THEN
-C PHOLIB interface
- ALA = ALM(IGRP(NPAR),ISET(NPAR))
- Q2MI = 2.D0
- PDFNA = CHPAR(IGRP(NPAR))
-
-C some special internal parametrizations
-
- ELSE IF(IEXT(NPAR).EQ.4) THEN
-C photon PDFs depending on virtualities
- IF(IGRP(NPAR).EQ.1) THEN
-C Schuler/Sjostrand parametrization
- ALA = 0.2D0
- IF(ISET(NPAR).EQ.1) THEN
- Q2MI = 0.2D0
- PDFNA = 'SaS-1D '
- ELSE IF(ISET(NPAR).EQ.2) THEN
- Q2MI = 0.2D0
- PDFNA = 'SaS-1M '
- ELSE IF(ISET(NPAR).EQ.3) THEN
- Q2MI = 2.D0
- PDFNA = 'SaS-2D '
- ELSE IF(ISET(NPAR).EQ.4) THEN
- Q2MI = 2.D0
- PDFNA = 'SaS-2M '
- ENDIF
- ELSE IF(IGRP(NPAR).EQ.5) THEN
-C Gluck/Reya/Stratmann parametrization
- IF(ISET(NPAR).EQ.4) THEN
- ALA = 0.2D0
- Q2MI = 0.6D0
- PDFNA = 'GRS-G LO'
- ENDIF
- ENDIF
- ELSE IF(IEXT(NPAR).EQ.5) THEN
-C Schuler/Sjostrand anomalous only
- ALA = 0.2D0
- Q2MI = 0.2D0
- PDFNA = 'SaS anom'
- ENDIF
- IF(ALA.LT.0.01D0) THEN
- WRITE(LO,'(/1X,2A,/10X,5I6)')
- & 'PHO_GETPDF:ERROR: ',
- & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
- & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
- CALL PHO_ABORT
- ENDIF
-
- END
-
-CDECK ID>, PHO_ACTPDF
- SUBROUTINE PHO_ACTPDF(IDPDG,K)
-C***************************************************************
-C
-C activate PDF for QCD calculations
-C
-C input: IDPDG PDG particle number
-C K 1 first PDF in /POPPDF/
-C 2 second PDF in /POPPDF/
-C -2 write current settings
-C
-C output: /POPPDF/
-C
-C***************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-
- IF(K.GT.0) THEN
-
-C read PDF from table
- CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
- & IPAVA(K),1)
- IPARID(K) = IDPDG
-C get PDF parameters
- CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
-C initialize alpha_s calculation
- alam2 = PDFLAM(K)*PDFLAM(K)
- DUMMY = PHO_ALPHAS(alam2,-K)
-
- IF(IDEB(2).GE.20) THEN
- WRITE(LO,'(1X,A)')
- & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
- WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
- & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
- & IEXT(K),IPARID(K)
- ENDIF
- NPAOLD = K
-
- ELSE IF(K.EQ.-2) THEN
-
-C write table of current PDFs
- WRITE(LO,'(1X,A)')
- & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
- WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
- & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
- & IPARID(1)
- WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
- & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
- & IPARID(2)
-
- ELSE
-
- WRITE(LO,'(/1X,A,2I4)')
- & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
- CALL PHO_ABORT
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_PDFTST
- SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
-C*********************************************************************
-C
-C structure function test utility
-C
-C input: IDPDG PDG ID of particle
-C SCALE2 squared scale (GeV**2)
-C P2MASS particle virtuality (pos, GeV**2)
-C
-C output: tables of PDF, sum rule checking, table of F2
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C currently activated parton density parametrizations
- CHARACTER*8 PDFNAM
- INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
- DOUBLE PRECISION PDFLAM,PDFQ2M
- COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
- & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
- CHARACTER*8 PDFNA
-
- CALL PHO_ACTPDF(IDPDG,1)
- CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
-
- WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
- WRITE(LO,'(A)') ' ======================================='
-
- WRITE(LO,'(/,A,3I10)')
- & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
- WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
- WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
- WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
- WRITE(LO,'(/1X,A)') 'x times parton densities'
- WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
- WRITE(LO,'(1X,A)')
- & ' ============================================================'
-
-C logarithmic loop over x values
-C upper bound
- XUPPER=0.9999D0
-C lower bound
- XLOWER=1.D-4
-C number of steps
- NSTEP=50
-
- XFIRST=LOG(XLOWER)
- XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
- DO 100 I=1,NSTEP
- X=EXP(XFIRST)
- XCONTR=X
- CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
- IF(X.NE.XCONTR) THEN
- WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
- ENDIF
- WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
- XFIRST=XFIRST+XDELTA
- 100 CONTINUE
-
- IF(IDPDG.EQ.22) THEN
- WRITE(LO,'(/1X,A)')
- & 'comparison PDF to contribution due to box diagram'
- WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
- WRITE(LO,'(1X,A)')
- & ' ============================================================'
- XFIRST=LOG(XLOWER)
- XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
- DO 110 I=1,NSTEP
- X=EXP(XFIRST)
- CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
- DO 120 K=1,4
- CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
- 120 CONTINUE
- WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
- XFIRST=XFIRST+XDELTA
- 110 CONTINUE
- ENDIF
-
-C check momentum sum rule
-
- WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
- DO 199 I=-6,6
- PDSUM(I) = 0.D0
- PDAVE(I) = 0.D0
- 199 CONTINUE
- ITER=5000
- DO 200 I=1,ITER
- XX=DBLE(I)/DBLE(ITER)
- IF(XX.EQ.1.D0) XX = 0.999999D0
- CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
- DO 202 K=-6,6
- PDSUM(K) = PDSUM(K)+PD(K)/XX
- PDAVE(K) = PDAVE(K)+PD(K)
- 202 CONTINUE
- 200 CONTINUE
- WRITE(LO,'(1X,A)')
- & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
- XSUM = 0.D0
- DO 204 I=-6,6
- PDSUM(I) = PDSUM(I)/DBLE(ITER)
- PDAVE(I) = PDAVE(I)/DBLE(ITER)
- XSUM = XSUM+PDAVE(I)
- WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
- 204 CONTINUE
- WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
- DO 205 I=1,6
- WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
- 205 CONTINUE
- WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
- WRITE(LO,'(A/)') ' ============================================='
-
-C table of F2
-
- WRITE(LO,'(/1X,A,E12.4,/1X,A)')
- & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
- & '-----------------------------------------------------'
- ITER=100
- DO 300 I=1,ITER
- XX=DBLE(I)/DBLE(ITER)
- IF(XX.EQ.1.D0) XX = 0.9999D0
- CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
- F2 = 0.D0
- DO 302 K=-6,6
- IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
- 302 CONTINUE
- WRITE(LO,'(5X,1P,2E14.5)') XX,F2
- 300 CONTINUE
- WRITE(LO,'(A/)') ' ============================================='
- END
-
-CDECK ID>, PHO_REGPAR
- SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
- & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
-C**********************************************************************
-C
-C registration of particle in /POEVT1/ and /POEVT2/
-C
-C input: ISTH status code of particle
-C -2 initial parton hard scattering
-C -1 parton
-C 0 string
-C 1 visible particle (no color)
-C 2 decayed particle
-C IDPDG PDG particle ID code
-C IDBAM CPC particle ID code
-C JM1,JM2 first and second mother index
-C P1..P4 four momentum
-C IPHIS1 extended history information
-C IPHIS1<100: JM1 from particle 1
-C IPHIS1>100: JM1 from particle 2
-C 1 valence quark
-C 2 valence diquark
-C 3 sea quark
-C 4 sea diquark
-C (neg. for antipartons)
-C IPHIS2 extended history information
-C positive: JM2 from particle 1
-C negative: JM2 from particle 2
-C (see IPHIS1)
-C IC1,IC2 color labels for partons
-C IMODE 1 register given parton
-C 0 reset /POEVT1/ and /POEVT2/
-C 2 return data of entry IPOS
-C
-C IPOS position of particle in /POEVT1/
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (DEPS = 1.D-20)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- IF(IMODE.EQ.1) THEN
- IF(IDEB(76).GE.26) THEN
- WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
- & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
- & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
- WRITE(LO,'(1X,A,/2X,6I6)')
- & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
- & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
- ENDIF
- IF(NHEP.EQ.NMXHEP) THEN
- WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
- & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
- CALL PHO_ABORT
- ENDIF
- NHEP = NHEP+1
- IDBAMI = IDBAM
- IDPDGI = IDPDG
- IF(ABS(ISTH).LE.2) THEN
- IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
- IDPDGI = ipho_id2pdg(IDBAM)
- ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
- IDBAMI = ipho_pdg2id(IDPDG)
- ENDIF
- ENDIF
-C standard data
- ISTHEP(NHEP) = ISTH
- IDHEP(NHEP) = IDPDGI
- JMOHEP(1,NHEP) = JM1
- JMOHEP(2,NHEP) = JM2
-C update of mother-daugther relations
- IF(ABS(ISTH).LE.1) THEN
- IF(JM1.GT.0) THEN
- IF(JDAHEP(1,JM1).EQ.0) THEN
- JDAHEP(1,JM1) = NHEP
- ISTHEP(JM1) = 2
- ENDIF
- JDAHEP(2,JM1) = NHEP
- ENDIF
- IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
- IF(JDAHEP(1,JM2).EQ.0) THEN
- JDAHEP(1,JM2) = NHEP
- ISTHEP(JM2) = 2
- ENDIF
- JDAHEP(2,JM2) = NHEP
- ELSE IF(JM2.LT.0) THEN
- DO 100 II=JM1+1,-JM2
- IF(JDAHEP(1,II).EQ.0) THEN
- JDAHEP(1,II) = NHEP
- ISTHEP(II) = 2
- ENDIF
- JDAHEP(2,II) = NHEP
-100 CONTINUE
- ENDIF
- ENDIF
- PHEP(1,NHEP) = P1
- PHEP(2,NHEP) = P2
- PHEP(3,NHEP) = P3
- PHEP(4,NHEP) = P4
- IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
- TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
- PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
- ELSE
- PHEP(5,NHEP) = 0.D0
- ENDIF
- JDAHEP(1,NHEP) = 0
- JDAHEP(2,NHEP) = 0
-C extended information
- IMPART(NHEP) = IDBAMI
-C extended history information
- IPHIST(1,NHEP) = IPHIS1
- IPHIST(2,NHEP) = IPHIS2
-C charge/baryon number or color labels
- IF(ISTH.EQ.1) THEN
- ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
- ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
- ELSE
- ICOLOR(1,NHEP) = IC1
- ICOLOR(2,NHEP) = IC2
- ENDIF
-
- IPOS = NHEP
- IF(IDEB(76).GE.26) THEN
- WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
- & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
- & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
- & PHEP(5,NHEP),IPOS
- ENDIF
-
- ELSE IF(IMODE.EQ.0) THEN
- NHEP = 0
- ELSE IF(IMODE.EQ.2) THEN
- IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
- WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
- & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
- RETURN
- ENDIF
- ISTH = ISTHEP(IPOS)
- IDPDG = IDHEP(IPOS)
- IDBAM = IMPART(IPOS)
- JM1 = JMOHEP(1,IPOS)
- JM2 = JMOHEP(2,IPOS)
- P1 = PHEP(1,IPOS)
- P2 = PHEP(2,IPOS)
- P3 = PHEP(3,IPOS)
- P4 = PHEP(4,IPOS)
- IPHIS1= IPHIST(1,IPOS)
- IPHIS2= IPHIST(2,IPOS)
- IC1 = ICOLOR(1,IPOS)
- IC2 = ICOLOR(2,IPOS)
- ELSE
- WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
- ENDIF
- END
-
-CDECK ID>, IPHO_CNV1
- INTEGER FUNCTION IPHO_CNV1(IPART)
-C*********************************************************************
-C
-C conversion of quark numbering scheme to PARTICLE DATA GROUP
-C convention
-C
-C input: old internal particle code of hard scattering
-C 0 gluon
-C 1 d
-C 2 u
-C 3 s
-C 4 c
-C valence quarks changed to standard numbering
-C
-C output: standard particle codes
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-C
- II = ABS(IPART)
-C change gluon number
- IF(II.EQ.0) THEN
- IPHO_CNV1 = 21
-C change valence quark
- ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
- IPHO_CNV1 = SIGN(II-6,IPART)
- ELSE
- IPHO_CNV1 = IPART
- ENDIF
- END
-
-CDECK ID>, PHO_HACODE
- SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
-C*********************************************************************
-C
-C determination of hadron index from quarks
-C
-C input: ID1,ID2 parton code according to PDG conventions
-C
-C output: IDcpc1,2 CPC particle codes
-C
-C*********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID1,ID2,IDcpc1,IDcpc2
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C local variables
- integer ii,jj,kk,i1,i2
-
- IDcpc1 = 0
- IDcpc2 = 0
-
- if(ID1*ID2.lt.0) then
-C meson
- if(ID1.gt.0) then
- ii = ID1
- jj = -ID2
- else
- ii = ID2
- jj = -ID1
- endif
- IDcpc1 = ID_psm_list(ii,jj)
- IDcpc2 = ID_vem_list(ii,jj)
-
- else
-C baryon
- i1 = abs(ID1)
- i2 = abs(ID2)
- if(i1.gt.6) then
- ii = i1/1000
- jj = (i1-ii*1000)/100
- kk = i2
- else
- ii = i1
- jj = i2/1000
- kk = (i2-jj*1000)/100
- endif
- IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
- IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
-
- endif
-
- END
-
-CDECK ID>, PHO_ID2STR
- SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
-C*********************************************************************
-C
-C conversion of quark numbering scheme
-C
-C input: standard particle codes:
-C ID1
-C ID2
-C
-C output: NOBAM CPC string code
-C quark codes (PDG convention):
-C IBAM1
-C IBAM2
-C IBAM3
-C IBAM4
-C
-C NOBAM = -1 invalid flavour combinations
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- IDA1 = ABS(ID1)
- IDA2 = ABS(ID2)
-
-C quark-antiquark string
- IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
- IF((ID1*ID2).GE.0) GOTO 100
- IBAM1 = ID1
- IBAM2 = ID2
- IBAM3 = 0
- IBAM4 = 0
- NOBAM = 3
-C quark-diquark string
- ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
- IF((ID1*ID2).LE.0) GOTO 100
- IBAM1 = ID1
- IBAM2 = ID2/1000
- IBAM3 = (ID2-IBAM2*1000)/100
- IBAM4 = 0
- NOBAM = 4
-C diquark-quark string
- ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
- IF((ID1*ID2).LE.0) GOTO 100
- IBAM1 = ID1/1000
- IBAM2 = (ID1-IBAM1*1000)/100
- IBAM3 = ID2
- IBAM4 = 0
- NOBAM = 6
-C gluon-gluon string
- ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
- IBAM1 = 21
- IBAM2 = 21
- IBAM3 = 0
- IBAM4 = 0
- NOBAM = 7
-C diquark-antidiquark string
- ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
- IF((ID1*ID2).GE.0) GOTO 100
- IBAM1 = ID1/1000
- IBAM2 = (ID1-IBAM1*1000)/100
- IBAM3 = ID2/1000
- IBAM4 = (ID2-IBAM3*1000)/100
- NOBAM = 5
- ENDIF
- RETURN
-
-C invalid combination
- 100 CONTINUE
- WRITE(LO,'(//1X,A,2I10)')
- & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
- CALL PHO_ABORT
-
- END
-
-CDECK ID>, PHO_MKSLTR
- SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
-C********************************************************************
-C
-C calculate successive Lorentz boots for arbitrary Lorentz trans.
-C
-C input: P1 initial 4 vector
-C GAM(3),GAMB(3) Lorentz boost parameters
-C
-C output: P2 final 4 vector
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
-
- P2(4) = P1(4)
- DO 150 I=1,3
- P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
- P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
- 150 CONTINUE
- END
-
-CDECK ID>, PHO_GETLTR
- SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
-C********************************************************************
-C
-C calculate Lorentz boots for arbitrary Lorentz transformation
-C
-C input: P1 initial 4 vector
-C P2 final 4 vector
-C
-C output: GAM(3),GAMB(3)
-C DELE energy deviation
-C IREJ 0 success
-C 1 failure
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DREL = 0.001D0 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
-
- IREJ = 1
- DO 50 K=1,4
- PA(K) = P1(K)
- PP(K) = P1(K)
- 50 CONTINUE
- PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
- DO 100 I=1,3
- PP(I) = P2(I)
- PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
- IF(PP(4).LE.0.D0) RETURN
- PP(4) = SQRT(PP(4))
- GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
- & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
- GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
- GAMB(I) = GAMB(I)*GAM(I)
- DO 150 K=1,4
- PA(K) = PP(K)
- 150 CONTINUE
- 100 CONTINUE
- DELE = P2(4)-PP(4)
- IREJ = 0
-C consistency check
-* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
-* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
-* WRITE(LO,'(/1X,A,2E12.5)')
-* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
-* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
-* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
-* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
-* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
-* ENDIF
- END
-
-CDECK ID>, PHO_ALTRA
- SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
-C*********************************************************************
-C
-C arbitrary Lorentz transformation
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- EP=PCX*BGX+PCY*BGY+PCZ*BGZ
- PE=EP/(GA+1.D0)+EC
- PX=PCX+BGX*PE
- PY=PCY+BGY*PE
- PZ=PCZ+BGZ*PE
- P=SQRT(PX*PX+PY*PY+PZ*PZ)
- E=GA*EC+EP
-
- END
-
-CDECK ID>, PHO_LTRANS
- SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
- & PL,CXL,CYL,CZL,EL)
-C**********************************************************************
-C
-C Lorentz transformation into lab - system
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- SID=SQRT(1.D0-COD*COD)
- PLX=P*SID*COF
- PLY=P*SID*SIF
- PCMZ=P*COD
- PLZ=GAM*PCMZ+BGAM*ECM
- PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
- EL=GAM*ECM+BGAM*PCMZ
-
-C rotation into the original direction
- COZ=PLZ/PL
- SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
-
-* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
-
- AX=ABS(CX)
- AY=ABS(CY)
- IF(AX.LT.AY) THEN
- AMAX=AY
- AMIN=AX
- ELSE
- AMAX=AX
- AMIN=AY
- ENDIF
- IF (ABS(CX)-TINY) 1,1,2
- 1 IF (ABS(CY)-TINY) 3,3,2
-
- 3 CONTINUE
-* WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
- CXL=SIZ*COF
- CYL=SIZ*SIF
- CZL=COZ*CZ
-* WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
-* WRITE(LO,*) CXL,CYL,CZL
- RETURN
-
- 2 CONTINUE
- IF(AMAX.GT.TINY2) THEN
- AR=AMIN/AMAX
- AR=AR*AR
- A=AMAX*SQRT(1.D0+AR)
- ELSE
-* WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
- GOTO 3
- ENDIF
- XI=SIZ*COF
- YI=SIZ*SIF
- ZI=COZ
- CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
- CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
- CZL=A*YI+CZ*ZI
-
- END
-
-CDECK ID>, PHO_TRANS
- SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
-C**********************************************************************
-C
-C rotation of coordinate frame (1) de rotation around y axis
-C (2) fe rotation around z axis
-C (inverse rotation to PHO_TRANI)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
- Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
- Z=-SDE *XO +CDE *ZO
-
- END
-
-CDECK ID>, PHO_TRANI
- SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
-C**********************************************************************
-C
-C rotation of coordinate frame (1) -fe rotation around z axis
-C (2) -de rotation around y axis
-C (inverse rotation to PHO_TRANS)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
- Y=-SFE *XO+CFE* YO
- Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
-
- END
-
-CDECK ID>, pho_cpcini
- SUBROUTINE pho_cpcini(Nrows,Number,List)
-C***********************************************************************
-C
-C initialization of particle hash table
-C
-C input: Number vector with Nrows entries according to PDG
-C convention
-C
-C output: List vector with hash table
-C
-C (this code is based on the function initpns written by
-C Gerry Lynch, LBL, January 1990)
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- integer Number(*),List(*),Nrows
-
- Integer Nin,Nout,Ip,I
-
- do I = 1,577
- List(I) = 0
- enddo
-
-C Loop over all of the elements in the Number vector
-
- Do 500 Ip = 1,Nrows
- Nin = Number(Ip)
-
-C Calculate a list number for this particle id number
- If(Nin.Gt.99999.or.Nin.Le.0) Then
- Nout = -1
- Else If(Nin.Le.577) Then
- Nout = Nin
- Else
- Nout = Mod(Nin,577)
- End If
-
- 200 continue
-
- If(Nout.Lt.0) Then
-C Count the bad entries
- WRITE(LO,'(1x,a,i10)')
- & 'pho_cpcini: invalid particle ID',Nin
- Go to 500
- End If
- If(List(Nout).eq.0) Then
- List(Nout) = Ip
- Else
- If(Nin.eq.Number(List(Nout))) Then
- WRITE(LO,'(1x,a,i10)')
- & 'pho_cpcini: double particle ID',Nin
- End If
- Nout = Nout + 5
- If(Nout.Gt.577) Nout = Mod(Nout, 577)
-
- Go to 200
- End If
- 500 Continue
-
- END
-
-CDECK ID>, ipho_pdg2id
- INTEGER FUNCTION ipho_pdg2id(IDpdg)
-C**********************************************************************
-C
-C calculation internal particle code using the particle index i
-C according to the PDG proposal.
-C
-C input: IDpdg PDG particle number
-C output: ipho_pdg2id internal particle code
-C (0 for invalid IDpdg)
-C
-C the hash algorithm is based on a program by Gerry Lynch
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer IDpdg
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-
- integer Nin,Nout
- Nin = abs(IDpdg)
-
- if((Nin.gt.99999).or.(Nin.eq.0)) then
-C invalid particle number
- if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
- & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
- ipho_pdg2id = 0
- return
- else If(Nin.le.577) then
-C simple case
- Nout = Nin
- else
-C use hash algorithm
- Nout = mod(Nin,577)
- endif
-
- 100 continue
-
-C particle not in table
- if(ID_list(Nout).Eq.0) then
- if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
- & 'ipho_pdg2id: particle not in table ',IDpdg
- ipho_pdg2id = 0
- return
- endif
-
- if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
-C particle ID found
- ipho_pdg2id = sign(ID_list(Nout),IDpdg)
- return
- else
-C increment and try again
- Nout = Nout + 5
- If(Nout.gt.577) Nout = Mod(Nout,577)
- goto 100
- endif
-
- END
-
-CDECK ID>, IPHO_ID2PDG
- INTEGER FUNCTION ipho_id2pdg(IDcpc)
-C**********************************************************************
-C
-C conversion of internal particle code to PDG standard
-C
-C input: IDcpc internal particle number
-C output: ipho_id2pdg PDG particle number
-C (0 for invalid IDcpc)
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer IDcpc
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-
- integer IDabs
-
- IDabs = abs(IDcpc)
- if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
- ipho_id2pdg = 0
- return
- endif
-
- ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
-
- END
-
-CDECK ID>, IPHO_LU2PDG
- INTEGER FUNCTION IPHO_LU2PDG(LUKF)
-C**********************************************************************
-C
-C conversion of JETSET KF code to PDG code
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
- PARAMETER (NTAB=10)
- DIMENSION LU2PD(2,NTAB)
- DATA LU2PD / 4232, 4322,
- & 4322, 4232,
- & 3212, 3122,
- & 3122, 3212,
- & 30553, 20553,
- & 30443, 20443,
- & 20443, 10443,
- & 10443, 0,
- & 511, 0,
- & 10551, 551 /
-C
- DO 100 I=1,NTAB
- IF(LU2PD(1,I).EQ.LUKF) THEN
- IPHO_LU2PDG=LU2PD(2,I)
- RETURN
- ENDIF
- 100 CONTINUE
- IPHO_LU2PDG=LUKF
-
- END
-
-CDECK ID>, IPHO_PDG2LU
- INTEGER FUNCTION IPHO_PDG2LU(IPDG)
-C**********************************************************************
-C
-C conversion of PDG code to JETSET code
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
- PARAMETER (NTAB=8)
- DIMENSION LU2PD(2,NTAB)
- DATA LU2PD / 4232, 4322,
- & 4322, 4232,
- & 3212, 3122,
- & 3122, 3212,
- & 30553, 20553,
- & 30443, 20443,
- & 20443, 10443,
- & 10551, 551 /
-C
- DO 100 I=1,NTAB
- IF(LU2PD(2,I).EQ.IPDG) THEN
- IPHO_PDG2LU=LU2PD(1,I)
- RETURN
- ENDIF
- 100 CONTINUE
- IPHO_PDG2LU=IPDG
-
- END
-
-CDECK ID>, pho_pname
- CHARACTER*15 FUNCTION pho_pname(ID,mode)
-C***********************************************************************
-C
-C returns particle name for given ID number
-C
-C input: ID particle ID number
-C mode 0: ID treated as compressed particle code
-C 1: ID treated as PDG number
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID,mode
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C external functions
- integer ipho_id2pdg,ipho_pdg2id
-
-C local variables
- integer IDpdg,i,ii,k,l,ichar,i_anti
- character*15 name
-
- pho_pname = '(?????????????)'
-
- if(mode.eq.0) then
- i = ID
- IDpdg = ipho_id2pdg(ID)
- if(IDpdg.eq.0) return
- else if(mode.eq.1) then
- i = ipho_pdg2id(ID)
- if(i.eq.0) return
- IDpdg = ID
- else if(mode.eq.2) then
- if(ISTHEP(ID).gt.11) then
- if(ISTHEP(ID).eq.20) then
- pho_pname = 'hard ini. part.'
- else if(ISTHEP(ID).eq.21) then
- pho_pname = 'hard fin. part.'
- else if(ISTHEP(ID).eq.25) then
- pho_pname = 'hard scattering'
- else if(ISTHEP(ID).eq.30) then
- pho_pname = 'diff. diss. '
- else if(ISTHEP(ID).eq.35) then
- pho_pname = 'elastic scatt. '
- else if(ISTHEP(ID).eq.40) then
- pho_pname = 'central scatt. '
- endif
- return
- endif
- IDpdg = IDHEP(ID)
- i = IMPART(ID)
- else
- WRITE(LO,'(1x,a,2i4)')
- & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
- return
- endif
-
- ii = abs(i)
- if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
-
- name = name_list(ii)
- ichar = ich3_list(ii)*sign(1,i)
- if(mod(ichar,3).ne.0) then
- ichar = 0
- else
- ichar = ichar/3
- endif
-
-C find position of first blank character
- k = 1
- 100 continue
- k = k+1
- if(name(k:k).ne.' ') goto 100
-
-C append anti-particle sign
- if(i.lt.0) then
- i_anti = 0
- do l=1,3
- i_anti = i_anti+iq_list(l,ii)
- enddo
- if(iba3_list(ii).ne.0) then
- name(k:k) = '~'
- k = K+1
- else if(((i_anti.ne.0).and.(ichar.eq.0))
- & .or.(IDpdg.eq.-12)
- & .or.(IDpdg.eq.-14)
- & .or.(IDpdg.eq.-16)) then
- name(k:k) = '~'
- k = K+1
- endif
- endif
-
-C append charge sign
- if(ichar.eq.-2) then
- name(k:k+1) = '--'
- else if(ichar.eq.-1) then
- name(k:k) = '-'
- else if(ichar.eq.1) then
- name(k:k) = '+'
- else if(ichar.eq.2) then
- name(k:k+1) = '++'
- endif
-
- pho_pname = name
-
- END
-
-CDECK ID>, ipho_anti
- INTEGER FUNCTION ipho_anti(ID)
-C**********************************************************************
-C
-C determine antiparticle for given ID
-C
-C input: ID gives CPC particle number
-C
-C output: ipho_anti antiparticle code
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C external functions
- integer ipho_id2pdg,ipho_pdg2id
-
-C local variables
- integer IDabs,IDpdg,i_anti,l
-
- ipho_anti = -ID
- IDabs = abs(ID)
-
-C baryons
- if(iba3_list(IDabs).ne.0) return
-
-C charged particles
- if(ich3_list(IDabs).ne.0) return
-
-C K0_s and K0_l
- IDpdg = ipho_id2pdg(ID)
- if(IDpdg.eq.310) then
- ID = ipho_pdg2id(130)
- return
- else if(IDpdg.eq.130) then
- ID = ipho_pdg2id(310)
- return
- endif
-
-C neutral mesons with open strangeness, charm, or beauty
- i_anti = 0
- do l=1,3
- i_anti = i_anti+iq_list(l,IDabs)
- enddo
- if(i_anti.ne.0) return
-
-C neutrinos
- IDpdg = abs(IDpdg)
- if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
-
- ipho_anti = ID
-
- END
-
-CDECK ID>, ipho_chr3
- INTEGER FUNCTION ipho_chr3(ID,mode)
-C**********************************************************************
-C
-C output of three times the electric charge
-C
-C input: mode
-C 0 ID gives CPC particle number
-C 1 ID gives PDG particle number
-C 2 ID gives position of particle in /POEVT1/
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID,mode
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C external functions
- integer ipho_pdg2id
-
-C local variables
- integer i,IDpdg
-
- ipho_chr3 = 0
-
- if(mode.eq.0) then
- i = ID
- else if(mode.eq.1) then
- i = ipho_pdg2id(ID)
- if(i.eq.0) return
- IDpdg = ID
- else if(mode.eq.2) then
- if(ISTHEP(ID).gt.11) return
- i = IMPART(ID)
- IDpdg = IDHEP(ID)
- IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
- ipho_chr3 = ICOLOR(1,ID)
- return
- endif
- else
- WRITE(LO,'(1x,a,2i4)')
- & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
- return
- endif
-
- if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
- WRITE(LO,'(1x,a,3i8)')
- & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
- ipho_chr3 = 1.D0/dble(i)
- call pho_prevnt(0)
- return
- endif
-
- ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
-
- END
-
-CDECK ID>, ipho_bar3
- INTEGER FUNCTION ipho_bar3(ID,mode)
-C**********************************************************************
-C
-C output of three times the baryon charge
-C
-C index: MODE
-C 0 ID gives CPC particle number
-C 1 ID gives PDG particle number
-C 2 ID gives position of particle in /POEVT1/
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID,mode
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C external functions
- integer ipho_pdg2id
-
-C local variables
- integer i,IDpdg
-
- ipho_bar3 = 0
-
- if(mode.eq.0) then
- i = ID
- else if(mode.eq.1) then
- i = ipho_pdg2id(ID)
- if(i.eq.0) return
- IDpdg = ID
- else if(mode.eq.2) then
- if(ISTHEP(ID).gt.11) return
- i = IMPART(ID)
- IDpdg = IDHEP(ID)
- IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
- ipho_bar3 = ICOLOR(2,ID)
- return
- endif
- else
- WRITE(LO,'(1x,a,2i4)')
- & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
- return
- endif
-
- if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
- WRITE(LO,'(1x,a,3i8)')
- & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
- ipho_bar3 = 1.D0/dble(i)
- return
- endif
-
- ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
-
- END
-
-CDECK ID>, pho_pmass
- DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
-C***********************************************************************
-C
-C particle mass
-C
-C input: mode -1 initialization
-C 0 ID gives CPC particle number
-C 1 ID gives PDG particle number,
-C (for quarks current masses are returned)
-C 2 ID gives position of particle in /POEVT1/
-C 3 ID gives PDG parton number,
-C (for quarks constituent masses are returned)
-C
-C output: average particle mass (in GeV)
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer ID,mode,MSTJ24
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
- INTEGER MSTU,MSTJ
- DOUBLE PRECISION PARU,PARJ
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-
-C external functions
- integer ipho_pdg2id,ipho_id2pdg
-
- DOUBLE PRECISION PYMASS
-
-C local variables
- integer i,IDpdg
-
- pho_pmass = 0.D0
-
- if(mode.eq.0) then
- i = ID
- else if(mode.eq.1) then
- i = ipho_pdg2id(ID)
- if(i.eq.0) return
- else if(mode.eq.2) then
- if(ISTHEP(ID).gt.11) return
- i = IMPART(ID)
- IDpdg = IDHEP(ID)
- IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
- pho_pmass = PHEP(5,ID)
- return
- endif
- else if(mode.eq.3) then
- i = abs(ID)
- if((i.gt.0).and.(i.le.6)) then
- pho_pmass = PARMDL(150+i)
- return
- else
- i = ipho_pdg2id(ID)
- if(i.eq.0) return
- endif
- else if(mode.eq.-1) then
-C initialization: take masses for quarks and di-quarks from JETSET
- MSTJ24 = MSTJ(24)
- MSTJ(24) = 0
- do i=1,22
- IDpdg = ipho_id2pdg(i)
-
- xm_list(i) = PYMASS(IDpdg)
-
- enddo
- MSTJ(24) = MSTJ24
- return
- else
- WRITE(LO,'(1x,a,2i4)')
- & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
- return
- endif
-
- if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
- WRITE(LO,'(1x,a,2i8)')
- & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
- pho_pmass = 1.D0/dble(i)
- return
- endif
-
- pho_pmass = xm_list(iabs(i))
-
- END
-
-CDECK ID>, PHO_MEMASS
- SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
-C**********************************************************************
-C
-C determine meson masses corresponding to the input flavours
-C
-C input: I,J,K quark flavours (PDG convention)
-C
-C output: AMPS pseudo scalar meson mass
-C AMPS2 next possible two particle configuration
-C (two pseudo scalar mesons)
-C AMVE vector meson mass
-C AMVE2 next possible two particle configuration
-C (two vector mesons)
-C IPS,IVE meson numbers in CPC
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer I,J,IPS,IVE
- double precision AMPS,AMPS2,AMVE,AMVE2
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C local variables
- integer ii,jj
-
- IF(I.GT.0) THEN
- ii = I
- jj = -J
- ELSE
- ii = J
- jj = -I
- ENDIF
-
-C particle ID's
- IPS = id_psm_list(ii,jj)
- IVE = id_vem_list(ii,jj)
-C masses
- if(IPS.ne.0) then
- AMPS = xm_list(iabs(IPS))
- else
- AMPS = 0.D0
- endif
- if(IVE.ne.0) then
- AMVE = xm_list(iabs(IVE))
- else
- AMVE = 0.D0
- endif
-
-C next possible two-particle configurations (add phase space)
- AMPS2 = xm_psm2_list(ii,jj)*1.5D0
- AMVE2 = xm_vem2_list(ii,jj)*1.1D0
-
- END
-
-CDECK ID>, PHO_BAMASS
- SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
-C**********************************************************************
-C
-C determine baryon masses corresponding to the input flavours
-C
-C input: I,J,K quark flavours (PDG convention)
-C
-C output: AM8 octett baryon mass
-C AM82 next possible two particle configuration
-C (octett baryon and meson)
-C AM10 decuplett baryon mass
-C AM102 next possible two particle configuration
-C (decuplett baryon and meson,
-C baryon built up from first two quarks)
-C I8,I10 internal baryon numbers
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer I,J,K,I8,I10
- double precision AM8,AM82,AM10,AM102
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C local variables
- integer ii,jj,kk
-
-C find particle ID's
- ii = iabs(I)
- jj = iabs(J)
- kk = iabs(K)
- I8 = id_b8_list(ii,jj,kk)
- I10 = id_b10_list(ii,jj,kk)
-
-C masses (if combination possible)
- if(I8.ne.0) then
- AM8 = xm_list(I8)
- I8 = sign(I8,i)
- else
- AM8 = 0.D0
- endif
- if(I10.ne.0) then
- AM10 = xm_list(I10)
- I10 = sign(I10,i)
- else
- AM10 = 0.D0
- endif
-
-C next possible two-particle configurations (add phase space)
- AM82 = xm_b82_list(ii,jj,kk)*1.5D0
- AM102 = xm_b102_list(ii,jj,kk)*1.1D0
-
- END
-
-CDECK ID>, PHO_DQMASS
- SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
-C**********************************************************************
-C
-C determine minimal masses corresponding to the input flavours
-C (diquark a-diquark string system)
-C
-C input: I,J,K,L quark flavours (PDG convention)
-C
-C output: AM82 mass of two octett baryons
-C AM102 mass of two decuplett baryons
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer I,J,K,L
- double precision AM82,AM102
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-
-C local variables
- integer ii,jj,kk,ll
-
- ii = iabs(i)
- kk = iabs(k)
- jj = iabs(j)
- ll = iabs(l)
-
- AM82 = xm_bb82_list(ii,jj,kk,ll)
- AM102 = xm_bb102_list(ii,jj,kk,ll)
-
- END
-
-CDECK ID>, PHO_CHECK
- SUBROUTINE PHO_CHECK(MD,IDEV)
-C**********************************************************************
-C
-C check quantum numbers of entries in /POEVT1/ and /POEVT2/
-C (energy, momentum, charge, baryon number conservation)
-C
-C input: MD -1 check overall momentum conservation
-C and perform detailed check only in case of
-C deviations
-C 1 test all branchings, mother-daughter
-C relations
-C
-C output: IDEV 0 no deviations
-C 1 deviations found
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
-C count number of errors to avoid disk overflow
- DATA IERR / 0 /
-
- IDEV = 0
-C conservation check suppressed
- IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
-
- IF(IPAMDL(13).GT.0) THEN
-
-C DPMJET call with x limitations
- MODE = -1
- ECM1 = SQRT(XPSUB*XTSUB)*ECM
-
- ELSE
-
-C standard call
- MODE = MD
-C first two entries are considered as scattering particles
- EE1 = PHEP(4,1) + PHEP(4,2)
- PX1 = PHEP(1,1) + PHEP(1,2)
- PY1 = PHEP(2,1) + PHEP(2,2)
- PZ1 = PHEP(3,1) + PHEP(3,2)
-
- ENDIF
-
- DDREL = PARMDL(75)
- DDABS = PARMDL(76)
- IF(MODE.EQ.-1) GOTO 500
-
- 50 CONTINUE
-
- I = 1
- 100 CONTINUE
-
-C recognize only decayed particles as mothers
- IF(ISTHEP(I).EQ.2) THEN
-C search for other mother particles
- K = JDAHEP(1,I)
- IF(K.EQ.0) THEN
- IF(IPAMDL(178).NE.0)
- & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
- & 'entry marked as decayed but no dauther given:',I
- GOTO 99
- ENDIF
- K1 = JMOHEP(1,K)
- K2 = JMOHEP(2,K)
-C sum over mother particles
- ICH1 = IPHO_CHR3(K1,2)
- IBA1 = IPHO_BAR3(K1,2)
- EE1 = PHEP(4,K1)
- PX1 = PHEP(1,K1)
- PY1 = PHEP(2,K1)
- PZ1 = PHEP(3,K1)
- IF(K2.LT.0) THEN
- K2 = -K2
- IF((K1.GT.I).OR.(K2.LT.I)) THEN
- WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
- & 'inconsistent mother/daughter relation found',I,K1,K2
- CALL PHO_PREVNT(-1)
- ENDIF
- DO 400 II=K1+1,K2
- IF(ABS(ISTHEP(II)).LE.2) THEN
- ICH1 = ICH1 + IPHO_CHR3(II,2)
- IBA1 = IBA1 + IPHO_BAR3(II,2)
- EE1 = EE1 + PHEP(4,II)
- PX1 = PX1 + PHEP(1,II)
- PY1 = PY1 + PHEP(2,II)
- PZ1 = PZ1 + PHEP(3,II)
- ENDIF
- 400 CONTINUE
- ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
- ICH1 = ICH1 + IPHO_CHR3(K2,2)
- IBA1 = IBA1 + IPHO_BAR3(K2,2)
- EE1 = EE1 + PHEP(4,K2)
- PX1 = PX1 + PHEP(1,K2)
- PY1 = PY1 + PHEP(2,K2)
- PZ1 = PZ1 + PHEP(3,K2)
- ENDIF
-
-C sum over daughter particles
- ICH2 = 0.D0
- IBA2 = 0.D0
- EE2 = 0.D0
- PX2 = 0.D0
- PY2 = 0.D0
- PZ2 = 0.D0
- DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
- IF(ABS(ISTHEP(II)).LE.2) THEN
- ICH2 = ICH2 + IPHO_CHR3(II,2)
- IBA2 = IBA2 + IPHO_BAR3(II,2)
- EE2 = EE2 + PHEP(4,II)
- PX2 = PX2 + PHEP(1,II)
- PY2 = PY2 + PHEP(2,II)
- PZ2 = PZ2 + PHEP(3,II)
- ENDIF
- 200 CONTINUE
-
-C conservation check
- ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
- IF(ABS(EE1-EE2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
- & 'PHO_CHECK: energy conservation violated for',
- & 'entry,initial,final:',I,EE1,EE2
- IDEV = 1
- ENDIF
- ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
- IF(ABS(PX1-PX2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
- & 'PHO_CHECK: x-momentum conservation violated for',
- & 'entry,initial,final:',I,PX1,PX2
- IDEV = 1
- ENDIF
- ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
- IF(ABS(PY1-PY2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
- & 'PHO_CHECK: y-momentum conservation violated for',
- & 'entry,initial,final:',I,PY1,PY2
- IDEV = 1
- ENDIF
- ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
- IF(ABS(PZ1-PZ2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
- & 'PHO_CHECK: z-momentum conservation violated for',
- & 'entry,initial,final:',I,PZ1,PZ2
- IDEV = 1
- ENDIF
- IF(ICH1.NE.ICH2) THEN
- WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
- & 'PHO_CHECK: charge conservation violated for',
- & 'entry,initial,final:',I,ICH1,ICH2
- IDEV = 1
- ENDIF
- IF(IBA1.NE.IBA2) THEN
- WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
- & 'baryon charge conservation violated for',
- & 'entry,initial,final:',I,IBA1,IBA2
- IDEV = 1
- ENDIF
- IF(IDEB(20).GE.35) THEN
- WRITE(LO,
- & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
- & 'PHO_CHECK diagnostics:',
- & '(1.mother/l.mother,1.daughter/l.daughter):',
- & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
- & 'mother momenta ',PX1,PY1,PZ1,EE1,
- & 'daughter momenta ',PX2,PY2,PZ2,EE2,
- & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
- ENDIF
- ENDIF
- 99 CONTINUE
- I = I+1
- IF(I.LE.NHEP) GOTO 100
-
- 55 CONTINUE
-
- IERR = IERR+IDEV
-
-C write complete event in case of deviations
- IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
- CALL PHO_PREVNT(1)
- IF(ISTR.GT.0) THEN
- CALL PHO_PRSTRG
-
- IF(ISWMDL(6).GE.0) CALL PYLIST(1)
-
- ENDIF
- ENDIF
-
-C stop after too many errors
- IF(IERR.GT.IPAMDL(179)) THEN
- WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
- & 'too many inconsistencies found, program terminated',IERR
- CALL PHO_ABORT
- ENDIF
-
- RETURN
-
-C overall check only (less time consuming)
-
- 500 CONTINUE
-
- ICH2 = 0.D0
- IBA2 = 0.D0
- EE2 = 0.D0
- PX2 = 0.D0
- PY2 = 0.D0
- PZ2 = 0.D0
-
- DO 300 K=3,NHEP
-C recognize only existing particles as possible daughters
- IF(ABS(ISTHEP(K)).EQ.1) THEN
- ICH2 = ICH2 + IPHO_CHR3(K,2)
- IBA2 = IBA2 + IPHO_BAR3(K,2)
- EE2 = EE2 + PHEP(4,K)
- PX2 = PX2 + PHEP(1,K)
- PY2 = PY2 + PHEP(2,K)
- PZ2 = PZ2 + PHEP(3,K)
- ENDIF
- 300 CONTINUE
-
-C check energy-momentum conservation
- ESC = ECM*DDREL
-
- IF(IPAMDL(13).GT.0) THEN
-
-C DPMJET call with x limitations
- ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
- IF(ABS(ECM1-ECM2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
- & 'PHO_CHECK: c.m. energy conservation violated',
- & 'initial/final energy:',ECM1,ECM2
- IDEV = 1
- ENDIF
-
- ELSE
-
-C standard call
- IF(ABS(EE1-EE2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
- & 'PHO_CHECK: energy conservation violated',
- & 'initial/final energy:',EE1,EE2
- IDEV = 1
- ENDIF
- IF(ABS(PX1-PX2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
- & 'PHO_CHECK: x-momentum conservation violated',
- & 'initial/final x-momentum:',PX1,PX2
- IDEV = 1
- ENDIF
- IF(ABS(PY1-PY2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
- & 'PHO_CHECK: y-momentum conservation violated',
- & 'initial/final y-momentum:',PY1,PY2
- IDEV = 1
- ENDIF
- IF(ABS(PZ1-PZ2).GT.ESC) THEN
- WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
- & 'PHO_CHECK: z-momentum conservation violated',
- & 'initial/final z-momentum:',PZ1,PZ2
- IDEV = 1
- ENDIF
-
-C check of quantum number conservation
-
- ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
- IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
-
- IF(ICH1.NE.ICH2) THEN
- WRITE(LO,'(1X,A,/,5X,A,2I5)')
- & 'PHO_CHECK: charge conservation violated',
- & 'initial/final charge sum',ICH1,ICH2
- IDEV = 1
- ENDIF
- IF(IBA1.NE.IBA2) THEN
- WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
- & 'baryonic charge conservation violated',
- & 'initial/final baryonic charge sum',IBA1,IBA2
- IDEV = 1
- ENDIF
-
- ENDIF
-
-C perform detailed checks in case of deviations
- IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
- IF(IPAMDL(13).GT.0) THEN
- GOTO 55
- ELSE
- DDREL = DDREL/2.D0
- DDABS = DDABS/2.D0
- WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
- & 'increasing precision of tests to',DDREL,DDABS
- GOTO 50
- ENDIF
- ENDIF
-
- END
-
-CDECK ID>, PHO_ABORT
- SUBROUTINE PHO_ABORT
-C**********************************************************************
-C
-C top MC event generation due to fatal error,
-C print all information of event generation and history
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-C light-cone x fractions and c.m. momenta of soft cut string ends
- INTEGER MAXSOF
- PARAMETER ( MAXSOF = 50 )
- INTEGER IJSI2,IJSI1
- DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
- COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
- & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
- & IJSI1(MAXSOF),IJSI2(MAXSOF)
-C hard scattering data
- INTEGER MSCAHD
- PARAMETER ( MSCAHD = 50 )
- INTEGER LSCAHD,LSC1HD,LSIDX,
- & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
- DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
- COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
- & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
- & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
- & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
- & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
- & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
- & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
-
- WRITE(LO,'(//,1X,A,/,1X,A)')
- & 'PHO_ABORT: program execution stopped',
- & '===================================='
- WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
-C
- CALL PHO_SETMDL(0,0,-2)
- CALL PHO_PREVNT(-1)
- CALL PHO_ACTPDF(0,-2)
-C print selected parton flavours
- WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
- DO 700 I=1,KSOFT
- WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
- 700 CONTINUE
- WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
- DO 750 K=1,KHARD
- I = LSIDX(K)
- WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
- WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
- & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
- 750 CONTINUE
-C print selected parton momenta
- WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
- DO 300 I=1,KSOFT
- WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
- WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
- 300 CONTINUE
- WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
- DO 350 K=1,KHARD
- I = LSIDX(K)
- I3 = 8*I-4
- WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
- WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
- 350 CONTINUE
-
-C print /POEVT1/
- CALL PHO_PREVNT(0)
-
-C fragmentation process
- IF(ISTR.GT.0) THEN
-C print /POSTRG/
- CALL PHO_PRSTRG
-
- IF(ISWMDL(6).GE.0) CALL PYLIST(1)
-
- ENDIF
-
-C last message
- WRITE(LO,'(////5X,A,///5X,A,///)')
- & 'PHO_ABORT: execution terminated due to fatal error',
- &'*** Simulating division by zero to get traceback information ***'
- ISTR = 100/IPAMDL(100)
-
- END
-
-CDECK ID>, PHO_TRACE
- SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
-C**********************************************************************
-C
-C trace program subroutines according to level,
-C original output levels will be saved
-C
-C input: ISTART first event to trace
-C ISWI number of events to trace
-C 0 loop call, use old values
-C -1 restore original output levels
-C 1 store level and wait for event
-C LEVEL desired output level
-C 0 standard output
-C 3 internal rejections
-C 5 cross sections, slopes etc.
-C 10 parameter of subroutines and
-C results
-C 20 huge amount of debug output
-C 30 maximal possible output
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
- DIMENSION IMEM(NMAXD)
-
-C protect ISWI
- ISW = ISWI
- 10 CONTINUE
- IF(ISW.EQ.0) THEN
- IF(KEVENT.LT.ION) THEN
- RETURN
- ELSE IF(KEVENT.EQ.ION) THEN
- WRITE(LO,'(///,1X,A,///)')
- & 'PHO_TRACE: trace mode switched on'
- DO 100 I=1,NMAXD
- IMEM(I) = IDEB(I)
- IDEB(I) = MAX(ILEVEL,IMEM(I))
- 100 CONTINUE
- ELSE IF(KEVENT.EQ.IOFF) THEN
- WRITE(LO,'(//,1X,A,///)')
- & 'PHO_TRACE: trace mode switched off'
- DO 200 I=1,NMAXD
- IDEB(I) = IMEM(I)
- 200 CONTINUE
- ENDIF
- ELSE IF(ISW.EQ.-1) THEN
- DO 300 I=1,NMAXD
- IDEB(I) = IMEM(I)
- 300 CONTINUE
- ELSE
-C save information
- ION = ISTART
- IOFF = ISTART+ISW
- ILEVEL = LEVEL
- ENDIF
-C check coincidence
- IF(ISW.GT.0) THEN
- ISW=0
- ILEVEL = LEVEL
- GOTO 10
- ENDIF
-
- END
-
-CDECK ID>, PHO_PRSTRG
- SUBROUTINE PHO_PRSTRG
-C**********************************************************************
-C
-C print information of /POSTRG/
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-
- WRITE(LO,'(/,1X,A,I5)')
- & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
- WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
- & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
- WRITE(LO,'(1X,A)')
- & ' ======================================================='
- DO 800 I=1,ISTR
- WRITE(LO,'(1X,9I5,1P,E11.3)')
- & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
- & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
- 800 CONTINUE
-
- END
-
-CDECK ID>, PHO_PREVNT
- SUBROUTINE PHO_PREVNT(NPART)
-C**********************************************************************
-C
-C print all information of event generation and history
-C
-C input: NPART -1 minimal output: process IDs
-C 0 additional output of /POEVT1/
-C 1 additional output of /POSTRG/
-C 2 additional output of /HEPEVT/
-C (call LULIST(1))
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-
- CHARACTER*15 PHO_PNAME
-
- IF(NPART.GE.0) WRITE(LO,'(/)')
- WRITE(LO,'(1X,A,1PE10.3)')
- & 'PHO_PREVNT: c.m. energy',ECM
- CALL PHO_SETPAR(-2,IH,NPART,0.D0)
- WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
- & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
- & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
- & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
- & KHDPO
- WRITE(LO,'(6X,A,I4,4I3)')
- & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
- & IDIFR2,IDDPOM
-
- IF(IPAMDL(13).GT.0) THEN
- WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
- WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
- & ECMN,PCMN,SECM,SPCM
- WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
- ENDIF
-
- IF(NPART.LT.0) RETURN
-
- IF(NPART.GE.1) CALL PHO_PRSTRG
-
- WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
- ICHAS = 0
- IBARFS = 0
- IMULC = 0
- IMUL = 0
- WRITE(LO,'(/1X,A,A,/,1X,A,A)')
- & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
- & ' IH1 IH2 CO1 CO2',
- & '========================================================',
- & '===================='
- DO 20 IH=1,NHEP
- CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
- BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
- WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
- & IH,ISTHEP(IH),PHO_PNAME(IH,2),
- & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
- & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
- & ICOLOR(1,IH),ICOLOR(2,IH)
- IF(ABS(ISTHEP(IH)).EQ.1) THEN
- ICHAS = ICHAS + IPHO_CHR3(IH,2)
- IBARFS = IBARFS + IPHO_BAR3(IH,2)
- ENDIF
- IF(ABS(ISTHEP(IH)).EQ.1) THEN
- IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
- IMUL = IMUL+1
- ENDIF
- 20 CONTINUE
- WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
- & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
-
- WRITE(LO,7)
- PXS = 0.D0
- PYS = 0.D0
- PZS = 0.D0
- P0S = 0.D0
- DO 30 IN=1,NHEP
- IF( (ABS(PHEP(3,IN)).LT.99999.D0)
- & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
- WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
- & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
- ELSE
- WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
- & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
- ENDIF
- IF(ABS(ISTHEP(IN)).EQ.1) THEN
- PXS = PXS + PHEP(1,IN)
- PYS = PYS + PHEP(2,IN)
- PZS = PZS + PHEP(3,IN)
- P0S = P0S + PHEP(4,IN)
- ENDIF
- 30 CONTINUE
- AMFS = P0S**2-PXS**2-PYS**2-PZS**2
- AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
- IF(P0S.LT.99999.D0) THEN
- WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
- ELSE
- WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
- ENDIF
- WRITE(LO,'(//)')
-
- 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
- & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
- & 8H CHARGE ,8H BARYON ,/)
- 6 FORMAT(7I8,2F8.3)
- 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
- & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
- & 2X,'-------------------------------',
- & '--------------------------------------------')
- 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
- 9 FORMAT(I10,14X,5F10.3)
- 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
- 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
- 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
-
- IF(NPART.GE.2) CALL PYLIST(1)
-
- END
-
-CDECK ID>, PHO_LTRHEP
- SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
-C*******************************************************************
-C
-C Lorentz transformation of entries I1 to I2 in /POEVT1/
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( DIFF = 0.001D0,
- & EPS = 1.D-5 )
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
- DO 100 I=I1,MIN(I2,NHEP)
- IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
- CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
- & XX,YY,ZZ)
- EE=PHEP(4,I)
- CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
- & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
- ELSE IF(ISTHEP(I).EQ.20) THEN
- EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
- CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
- & XX,YY,ZZ)
- CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
- & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
- ENDIF
- 100 CONTINUE
-
-C debug precision
- IF(IDEB(70).LT.1) RETURN
- DO 200 I=I1,MIN(NHEP,I2)
- IF(ABS(ISTHEP(I)).GT.10) GOTO 190
- PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
- PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
- IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
- WRITE(LO,'(1X,A,I5,2E13.4)')
- & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
- ENDIF
- 190 CONTINUE
- 200 CONTINUE
-
- END
-
-CDECK ID>, PHO_PECMS
- SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
-C*******************************************************************
-C
-C calculation of cms momentum and energy of massive particle
-C (ID= 1 using PMASS1, 2 using PMASS2)
-C
-C output: PP cms momentum
-C EE energy in CMS of particle ID
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- S=ECM**2
- PM1 = SIGN(PMASS1**2,PMASS1)
- PM2 = SIGN(PMASS2**2,PMASS2)
- PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
- & + PM1**2 + PM2**2)/(2.D0*ECM)
-
- IF(ID.EQ.1) THEN
- EE = SQRT( PM1 + PP**2 )
- ELSE IF(ID.EQ.2) THEN
- EE = SQRT( PM2 + PP**2 )
- ELSE
- WRITE(LO,'(/1X,A,I3,/)')
- & 'PHO_PECMS:ERROR: invalid ID number:',ID
- EE = PP
- ENDIF
-
- END
-
-CDECK ID>, PHO_FRAINI
- SUBROUTINE PHO_FRAINI(IDEFAU)
-C***********************************************************************
-C
-C initialization of fragmentation packages
-C (currently LUND JETSET)
-C
-C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
-C changed to work in PHOJET (R.E. 1/94)
-C
-C input: IDEFAU 0 no hadronization at all
-C 1 do not touch any parameter of JETSET
-C 2 default parameters kept, decay length 10mm to
-C define stable particles
-C 3 load tuned parameters for JETSET 7.3
-C neg. value: prevent strange/charm hadrons from decaying
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (EPS=1.D-10)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- INTEGER N,NPAD,K
- DOUBLE PRECISION P,V
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
-
- INTEGER MSTU,MSTJ
- DOUBLE PRECISION PARU,PARJ
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-
- INTEGER KCHG
- DOUBLE PRECISION PMAS,PARF,VCKM
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
-
- INTEGER MDCY,MDME,KFDP
- DOUBLE PRECISION BRAT
- COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
-
- INTEGER PYCOMP
-
- IDEFAB = ABS(IDEFAU)
-
- IF(IDEFAB.EQ.0) THEN
- WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
- RETURN
- ENDIF
-C defaults
- DEF2 = PARJ(2)
- IDEF12 = MSTJ(12)
- DEF19 = PARJ(19)
- DEF41 = PARJ(41)
- DEF42 = PARJ(42)
- DEF21 = PARJ(21)
-
-C declare stable particles
- IF(IDEFAB.GE.2) MSTJ(22) = 2
-
-C load optimized parameters
- IF(IDEFAB.GE.3) THEN
-
-* PARJ(19)=0.19
-C Lund a-parameter
-C (default=0.3)
- PARJ(41)=0.3
-C Lund b-parameter
-C (default=1.0)
- PARJ(42)=1.0
-C Lund sigma parameter in pt distribution
-C (default=0.36)
- PARJ(21)=0.36
- ENDIF
-C
-C prevent particles decaying
- IF(IDEFAU.LT.0) THEN
-C K0S
-
- KC=PYCOMP(310)
-
- MDCY(KC,1)=0
-C PI0
-
- KC=PYCOMP(111)
-
- MDCY(KC,1)=0
-C LAMBDA
-
- KC=PYCOMP(3122)
-
- MDCY(KC,1)=0
-C ALAMBDA
-
- KC=PYCOMP(-3122)
-
- MDCY(KC,1)=0
-C SIG+
-
- KC=PYCOMP(3222)
-
- MDCY(KC,1)=0
-C ASIG+
-
- KC=PYCOMP(-3222)
-
- MDCY(KC,1)=0
-C SIG-
-
- KC=PYCOMP(3112)
-
- MDCY(KC,1)=0
-C ASIG-
-
- KC=PYCOMP(-3112)
-
- MDCY(KC,1)=0
-C SIG0
-
- KC=PYCOMP(3212)
-
- MDCY(KC,1)=0
-C ASIG0
-
- KC=PYCOMP(-3212)
-
- MDCY(KC,1)=0
-C TET0
-
- KC=PYCOMP(3322)
-
- MDCY(KC,1)=0
-C ATET0
-
- KC=PYCOMP(-3322)
-
- MDCY(KC,1)=0
-C TET-
-
- KC=PYCOMP(3312)
-
- MDCY(KC,1)=0
-C ATET-
-
- KC=PYCOMP(-3312)
-
- MDCY(KC,1)=0
-C OMEGA-
-
- KC=PYCOMP(3334)
-
- MDCY(KC,1)=0
-C AOMEGA-
-
- KC=PYCOMP(-3334)
-
- MDCY(KC,1)=0
-C D+
-
- KC=PYCOMP(411)
-
- MDCY(KC,1)=0
-C D-
-
- KC=PYCOMP(-411)
-
- MDCY(KC,1)=0
-C D0
-
- KC=PYCOMP(421)
-
- MDCY(KC,1)=0
-C A-D0
-
- KC=PYCOMP(-421)
-
- MDCY(KC,1)=0
-C DS+
-
- KC=PYCOMP(431)
-
- MDCY(KC,1)=0
-C A-DS+
-
- KC=PYCOMP(-431)
-
- MDCY(KC,1)=0
-C ETAC
-
- KC=PYCOMP(441)
-
- MDCY(KC,1)=0
-C LAMBDAC+
-
- KC=PYCOMP(4122)
-
- MDCY(KC,1)=0
-C A-LAMBDAC+
-
- KC=PYCOMP(-4122)
-
- MDCY(KC,1)=0
-C SIGMAC++
-
- KC=PYCOMP(4222)
-
- MDCY(KC,1)=0
-C SIGMAC+
-
- KC=PYCOMP(4212)
-
- MDCY(KC,1)=0
-C SIGMAC0
-
- KC=PYCOMP(4112)
-
- MDCY(KC,1)=0
-C A-SIGMAC++
-
- KC=PYCOMP(-4222)
-
- MDCY(KC,1)=0
-C A-SIGMAC+
-
- KC=PYCOMP(-4212)
-
- MDCY(KC,1)=0
-C A-SIGMAC0
-
- KC=PYCOMP(-4112)
-
- MDCY(KC,1)=0
-C KSIC+
-
- KC=PYCOMP(4232)
-
- MDCY(KC,1)=0
-C KSIC0
-
- KC=PYCOMP(4132)
-
- MDCY(KC,1)=0
-C A-KSIC+
-
- KC=PYCOMP(-4232)
-
- MDCY(KC,1)=0
-C A-KSIC0
-
- KC=PYCOMP(-4132)
-
- MDCY(KC,1)=0
- ENDIF
-
-C *** Commented by Chiara
-C WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
-C & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
-C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
-C & ' --------------------------------------------------',/,
-C & 5X,'parameter description default / current',/,
-C & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
-C & 5X,'MSTJ(12) popcorn : ',2I7,/,
-C & 5X,'PARJ(19) popcorn : ',2F7.3,/,
-C & 5X,'PARJ(41) Lund a : ',2F7.3,/,
-C & 5X,'PARJ(42) Lund b : ',2F7.3,/,
-C & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
-
- END
-
-CDECK ID>, PHO_SETPAR
- SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
-C**********************************************************************
-C
-C assign a particle to either side 1 or 2
-C (including special treatment for remnants)
-C
-C input: Iside 1,2 side selected for the particle
-C -2 output of current settings
-C IDpdg PDG number
-C IDcpc CPC number
-C 0 CPC determination in subroutine
-C -1 special particle remnant, IDPDG
-C is the particle number the remnant
-C corresponds to (see /POHDFL/)
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- integer Iside,IDpdg,IDcpc
- double precision Pvir
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C particle ID translation table
- integer ID_pdg_list,ID_list,ID_pdg_max
- character*12 name_list
- COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
- & ID_pdg_max
-C general particle data
- double precision xm_list,tau_list,gam_list,
- & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
- & xm_bb82_list,xm_bb102_list
- integer ich3_list,iba3_list,iq_list,
- & id_psm_list,id_vem_list,id_b8_list,id_b10_list
- COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
- & xm_psm2_list(6,6),xm_vem2_list(6,6),
- & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
- & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
- & ich3_list(300),iba3_list(300),iq_list(3,300),
- & id_psm_list(6,6),id_vem_list(6,6),
- & id_b8_list(6,6,6),id_b10_list(6,6,6)
-C particle decay data
- double precision wg_sec_list
- integer idec_list,isec_list
- COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
- & isec_list(3,500)
-
-C external functions
- integer ipho_pdg2id,ipho_chr3,ipho_bar3
- double precision pho_pmass
-
-C local variables
- integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
-
- IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
- IDcpcN = IDcpc
-C remnant?
- IF(IDcpc.EQ.-1) THEN
- IF(Iside.EQ.1) THEN
- IDpdgR = 81
- ELSE
- IDpdgR = 82
- ENDIF
- IDcpcR = ipho_pdg2id(IDpdgR)
- IDEQB(Iside) = ipho_pdg2id(IDpdg)
- IDEQP(Iside) = IDpdg
-C copy particle properties
- IDB = abs(IDEQB(Iside))
- xm_list(IDcpcR) = xm_list(IDB)
- tau_list(IDcpcR) = tau_list(IDB)
- gam_list(IDcpcR) = gam_list(IDB)
- IF(IHFLS(Iside).EQ.1) THEN
- ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
- iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
- ELSE
- ich3_list(IDcpcR) = 0
- iba3_list(IDcpcR) = 0
- ENDIF
-C quark content
- IFL1 = IHFLD(Iside,1)
- IFL2 = IHFLD(Iside,2)
- IFL3 = 0
- IF(IHFLS(Iside).EQ.1) THEN
- IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
- IFL1 = IHFLD(Iside,1)/1000
- IFL2 = MOD(IHFLD(Iside,1)/100,10)
- IFL3 = IHFLD(Iside,2)
- ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
- IFL1 = IHFLD(Iside,1)
- IFL2 = IHFLD(Iside,2)/1000
- IFL3 = MOD(IHFLD(Iside,2)/100,10)
- ENDIF
- ENDIF
- iq_list(1,IDcpcR) = IFL1
- iq_list(2,IDcpcR) = IFL2
- iq_list(3,IDcpcR) = IFL3
-
- IDcpcN = IDcpcR
- IDPDGN = IDPDGR
-
- IF(IDEB(87).GE.5) THEN
- WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
- & 'pho_setpar: remnant assignment side',Iside,
- & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
- ENDIF
- ELSE IF(IDcpc.EQ.0) THEN
-C ordinary hadron
- IHFLS(Iside) = 1
- IHFLD(Iside,1) = 0
- IHFLD(Iside,2) = 0
- IDcpcN = ipho_pdg2id(IDpdg)
- IDpdgN = IDpdg
- ENDIF
-
-C initialize /POGCMS/
- IFPAP(Iside) = IDpdgN
- IFPAB(Iside) = IDcpcN
- PMASS(Iside) = pho_pmass(IDcpcN,0)
- IF(IFPAP(Iside).EQ.22) THEN
- PVIRT(Iside) = ABS(PVIR)
- ELSE
- PVIRT(Iside) = 0.D0
- ENDIF
-
- ELSE IF(Iside.EQ.-2) THEN
-C output of current settings
- DO 100 I=1,2
- WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
- & 'PHO_SETPAR: side',
- & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
- & PVIRT(I)
- IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
- WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
- & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
- & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
- ENDIF
- 100 CONTINUE
- ELSE
- WRITE(LO,'(/1X,A,I8)')
- & 'pho_setpar: invalid argument (Iside)',Iside
- ENDIF
-
- END
-
-CDECK ID>, PHO_XLAM
- DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
-C**********************************************************************
-C
-C auxiliary function for two/three particle decay mode
-C (standard LAMBDA**(1/2) function)
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-C
- YZ=Y-Z
- XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
- IF(XLAM.LT.0.D0) XLAM=-XLAM
- PHO_XLAM=SQRT(XLAM)
- END
-
-CDECK ID>, PHO_BESSJ0
- DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
-C**********************************************************************
-C
-C CERN (KERN) LIB function C312
-C
-C modified by R. Engel (03/02/93)
-C
-C**********************************************************************
- DOUBLE PRECISION DX
- DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
- DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
- SAVE
-
- DATA EIGHT /8.0D0/
- DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
-
- DATA C1( 0) /+0.15772 79714 7489D0/
- DATA C1( 1) /-0.00872 34423 5285D0/
- DATA C1( 2) /+0.26517 86132 0334D0/
- DATA C1( 3) /-0.37009 49938 7265D0/
- DATA C1( 4) /+0.15806 71023 3210D0/
- DATA C1( 5) /-0.03489 37694 1141D0/
- DATA C1( 6) /+0.00481 91800 6947D0/
- DATA C1( 7) /-0.00046 06261 6621D0/
- DATA C1( 8) /+0.00003 24603 2882D0/
- DATA C1( 9) /-0.00000 17619 4691D0/
- DATA C1(10) /+0.00000 00760 8164D0/
- DATA C1(11) /-0.00000 00026 7925D0/
- DATA C1(12) /+0.00000 00000 7849D0/
- DATA C1(13) /-0.00000 00000 0194D0/
- DATA C1(14) /+0.00000 00000 0004D0/
-
- DATA C2( 0) /+0.99946 03493 4752D0/
- DATA C2( 1) /-0.00053 65220 4681D0/
- DATA C2( 2) /+0.00000 30751 8479D0/
- DATA C2( 3) /-0.00000 00517 0595D0/
- DATA C2( 4) /+0.00000 00016 3065D0/
- DATA C2( 5) /-0.00000 00000 7864D0/
- DATA C2( 6) /+0.00000 00000 0517D0/
- DATA C2( 7) /-0.00000 00000 0043D0/
- DATA C2( 8) /+0.00000 00000 0004D0/
- DATA C2( 9) /-0.00000 00000 0001D0/
-
- DATA C3( 0) /-0.01555 58546 05337D0/
- DATA C3( 1) /+0.00006 83851 99426D0/
- DATA C3( 2) /-0.00000 07414 49841D0/
- DATA C3( 3) /+0.00000 00179 72457D0/
- DATA C3( 4) /-0.00000 00007 27192D0/
- DATA C3( 5) /+0.00000 00000 42201D0/
- DATA C3( 6) /-0.00000 00000 03207D0/
- DATA C3( 7) /+0.00000 00000 00301D0/
- DATA C3( 8) /-0.00000 00000 00033D0/
- DATA C3( 9) /+0.00000 00000 00004D0/
- DATA C3(10) /-0.00000 00000 00001D0/
-
- X=DX
- V=ABS(X)
- IF(V .LT. EIGHT) THEN
- Y=V/EIGHT
- H=2.D0*Y**2-1.D0
- ALFA=-2.D0*H
- B1=0.D0
- B2=0.D0
- DO 1 I = 14,0,-1
- B0=C1(I)-ALFA*B1-B2
- B2=B1
- 1 B1=B0
- B1=B0-H*B2
- ELSE
- R=1.D0/V
- Y=EIGHT*R
- H=2.D0*Y**2-1.D0
- ALFA=-2.D0*H
- B1=0.D0
- B2=0.D0
- DO 2 I = 9,0,-1
- B0=C2(I)-ALFA*B1-B2
- B2=B1
- 2 B1=B0
- P=B0-H*B2
- B1=0.D0
- B2=0.D0
- DO 3 I = 10,0,-1
- B0=C3(I)-ALFA*B1-B2
- B2=B1
- 3 B1=B0
- Q=Y*(B0-H*B2)
- B0=V-PI2
- B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
- ENDIF
- PHO_BESSJ0=B1
- RETURN
- END
-
-CDECK ID>, PHO_BESSI0
- DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
-C**********************************************************************
-C
-C Bessel Function I0
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- AX = ABS(X)
- IF (AX .LT. 3.75D0) THEN
- Y = (X/3.75D0)**2
- PHO_BESSI0 =
- & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
- & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
- ELSE
- Y = 3.75D0/AX
- PHO_BESSI0 =
- & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
- & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
- & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
- & +Y*0.392377D-2))))))))
- ENDIF
-
- END
-
-CDECK ID>, PHO_BESSI1
- DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
-C**********************************************************************
-C
-C Bessel Function I1
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- AX = ABS(X)
-
- IF (AX .LT. 3.75D0) THEN
- Y = (X/3.75D0)**2
- BESLI1 =
- & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
- & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
- ELSE
- Y = 3.75D0/AX
- BESLI1 =
- & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
- & -Y*0.420059D-2))
- BESLI1 =
- & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
- & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
- BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
- ENDIF
- IF (X .LT. 0.D0) BESLI1 = -BESLI1
-
- PHO_BESSI1 = BESLI1
-
- END
-
-CDECK ID>, PHO_BESSK0
- DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
-C**********************************************************************
-C
-C Modified Bessel Function K0
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- IF (X .LT. 2.D0) THEN
- Y = X**2/4.D0
- PHO_BESSK0 =
- & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
- & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
- & +Y*(0.10750D-3+Y*0.740D-5))))))
- ELSE
- Y = 2.D0/X
- PHO_BESSK0 =
- & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
- & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
- & +Y*(-0.251540D-2+Y*0.53208D-3))))))
- ENDIF
-
- END
-
-CDECK ID>, PHO_BESSK1
- DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
-C**********************************************************************
-C
-C Modified Bessel Function K1
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- IF (X .LT. 2.D0) THEN
- Y = X**2/4.D0
- PHO_BESSK1 =
- & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
- & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
- & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
- ELSE
- Y=2.D0/X
- PHO_BESSK1 =
- & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
- & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
- & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
- ENDIF
-
- END
-
-CDECK ID>, PHO_GAUSET
- SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
-C********************************************************************
-C
-C N-point gauss zeros and weights for the interval (AX,BX) are
-C stored in arrays Z and W respectively.
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- COMMON /POGDAT/A(273),X(273),KTAB(96)
- DIMENSION Z(NX),W(NX)
-
- ALPHA=0.5*(BX+AX)
- BETA=0.5*(BX-AX)
- N=NX
-
-C the N=1 case:
- IF(N.NE.1) GO TO 1
- Z(1)=ALPHA
- W(1)=BX-AX
- RETURN
-
-C the Gauss cases:
- 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
- IF(N.EQ.20) GO TO 2
- IF(N.EQ.24) GO TO 2
- IF(N.EQ.32) GO TO 2
- IF(N.EQ.40) GO TO 2
- IF(N.EQ.48) GO TO 2
- IF(N.EQ.64) GO TO 2
- IF(N.EQ.80) GO TO 2
- IF(N.EQ.96) GO TO 2
-
-C the extended Gauss cases:
- IF((N/96)*96.EQ.N) GO TO 3
-
-C jump to center of intervall intrgration:
- GO TO 100
-
-C get Gauss point array
-
- 2 CALL PHO_GAUDAT
-C extract real points
- K=KTAB(N)
- M=N/2
- DO 21 J=1,M
-C extract values from big array
- JTAB=K-1+J
- WTEMP=BETA*A(JTAB)
- DELTA=BETA*X(JTAB)
-C store them backward
- Z(J)=ALPHA-DELTA
- W(J)=WTEMP
-C store them forward
- JP=N+1-J
- Z(JP)=ALPHA+DELTA
- W(JP)=WTEMP
- 21 CONTINUE
-C store central point (odd N)
- IF((N-M-M).EQ.0) RETURN
- Z(M+1)=ALPHA
- JMID=K+M
- W(M+1)=BETA*A(JMID)
- RETURN
-
-C get ND96 times chained 96 Gauss point array
-
- 3 CALL PHO_GAUDAT
-C print out message
-C -extract real points
- K=KTAB(96)
- ND96=N/96
- DO 31 J=1,48
-C extract values from big array
- JTAB=K-1+J
- WTEMP=BETA*A(JTAB)
- DELTA=BETA*X(JTAB)
- WTeMP=WTEMP/ND96
- DeLTA=DELTA/ND96
- DO 32 JD96=0,ND96-1
- ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
-C store them backward
- Z(J+JD96*96)=ZCNTR-DELTA
- W(J+JD96*96)=WTEMP
-C store them forward
- JP=96+1-J
- Z(JP+JD96*96)=ZCNTR+DELTA
- W(JP+JD96*96)=WTEMP
- 32 CONTINUE
- 31 CONTINUE
- RETURN
-
-C the center of intervall cases:
- 100 CONTINUE
-C put in constant weight and equally spaced central points
- N=IABS(N)
- DO 111 IN=1,N
- WIN=(BX-AX)/FLOAT(N)
- Z(IN)=AX + (FLOAT(IN)-.5)*WIN
- 111 W(IN)=WIN
-
- END
-
-CDECK ID>, PHO_GAUDAT
- SUBROUTINE PHO_GAUDAT
-C*********************************************************************
-C
-C store big arrays needed for Gauss integral, CERNLIB D106BD
-C (arrays A,X,ITAB copied on B,Y,LTAB)
-C
-C*********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-
- SAVE
- COMMON /POGDAT/ B(273),Y(273),LTAB(96)
- DIMENSION A(273),X(273),KTAB(96)
-
-C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
- DATA KTAB(2)/1/
- DATA KTAB(3)/2/
- DATA KTAB(4)/4/
- DATA KTAB(5)/6/
- DATA KTAB(6)/9/
- DATA KTAB(7)/12/
- DATA KTAB(8)/16/
- DATA KTAB(9)/20/
- DATA KTAB(10)/25/
- DATA KTAB(11)/30/
- DATA KTAB(12)/36/
- DATA KTAB(13)/42/
- DATA KTAB(14)/49/
- DATA KTAB(15)/56/
- DATA KTAB(16)/64/
- DATA KTAB(20)/72/
- DATA KTAB(24)/82/
- DATA KTAB(28)/82/
- DATA KTAB(32)/94/
- DATA KTAB(36)/94/
- DATA KTAB(40)/110/
- DATA KTAB(44)/110/
- DATA KTAB(48)/130/
- DATA KTAB(52)/130/
- DATA KTAB(56)/130/
- DATA KTAB(60)/130/
- DATA KTAB(64)/154/
- DATA KTAB(68)/154/
- DATA KTAB(72)/154/
- DATA KTAB(76)/154/
- DATA KTAB(80)/186/
- DATA KTAB(84)/186/
- DATA KTAB(88)/186/
- DATA KTAB(92)/186/
- DATA KTAB(96)/226/
-C
-C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
-C
-C-----N=2
- DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
-C-----N=3
- DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
- DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
-C-----N=4
- DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
- DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
-C-----N=5
- DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
- DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
- DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
-C-----N=6
- DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
- DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
- DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
-C-----N=7
- DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
- DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
- DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
- DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
-C-----N=8
- DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
- DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
- DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
- DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
-C-----N=9
- DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
- DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
- DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
- DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
- DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
-C-----N=10
- DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
- DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
- DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
- DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
- DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
-C-----N=11
- DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
- DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
- DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
- DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
- DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
- DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
-C-----N=12
- DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
- DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
- DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
- DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
- DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
- DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
-C-----N=13
- DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
- DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
- DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
- DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
- DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
- DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
- DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
-C-----N=14
- DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
- DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
- DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
- DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
- DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
- DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
- DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
-C-----N=15
- DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
- DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
- DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
- DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
- DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
- DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
- DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
- DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
-C-----N=16
- DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
- DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
- DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
- DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
- DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
- DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
- DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
- DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
-C-----N=20
- DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
- DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
- DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
- DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
- DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
- DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
- DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
- DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
- DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
- DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
-C-----N=24
- DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
- DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
- DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
- DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
- DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
- DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
- DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
- DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
- DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
- DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
- DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
- DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
-C-----N=32
- DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
- DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
- DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
- DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
- DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
- DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
- DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
- DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
- DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
- DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
- DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
- DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
- DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
- DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
- DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
- DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
-C-----N=40
- DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
- DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
- DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
- DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
- DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
- DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
- DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
- DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
- DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
- DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
- DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
- DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
- DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
- DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
- DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
- DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
- DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
- DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
- DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
- DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
-C-----N=48
- DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
- DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
- DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
- DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
- DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
- DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
- DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
- DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
- DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
- DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
- DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
- DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
- DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
- DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
- DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
- DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
- DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
- DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
- DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
- DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
- DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
- DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
- DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
- DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
-C-----N=64
- DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
- DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
- DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
- DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
- DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
- DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
- DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
- DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
- DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
- DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
- DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
- DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
- DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
- DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
- DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
- DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
- DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
- DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
- DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
- DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
- DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
- DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
- DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
- DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
- DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
- DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
- DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
- DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
- DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
- DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
- DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
- DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
-C-----N=80
- DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
- DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
- DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
- DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
- DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
- DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
- DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
- DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
- DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
- DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
- DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
- DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
- DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
- DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
- DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
- DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
- DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
- DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
- DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
- DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
- DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
- DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
- DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
- DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
- DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
- DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
- DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
- DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
- DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
- DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
- DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
- DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
- DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
- DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
- DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
- DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
- DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
- DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
- DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
- DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
-C-----N=96
- DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
- DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
- DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
- DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
- DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
- DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
- DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
- DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
- DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
- DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
- DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
- DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
- DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
- DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
- DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
- DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
- DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
- DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
- DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
- DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
- DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
- DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
- DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
- DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
- DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
- DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
- DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
- DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
- DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
- DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
- DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
- DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
- DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
- DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
- DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
- DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
- DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
- DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
- DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
- DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
- DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
- DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
- DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
- DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
- DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
- DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
- DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
- DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
- DATA IBD/0/
- IF(IBD.NE.0) RETURN
- IBD=1
- DO 10 I=1,273
- B(I) = A(I)
- Y(I) = X(I)
- 10 CONTINUE
- DO 20 I=1,96
- LTAB(I) = KTAB(I)
- 20 CONTINUE
- END
-
-CDECK ID>, PHO_DZEROX
- DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
-C**********************************************************************
-C
-C Based on
-C
-C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
-C Guaranteed Convergence for Finding a Zero of a Function,
-C ACM Trans. Math. Software 1 (1975) 330-345.
-C
-C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
-C
-C CERNLIB C200
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- CHARACTER NAME*(*)
- PARAMETER (NAME = 'PHO_DZEROX')
- LOGICAL LMT
- DIMENSION IM1(2),IM2(2),LMT(2)
- EXTERNAL F
-
- PARAMETER (Z1 = 1, HALF = Z1/2)
-
- DATA IM1 /2,3/, IM2 /-1,3/
-
- IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
- C=-2D+10
- WRITE(LO,100) NAME,MODE
- GO TO 99
- ENDIF
- FA=F(B0)
- FB=F(A0)
- IF(FA*FB .GT. 0) THEN
- C=-3D+10
- WRITE(LO,101) NAME
- GO TO 99
- ENDIF
- ATL=ABS(EPS)
- B=A0
- A=B0
- LMT(2)=.TRUE.
- MF=2
- 1 C=A
- FC=FA
- 2 IE=0
- 3 IF(ABS(FC) .LT. ABS(FB)) THEN
- IF(C .NE. A) THEN
- D=A
- FD=FA
- END IF
- A=B
- B=C
- C=A
- FA=FB
- FB=FC
- FC=FA
- END IF
- TOL=ATL*(1+ABS(C))
- H=HALF*(C+B)
- HB=H-B
- IF(ABS(HB) .GT. TOL) THEN
- IF(IE .GT. IM1(MODE)) THEN
- W=HB
- ELSE
- TOL=TOL*SIGN(Z1,HB)
- P=(B-A)*FB
- LMT(1)=IE .LE. 1
- IF(LMT(MODE)) THEN
- Q=FA-FB
- LMT(2)=.FALSE.
- ELSE
- FDB=(FD-FB)/(D-B)
- FDA=(FD-FA)/(D-A)
- P=FDA*P
- Q=FDB*FA-FDA*FB
- END IF
- IF(P .LT. 0) THEN
- P=-P
- Q=-Q
- END IF
- IF(IE .EQ. IM2(MODE)) P=P+P
- IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
- W=TOL
- ELSEIF(P .LT. HB*Q) THEN
- W=P/Q
- ELSE
- W=HB
- END IF
- END IF
- D=A
- A=B
- FD=FA
- FA=FB
- B=B+W
- MF=MF+1
- IF(MF .GT. MAXF) THEN
- WRITE(LO,102) NAME
- GO TO 99
- ENDIF
- FB=F(B)
- IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
- IF(W .EQ. HB) GO TO 2
- IE=IE+1
- GO TO 3
- END IF
- 99 CONTINUE
- PHO_DZEROX=C
- RETURN
- 100 FORMAT(1X,A,': mode = ',I3,' illegal')
- 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
- 102 FORMAT(1X,A,': too many function calls')
-
- END
-
-CDECK ID>, PHO_EXPINT
- DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
-C***********************************************************************
-C
-C function to calculate E_i(x) = -E_1(-x)
-C
-C based on CERNLIB C337 (changed by R.Engel 10/1993)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
- DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
- DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
-
- DATA X0 /0.37250 74107 8137D0/
- DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
- DATA P1
- 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
- 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
- 3 -4.34981 43832 952D+2/
- DATA Q1
- 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
- 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
- 3 +7.53585 64359 843D+2/
- DATA P2
- 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
- 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
- 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
- 4 +4.65627 10797 510D-7/
- DATA Q2
- 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
- 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
- 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
- 4 +1.00000 00000 000D+0/
- DATA P3
- 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
- 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
- 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
- DATA Q3
- 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
- 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
- 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
- DATA P4
- 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
- 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
- 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
- 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
- DATA Q4
- 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
- 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
- 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
- 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
- DATA A1
- 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
- 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
- 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
- 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
- DATA B1
- 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
- 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
- 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
- 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
- DATA A2
- 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
- 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
- 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
- 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
- DATA B2
- 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
- 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
- 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
- 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
- DATA A3
- 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
- 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
- 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
- DATA B3
- 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
- 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
- 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
-C
-C conversion to E_i function
- X = -RXM
-C
- IF(X .LE. XL(1)) THEN
- AP=A3(1)-X
- DO 1 I = 2,5
- 1 AP=A3(I)-X+B3(I)/AP
- Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
- ELSEIF(X .LE. XL(2)) THEN
- AP=A2(1)-X
- DO 2 I = 2,7
- 2 AP=A2(I)-X+B2(I)/AP
- Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
- ELSEIF(X .LE. XL(3)) THEN
- AP=A1(1)-X
- DO 3 I = 2,7
- 3 AP=A1(I)-X+B1(I)/AP
- Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
- ELSEIF(X .LT. XL(4)) THEN
- V=-2.D0*(X/3.D0+1.D0)
- BP=0.D0
- DP=P4(1)
- DO 4 I = 2,8
- AP=BP
- BP=DP
- 4 DP=P4(I)-AP+V*BP
- BQ=0.D0
- DQ=Q4(1)
- DO 14 I = 2,8
- AQ=BQ
- BQ=DQ
- 14 DQ=Q4(I)-AQ+V*BQ
- Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
- ELSEIF(X .EQ. XL(4)) THEN
-* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
-* IF(MFLAG) THEN
-* IF(LGFILE .EQ. 0) THEN
-* WRITE(LO,100) ENAME
-* ELSE
-* WRITE(LGFILE,100) ENAME
-* ENDIF
-* ENDIF
-* IF(.NOT.RFLAG) CALL ABEND
- PHO_EXPINT=0.D0
- RETURN
- ELSEIF(X .LT. XL(5)) THEN
- AP=P1(1)
- AQ=Q1(1)
- DO 5 I = 2,5
- AP=P1(I)+X*AP
- 5 AQ=Q1(I)+X*AQ
- Y=-LOG(X)+AP/AQ
- ELSEIF(X .LE. XL(6)) THEN
- Y=1.D0/X
- AP=P2(1)
- AQ=Q2(1)
- DO 6 I = 2,7
- AP=P2(I)+Y*AP
- 6 AQ=Q2(I)+Y*AQ
- Y=EXP(-X)*AP/AQ
- ELSE
- Y=1.D0/X
- AP=P3(1)
- AQ=Q3(1)
- DO 7 I = 2,6
- AP=P3(I)+Y*AP
- 7 AQ=Q3(I)+Y*AQ
- Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
- ENDIF
-C sign conversion to E_i
- PHO_EXPINT=-Y
-
- END
-
-CDECK ID>, PHO_RNDBET
- DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
-C********************************************************************
-C
-C RANDOM NUMBER GENERATION FROM BETA
-C DISTRIBUTION IN REGION 0 < X < 1.
-C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
-C *GAMM(ETA))
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- Y = PHO_RNDGAM(1.D0,GAM)
- Z = PHO_RNDGAM(1.D0,ETA)
-
- PHO_RNDBET = Y/(Y+Z)
-
- END
-
-CDECK ID>, PHO_RNDGAM
- DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
-C********************************************************************
-C
-C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
-C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-C
- NCOU=0
- N = ETA
- F = ETA - N
- IF(F.EQ.0.D0) GOTO 20
- 10 R = DT_RNDM(ETA)
- NCOU=NCOU+1
- IF (NCOU.GE.11) GOTO 20
- IF(R.LT.F/(F+2.71828D0)) GOTO 30
- YYY=LOG(DT_RNDM(F)+1.0D-9)/F
- IF(ABS(YYY).GT.50.D0) GOTO 20
- Y = EXP(YYY)
- IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
- GOTO 40
- 20 Y = 0.D0
- GOTO 50
- 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
- IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
- 40 IF(N.EQ.0) GOTO 70
- 50 Z = 1.D0
- DO 60 I = 1,N
- 60 Z = Z*DT_RNDM(Y)
- Y = Y-LOG(Z+1.0D-9)
- 70 PHO_RNDGAM = Y/ALAM
- RETURN
- END
-
-CDECK ID>, PHO_SFECFE
- SUBROUTINE PHO_SFECFE(SFE,CFE)
-C**********************************************************************
-C
-C fast random SIN(X) COS(X) selection
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-C
- 1 CONTINUE
- X=DT_RNDM(XX)
- Y=DT_RNDM(YY)
- XX=X*X
- YY=Y*Y
- XY=XX+YY
- IF(XY.GT.1.D0) GOTO 1
- CFE=(XX-YY)/XY
- SFE=2.D0*X*Y/XY
- IF(DT_RNDM(XY).LT.0.5D0) THEN
- SFE=-SFE
- ENDIF
- END
-
-CDECK ID>, PHO_SWAPD
- SUBROUTINE PHO_SWAPD(D1,D2)
-C********************************************************************
-C
-C exchange of argument values (double precision)
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- D = D1
- D1 = D2
- D2 = D
- END
-
-CDECK ID>, PHO_SWAPI
- SUBROUTINE PHO_SWAPI(I1,I2)
-C********************************************************************
-C
-C exchange of argument values (integer)
-C
-C********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- K = I1
- I1 = I2
- I2 = K
- END
-
-CDECK ID>, PHO_HADCSL
- SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
- & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
-C***********************************************************************
-C
-C low-energy cross section parametrizations
-C
-C input: ID1,ID2 PDG IDs of particles (meson first)
-C ECM c.m. energy (GeV)
-C PLAB lab. momentum (second particle at rest)
-C IMODE 1 ECM given, PLAB ignored
-C 2 PLAB given, ECM ignored
-C
-C output: SIGTOT total cross section (mb)
-C SIGEL elastic cross section (mb)
-C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
-C SLOPE forward elastic slope (GeV**-2)
-C RHO real/imaginary part of elastic amplitude
-C
-C comments:
-C
-C - low-energy data interpolation uses PDG fits from 1992 issue
-C - high-energy extrapolation by Donnachie-Landshoff like fit made
-C by PDG 1996
-C - analytic extension of amplitude to calculate rho
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- INTEGER ID1,ID2,IMODE
- DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-
- INTEGER K
- DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
- & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
-
- DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
-
- DATA TPDG92 /
- & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
- & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
- & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
- & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
- & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
- & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
- & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
- & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
- & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
- & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
- & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
- & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
-
- DATA TPDG96 /
- & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
- & 77.15D0,-21.05D0,0.46D0,0.9D0,
- & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
- & 77.15D0,21.05D0,0.46D0,0.9D0,
- & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
- & 31.85D0,-4.05D0,0.45D0,0.9D0,
- & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
- & 31.85D0,4.05D0,0.45D0,0.9D0,
- & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
- & 17.35D0,-9.05D0,0.50D0,0.9D0,
- & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
- & 17.35D0,9.05D0,0.50D0,0.9D0 /
-
- DATA BURQ83 /
- & 11.13D0, -6.21D0, 0.30D0,
- & 11.13D0, 7.23D0, 0.30D0,
- & 9.11D0, -0.73D0, 0.28D0,
- & 9.11D0, 0.65D0, 0.28D0,
- & 8.55D0, -5.98D0, 0.28D0,
- & 8.55D0, 1.60D0, 0.28D0 /
-
- DATA XMA /
- & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
-
-C find index
- IF(ID2.NE.2212) THEN
- GOTO 100
- ELSE IF(ID1.EQ.2212) THEN
- K = 1
- ELSE IF(ID1.EQ.-2212) THEN
- K = 2
- ELSE IF(ID1.EQ.211) THEN
- K = 3
- ELSE IF(ID1.EQ.-211) THEN
- K = 4
- ELSE IF(ID1.EQ.321) THEN
- K = 5
- ELSE IF(ID1.EQ.-321) THEN
- K = 6
- ELSE
- GOTO 100
- ENDIF
-
-C calculate lab momentum
- IF(IMODE.EQ.1) THEN
- SS = ECM**2
- E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
- PL = SQRT(E1*E1-XMA(K)**2)
- ELSE IF(IMODE.EQ.2) THEN
- PL = PLAB
- SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
- ECM = SQRT(SS)
- ELSE
- WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
- RETURN
- ENDIF
- PLL = LOG(PL)
-
-C check against lower limit
- IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
-
- XP = TPDG96(2,K)*SS**TPDG96(3,K)
- YP = TPDG96(6,K)/SS**TPDG96(8,K)
- YM = TPDG96(7,K)/SS**TPDG96(8,K)
-
- PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
- PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
- RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
- SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
-
-C select energy range and interpolation method
- IF(PL.LT.TPDG96(1,K)) THEN
- SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
- & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
- SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
- & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
- ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
- SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
- & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
- SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
- & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
- SIGTO2 = YP+YM+XP
- SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
- X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
- X1 = 1.D0 - X2
- SIGTOT = SIGTO2*X2 + SIGTO1*X1
- SIGEL = SIGEL2*X2 + SIGEL1*X1
- ELSE
- SIGTOT = YP+YM+XP
- SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
- ENDIF
-
-C no parametrization of diffraction implemented
- SIGDIF(1) = -1.D0
- SIGDIF(2) = -1.D0
- SIGDIF(3) = -1.D0
-
- RETURN
-
- 100 CONTINUE
- WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
- & 'invalid particle combination: ',ID1,ID2
- RETURN
-
- 200 CONTINUE
- WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
- & 'energy too small (Ecm,Plab): ',ECM,PLAB
-
- END
-
-CDECK ID>, PHO_CSDIFF
- SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
- & sig_sd1,sig_sd2,sig_dd)
-C***********************************************************************
-C
-C cross section for diffraction dissociation according to
-C Goulianos' parametrization (Ref: PL B358 (1995) 379)
-C
-C in addition rescaling for different particles is applied using
-C internal rescaling tables (not implemented yet)
-C
-C input: Id1/2 PDG ID's of incoming particles
-C SS squared c.m. energy (GeV**2)
-C Xi_min min. diff mass (squared) = Xi_min*SS
-C Xi_max max. diff mass (squared) = Xi_max*SS
-C
-C output: sig_sd1 cross section for diss. of particle 1 (mb)
-C sig_sd2 cross section for diss. of particle 2 (mb)
-C sig_dd cross section for diss. of both particles
-C
-C***********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
- INTEGER Id1,Id2
- DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-C some constants
- DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
- COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
- & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
-
- DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
- DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
- & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
- & xms_1,xms_2,CSdiff
-
- INTEGER Ngau1,Ngau2,i1,i2
-
-C model parameters
-
- DATA delta / 0.104d0 /
- DATA alphap / 0.25d0 /
- DATA beta0 / 6.56d0 /
- DATA gpom0 / 1.21d0 /
- DATA xm_p / 0.938d0 /
- DATA x_rad2 / 0.71d0 /
-
-C integration precision
-
- DATA Ngau1 / 96 /
- DATA Ngau2 / 96 /
-
- sig_sd1 = 0.d0
- sig_sd2 = 0.d0
- sig_dd = 0.d0
-
- IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
-
- xm4_p2 = 4.D0*xm_p**2
- fac = beta0**2/(16.D0*PI)
-
- t1 = -5.D0
- t2 = 0.D0
- tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
- tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
-
-C flux renormalization and cross section
-
- Xnorm = 0.d0
-
- xil = log(1.5d0/SS)
- xiu = log(0.1d0)
-
- IF(xiu.LE.xil) goto 1000
-
- CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
- CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
-
- do i1=1,Ngau1
-
- xi = exp(xpos1(i1))
- w_xi = Xwgh1(i1)
-
- do i2=1,Ngau2
-
- tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
-
- alpha_t = 1.D0+delta+alphap*tt
- f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
-
- Xnorm = Xnorm
- & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
-
- enddo
- enddo
-
- Xnorm = Xnorm*fac
-
- 1000 continue
-
- XIL = LOG(Xi_min)
- XIU = LOG(Xi_max)
-
- T1 = -5.D0
- T2 = 0.D0
-
- TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
- TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
-
-C single diffraction diss. cross section
-
- CSdiff = 0.d0
-
- IF(XIU.LE.XIL) goto 2000
-
- CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
- CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
-
- do i1=1,Ngau1
-
- xi = exp(xpos1(i1))
- w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
-
- do i2=1,Ngau2
-
- tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
-
- alpha_t = 1.D0+delta+alphap*tt
- f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
-
- CSdiff = CSdiff
- & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
-
- enddo
- enddo
-
- CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
-
-* WRITE(LO,'(1x,1p,4e14.3)')
-* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
-
- sig_sd1 = CSdiff
- sig_sd2 = CSdiff
-
- 2000 continue
-
-C double diffraction dissociation cross section
-
- CSdiff = 0.d0
-
- xil = log(1.5d0/SS)
- xiu = log(Xi_max/1.5d0)
-
- IF(xiu.LE.xil) goto 3000
-
- fac = (beta0*gpom0*SS**delta
- & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
- & /(2.d0*alphap)
-
- CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
-
- do i1=1,Ngau1
-
- xi = exp(xpos1(i1))
- xms_1 = xi*SS
-
- xiu = log(Xi_max/(xi*SS))
-
- if(xil.lt.xiu) then
-
- CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
-
- do i2=1,Ngau2
-
- xms_2 = exp(xpos2(i2))*SS
- CSdiff = CSdiff
- & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
- & *xwgh1(i1)*xwgh2(i2)
-
- enddo
-
- endif
-
- enddo
-
- sig_dd = CSdiff*fac*GEV2MB
-
- 3000 continue
-
- ELSE
-
- WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
- & 'invalid particle combination (Id1/2)',Id1,Id2
-
- ENDIF
-
- END
-
-CDECK ID>, PHO_ALLM97
- DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
-C**********************************************************************
-C
-C ALLM97 parametrization for gamma*-p cross section
-C (for F2 see comments, code adapted from V. Shekelyan, H1)
-C
-C**********************************************************************
-
- IMPLICIT NONE
-
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DOUBLE PRECISION Q2,W
- DOUBLE PRECISION M02,M12,LAM2,M22
- DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
- DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
- DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
- & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
- DATA ALFA,XMP2 /112.2D0 , .8802D0 /
-
- W2=W*W
- PHO_ALLM97 = 0.D0
-
-C pomeron
- S11 = 0.28067D0
- S12 = 0.22291D0
- S13 = 2.1979D0
- A11 = -0.0808D0
- A12 = -0.44812D0
- A13 = 1.1709D0
- B11 = 0.60243D0
- B12 = 1.3754D0
- B13 = 1.8439D0
- M12 = 49.457D0
-
-C reggeon
- S21 = 0.80107D0
- S22 = 0.97307D0
- S23 = 3.4942D0
- A21 = 0.58400D0
- A22 = 0.37888D0
- A23 = 2.6063D0
- B21 = 0.10711D0
- B22 = 1.9386D0
- B23 = 0.49338D0
- M22 = 0.15052D0
-C
- M02 = 0.31985D0
- LAM2 = 0.065270D0
- Q02 = 0.46017D0 +LAM2
-
-C
- S=0.
- T=LOG((Q2+Q02)/LAM2)
- T0=LOG(Q02/LAM2)
- IF(Q2.GT.0.D0) S=LOG(T/T0)
- Z=1.D0
-
- IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
-
- IF(S.LT.0.01D0) THEN
-
-C pomeron part
-
- XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
-
- AP=A11
- BP=B11**2
-
- SP=S11
- F2P=SP*XP**AP*Z**BP
-
-C reggeon part
-
- XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
-
- AR=A21
- BR=B21**2
-
- SR=S21
- F2R=SR*XR**AR*Z**BR
-
- ELSE
-
-C pomeron part
-
- XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
-
- AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
-
- BP=B11**2+B12**2*S**B13
-
- SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
-
- F2P=SP*XP**AP*Z**BP
-
-C reggeon part
-
- XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
-
- AR=A21+A22*S**A23
- BR=B21**2+B22**2*S**B23
-
- SR=S21+S22*S**S23
- F2R=SR*XR**AR*Z**BR
-
- ENDIF
-
-* F2 = (F2P+F2R)*Q2/(Q2+M02)
-
- CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
- PHO_ALLM97 = CIN*(F2P+F2R)
-
- END
-
-CDECK ID>, PHO_DOR98LO
- SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
-C***********************************************************************
-C
-C GRV98 parton densities, leading order set
-C
-C For a detailed explanation see
-C M. Glueck, E. Reya, A. Vogt :
-C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
-C (To appear in Eur. Phys. J. C)
-C
-C interpolation routine based on the original GRV98PA routine,
-C adapted to define interpolation table as DATA statements
-C
-C (R.Engel, 09/98)
-C
-C
-C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
-C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
-C
-C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
-C DS = d(bar), SS = s = s(bar), GL = gluon.
-C Always x times the distribution is returned.
-C
-C******************************************************i****************
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
- DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
- 1 XSF(NX,NQ), XGF(NX,NQ),
- 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
-
- DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
- & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
-
- EQUIVALENCE (XUVF(1,1),XUVF_L(1))
- EQUIVALENCE (XDVF(1,1),XDVF_L(1))
- EQUIVALENCE (XDEF(1,1),XDEF_L(1))
- EQUIVALENCE (XUDF(1,1),XUDF_L(1))
- EQUIVALENCE (XSF(1,1),XSF_L(1))
- EQUIVALENCE (XGF(1,1),XGF_L(1))
-
- DATA (ARRF(K),K= 1, 95) /
- & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
- & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
- & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
- & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
- & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
- & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
- & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
- & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
- & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
- & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
- & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
- & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
- & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
- & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
- & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
- & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
- & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
- & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
- & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
- DATA (XUVF_L(K),K= 1, 114) /
- &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
- &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
- &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
- &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
- &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
- &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
- &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
- &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
- &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
- &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
- &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
- &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
- &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
- &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
- &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
- &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
- &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
- &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
- &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
- DATA (XUVF_L(K),K= 115, 228) /
- &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
- &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
- &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
- &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
- &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
- &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
- &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
- &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
- &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
- &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
- &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
- &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
- &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
- &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
- &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
- &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
- &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
- &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
- &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
- DATA (XUVF_L(K),K= 229, 342) /
- &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
- &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
- &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
- &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
- &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
- &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
- &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
- &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
- &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
- &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
- &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
- &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
- &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
- &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
- &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
- &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
- &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
- &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
- &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
- DATA (XUVF_L(K),K= 343, 456) /
- &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
- &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
- &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
- &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
- &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
- &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
- &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
- &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
- &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
- &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
- &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
- &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
- &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
- &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
- &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
- &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
- &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
- &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
- &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
- DATA (XUVF_L(K),K= 457, 570) /
- &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
- &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
- &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
- &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
- &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
- &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
- &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
- &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
- &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
- &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
- &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
- &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
- &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
- &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
- &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
- &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
- &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
- &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
- &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
- DATA (XUVF_L(K),K= 571, 684) /
- &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
- &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
- &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
- &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
- &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
- &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
- &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
- &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
- &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
- &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
- &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
- &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
- &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
- &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
- &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
- &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
- &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
- &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
- &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
- DATA (XUVF_L(K),K= 685, 798) /
- &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
- &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
- &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
- &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
- &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
- &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
- &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
- &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
- &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
- &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
- &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
- &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
- &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
- &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
- &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
- &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
- &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
- &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
- &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
- DATA (XUVF_L(K),K= 799, 912) /
- &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
- &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
- &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
- &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
- &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
- &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
- &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
- &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
- &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
- &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
- &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
- &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
- &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
- &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
- &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
- &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
- &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
- &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
- &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
- DATA (XUVF_L(K),K= 913, 1026) /
- &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
- &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
- &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
- &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
- &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
- &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
- &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
- &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
- &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
- &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
- &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
- &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
- &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
- &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
- &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
- &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
- &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
- &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
- &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
- DATA (XUVF_L(K),K= 1027, 1140) /
- &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
- &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
- &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
- &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
- &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
- &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
- &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
- &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
- &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
- &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
- &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
- &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
- &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
- &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
- &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
- &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
- &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
- &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
- &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
- DATA (XUVF_L(K),K= 1141, 1254) /
- &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
- &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
- &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
- &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
- &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
- &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
- &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
- &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
- &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
- &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
- &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
- &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
- &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
- &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
- &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
- &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
- &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
- &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
- &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
- DATA (XUVF_L(K),K= 1255, 1368) /
- &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
- &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
- &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
- &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
- &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
- &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
- &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
- &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
- &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
- &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
- &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
- &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
- &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
- &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
- &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
- &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
- &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
- &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
- &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
- DATA (XUVF_L(K),K= 1369, 1482) /
- &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
- &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
- &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
- &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
- &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
- &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
- &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
- &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
- &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
- &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
- &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
- &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
- &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
- &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
- &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
- &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
- &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
- &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
- &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
- DATA (XUVF_L(K),K= 1483, 1596) /
- &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
- &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
- &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
- &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
- &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
- &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
- &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
- &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
- &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
- &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
- &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
- &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
- &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
- &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
- &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
- &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
- &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
- &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
- &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
- DATA (XUVF_L(K),K= 1597, 1710) /
- &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
- &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
- &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
- &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
- &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
- &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
- &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
- &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
- &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
- &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
- &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
- &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
- &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
- &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
- &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
- &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
- &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
- &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
- &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
- DATA (XUVF_L(K),K= 1711, 1824) /
- &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
- &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
- &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
- &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
- &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
- &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
- &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
- &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
- &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
- &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
- &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
- &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
- &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
- &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
- &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
- &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
- &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
- &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
- &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
- DATA (XUVF_L(K),K= 1825, 1836) /
- &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
- &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
- DATA (XDVF_L(K),K= 1, 114) /
- &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
- &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
- &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
- &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
- &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
- &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
- &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
- &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
- &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
- &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
- &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
- &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
- &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
- &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
- &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
- &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
- &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
- &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
- &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
- DATA (XDVF_L(K),K= 115, 228) /
- &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
- &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
- &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
- &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
- &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
- &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
- &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
- &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
- &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
- &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
- &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
- &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
- &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
- &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
- &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
- &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
- &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
- &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
- &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
- DATA (XDVF_L(K),K= 229, 342) /
- &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
- &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
- &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
- &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
- &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
- &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
- &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
- &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
- &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
- &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
- &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
- &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
- &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
- &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
- &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
- &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
- &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
- &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
- &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
- DATA (XDVF_L(K),K= 343, 456) /
- &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
- &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
- &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
- &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
- &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
- &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
- &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
- &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
- &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
- &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
- &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
- &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
- &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
- &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
- &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
- &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
- &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
- &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
- &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
- DATA (XDVF_L(K),K= 457, 570) /
- &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
- &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
- &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
- &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
- &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
- &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
- &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
- &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
- &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
- &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
- &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
- &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
- &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
- &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
- &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
- &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
- &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
- &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
- &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
- DATA (XDVF_L(K),K= 571, 684) /
- &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
- &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
- &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
- &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
- &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
- &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
- &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
- &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
- &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
- &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
- &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
- &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
- &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
- &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
- &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
- &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
- &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
- &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
- &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
- DATA (XDVF_L(K),K= 685, 798) /
- &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
- &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
- &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
- &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
- &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
- &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
- &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
- &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
- &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
- &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
- &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
- &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
- &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
- &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
- &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
- &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
- &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
- &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
- &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
- DATA (XDVF_L(K),K= 799, 912) /
- &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
- &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
- &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
- &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
- &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
- &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
- &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
- &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
- &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
- &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
- &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
- &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
- &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
- &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
- &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
- &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
- &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
- &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
- &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
- DATA (XDVF_L(K),K= 913, 1026) /
- &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
- &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
- &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
- &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
- &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
- &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
- &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
- &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
- &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
- &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
- &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
- &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
- &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
- &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
- &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
- &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
- &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
- &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
- &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
- DATA (XDVF_L(K),K= 1027, 1140) /
- &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
- &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
- &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
- &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
- &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
- &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
- &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
- &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
- &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
- &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
- &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
- &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
- &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
- &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
- &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
- &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
- &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
- &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
- &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
- DATA (XDVF_L(K),K= 1141, 1254) /
- &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
- &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
- &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
- &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
- &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
- &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
- &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
- &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
- &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
- &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
- &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
- &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
- &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
- &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
- &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
- &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
- &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
- &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
- &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
- DATA (XDVF_L(K),K= 1255, 1368) /
- &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
- &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
- &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
- &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
- &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
- &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
- &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
- &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
- &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
- &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
- &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
- &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
- &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
- &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
- &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
- &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
- &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
- &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
- &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
- DATA (XDVF_L(K),K= 1369, 1482) /
- &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
- &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
- &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
- &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
- &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
- &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
- &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
- &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
- &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
- &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
- &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
- &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
- &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
- &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
- &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
- &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
- &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
- &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
- &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
- DATA (XDVF_L(K),K= 1483, 1596) /
- &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
- &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
- &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
- &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
- &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
- &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
- &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
- &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
- &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
- &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
- &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
- &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
- &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
- &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
- &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
- &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
- &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
- &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
- &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
- DATA (XDVF_L(K),K= 1597, 1710) /
- &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
- &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
- &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
- &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
- &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
- &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
- &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
- &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
- &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
- &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
- &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
- &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
- &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
- &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
- &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
- &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
- &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
- &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
- &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
- DATA (XDVF_L(K),K= 1711, 1824) /
- &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
- &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
- &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
- &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
- &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
- &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
- &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
- &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
- &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
- &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
- &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
- &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
- &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
- &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
- &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
- &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
- &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
- &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
- &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
- DATA (XDVF_L(K),K= 1825, 1836) /
- &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
- &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
- DATA (XDEF_L(K),K= 1, 114) /
- &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
- &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
- &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
- &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
- &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
- &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
- &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
- &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
- &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
- &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
- &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
- &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
- &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
- &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
- &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
- &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
- &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
- &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
- DATA (XDEF_L(K),K= 115, 228) /
- &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
- &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
- &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
- &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
- &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
- &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
- &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
- &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
- &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
- &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
- &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
- &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
- &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
- &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
- &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
- &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
- &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
- DATA (XDEF_L(K),K= 229, 342) /
- &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
- &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
- &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
- &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
- &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
- &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
- &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
- &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
- &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
- &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
- &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
- &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
- &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
- &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
- &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
- &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
- &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
- DATA (XDEF_L(K),K= 343, 456) /
- &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
- &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
- &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
- &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
- &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
- &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
- &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
- &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
- &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
- &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
- &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
- &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
- &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
- &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
- &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
- &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
- &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
- &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
- DATA (XDEF_L(K),K= 457, 570) /
- &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
- &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
- &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
- &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
- &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
- &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
- &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
- &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
- &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
- &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
- &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
- &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
- &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
- &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
- &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
- &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
- &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
- DATA (XDEF_L(K),K= 571, 684) /
- &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
- &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
- &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
- &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
- &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
- &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
- &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
- &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
- &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
- &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
- &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
- &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
- &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
- &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
- &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
- &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
- &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
- DATA (XDEF_L(K),K= 685, 798) /
- &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
- &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
- &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
- &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
- &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
- &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
- &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
- &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
- &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
- &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
- &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
- &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
- &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
- &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
- &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
- &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
- &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
- &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
- DATA (XDEF_L(K),K= 799, 912) /
- &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
- &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
- &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
- &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
- &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
- &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
- &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
- &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
- &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
- &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
- &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
- &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
- &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
- &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
- &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
- &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
- &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
- DATA (XDEF_L(K),K= 913, 1026) /
- &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
- &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
- &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
- &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
- &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
- &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
- &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
- &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
- &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
- &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
- &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
- &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
- &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
- &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
- &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
- &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
- &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
- DATA (XDEF_L(K),K= 1027, 1140) /
- &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
- &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
- &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
- &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
- &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
- &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
- &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
- &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
- &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
- &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
- &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
- &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
- &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
- &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
- &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
- &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
- &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
- &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
- DATA (XDEF_L(K),K= 1141, 1254) /
- &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
- &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
- &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
- &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
- &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
- &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
- &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
- &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
- &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
- &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
- &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
- &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
- &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
- &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
- &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
- &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
- &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
- DATA (XDEF_L(K),K= 1255, 1368) /
- &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
- &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
- &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
- &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
- &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
- &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
- &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
- &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
- &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
- &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
- &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
- &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
- &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
- &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
- &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
- &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
- &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
- DATA (XDEF_L(K),K= 1369, 1482) /
- &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
- &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
- &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
- &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
- &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
- &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
- &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
- &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
- &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
- &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
- &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
- &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
- &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
- &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
- &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
- &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
- &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
- &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
- DATA (XDEF_L(K),K= 1483, 1596) /
- &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
- &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
- &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
- &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
- &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
- &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
- &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
- &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
- &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
- &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
- &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
- &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
- &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
- &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
- &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
- &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
- &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
- DATA (XDEF_L(K),K= 1597, 1710) /
- &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
- &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
- &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
- &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
- &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
- &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
- &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
- &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
- &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
- &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
- &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
- &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
- &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
- &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
- &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
- &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
- &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
- DATA (XDEF_L(K),K= 1711, 1824) /
- &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
- &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
- &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
- &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
- &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
- &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
- &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
- &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
- &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
- &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
- &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
- &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
- &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
- &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
- &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
- &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
- &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
- &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
- DATA (XDEF_L(K),K= 1825, 1836) /
- &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
- &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
- DATA (XUDF_L(K),K= 1, 114) /
- &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
- &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
- &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
- &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
- &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
- &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
- &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
- &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
- &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
- &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
- &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
- &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
- &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
- &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
- &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
- &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
- &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
- &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
- &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
- DATA (XUDF_L(K),K= 115, 228) /
- &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
- &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
- &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
- &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
- &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
- &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
- &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
- &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
- &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
- &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
- &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
- &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
- &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
- &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
- &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
- &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
- &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
- &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
- &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
- DATA (XUDF_L(K),K= 229, 342) /
- &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
- &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
- &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
- &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
- &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
- &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
- &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
- &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
- &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
- &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
- &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
- &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
- &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
- &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
- &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
- &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
- &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
- &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
- &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
- DATA (XUDF_L(K),K= 343, 456) /
- &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
- &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
- &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
- &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
- &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
- &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
- &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
- &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
- &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
- &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
- &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
- &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
- &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
- &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
- &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
- &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
- &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
- &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
- &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
- DATA (XUDF_L(K),K= 457, 570) /
- &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
- &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
- &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
- &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
- &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
- &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
- &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
- &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
- &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
- &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
- &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
- &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
- &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
- &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
- &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
- &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
- &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
- &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
- &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
- DATA (XUDF_L(K),K= 571, 684) /
- &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
- &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
- &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
- &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
- &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
- &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
- &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
- &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
- &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
- &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
- &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
- &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
- &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
- &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
- &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
- &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
- &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
- &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
- &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
- DATA (XUDF_L(K),K= 685, 798) /
- &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
- &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
- &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
- &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
- &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
- &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
- &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
- &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
- &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
- &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
- &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
- &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
- &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
- &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
- &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
- &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
- &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
- &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
- &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
- DATA (XUDF_L(K),K= 799, 912) /
- &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
- &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
- &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
- &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
- &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
- &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
- &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
- &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
- &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
- &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
- &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
- &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
- &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
- &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
- &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
- &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
- &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
- &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
- &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
- DATA (XUDF_L(K),K= 913, 1026) /
- &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
- &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
- &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
- &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
- &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
- &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
- &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
- &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
- &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
- &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
- &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
- &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
- &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
- &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
- &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
- &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
- &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
- &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
- &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
- DATA (XUDF_L(K),K= 1027, 1140) /
- &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
- &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
- &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
- &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
- &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
- &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
- &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
- &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
- &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
- &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
- &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
- &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
- &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
- &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
- &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
- &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
- &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
- &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
- &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
- DATA (XUDF_L(K),K= 1141, 1254) /
- &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
- &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
- &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
- &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
- &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
- &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
- &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
- &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
- &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
- &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
- &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
- &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
- &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
- &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
- &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
- &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
- &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
- &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
- &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
- DATA (XUDF_L(K),K= 1255, 1368) /
- &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
- &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
- &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
- &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
- &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
- &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
- &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
- &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
- &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
- &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
- &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
- &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
- &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
- &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
- &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
- &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
- &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
- &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
- &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
- DATA (XUDF_L(K),K= 1369, 1482) /
- &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
- &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
- &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
- &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
- &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
- &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
- &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
- &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
- &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
- &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
- &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
- &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
- &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
- &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
- &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
- &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
- &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
- &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
- &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
- DATA (XUDF_L(K),K= 1483, 1596) /
- &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
- &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
- &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
- &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
- &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
- &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
- &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
- &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
- &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
- &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
- &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
- &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
- &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
- &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
- &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
- &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
- &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
- &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
- &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
- DATA (XUDF_L(K),K= 1597, 1710) /
- &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
- &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
- &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
- &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
- &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
- &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
- &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
- &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
- &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
- &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
- &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
- &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
- &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
- &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
- &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
- &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
- &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
- &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
- &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
- DATA (XUDF_L(K),K= 1711, 1824) /
- &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
- &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
- &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
- &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
- &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
- &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
- &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
- &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
- &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
- &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
- &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
- &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
- &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
- &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
- &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
- &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
- &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
- &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
- &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
- DATA (XUDF_L(K),K= 1825, 1836) /
- &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
- &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
- DATA (XSF_L(K),K= 1, 114) /
- &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
- &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
- &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
- &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
- &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
- &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
- &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
- &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
- &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
- &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
- &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
- &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
- &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
- &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
- &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
- &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
- &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
- &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
- &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
- DATA (XSF_L(K),K= 115, 228) /
- &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
- &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
- &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
- &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
- &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
- &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
- &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
- &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
- &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
- &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
- &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
- &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
- &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
- &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
- &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
- &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
- &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
- &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
- &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
- DATA (XSF_L(K),K= 229, 342) /
- &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
- &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
- &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
- &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
- &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
- &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
- &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
- &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
- &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
- &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
- &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
- &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
- &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
- &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
- &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
- &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
- &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
- &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
- &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
- DATA (XSF_L(K),K= 343, 456) /
- &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
- &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
- &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
- &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
- &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
- &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
- &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
- &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
- &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
- &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
- &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
- &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
- &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
- &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
- &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
- &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
- &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
- &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
- &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
- DATA (XSF_L(K),K= 457, 570) /
- &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
- &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
- &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
- &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
- &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
- &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
- &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
- &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
- &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
- &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
- &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
- &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
- &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
- &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
- &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
- &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
- &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
- &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
- &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
- DATA (XSF_L(K),K= 571, 684) /
- &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
- &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
- &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
- &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
- &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
- &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
- &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
- &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
- &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
- &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
- &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
- &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
- &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
- &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
- &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
- &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
- &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
- &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
- &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
- DATA (XSF_L(K),K= 685, 798) /
- &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
- &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
- &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
- &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
- &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
- &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
- &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
- &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
- &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
- &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
- &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
- &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
- &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
- &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
- &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
- &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
- &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
- &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
- &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
- DATA (XSF_L(K),K= 799, 912) /
- &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
- &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
- &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
- &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
- &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
- &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
- &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
- &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
- &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
- &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
- &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
- &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
- &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
- &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
- &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
- &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
- &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
- &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
- &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
- DATA (XSF_L(K),K= 913, 1026) /
- &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
- &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
- &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
- &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
- &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
- &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
- &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
- &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
- &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
- &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
- &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
- &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
- &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
- &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
- &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
- &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
- &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
- &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
- &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
- DATA (XSF_L(K),K= 1027, 1140) /
- &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
- &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
- &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
- &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
- &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
- &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
- &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
- &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
- &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
- &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
- &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
- &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
- &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
- &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
- &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
- &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
- &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
- &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
- &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
- DATA (XSF_L(K),K= 1141, 1254) /
- &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
- &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
- &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
- &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
- &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
- &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
- &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
- &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
- &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
- &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
- &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
- &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
- &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
- &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
- &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
- &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
- &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
- &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
- &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
- DATA (XSF_L(K),K= 1255, 1368) /
- &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
- &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
- &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
- &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
- &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
- &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
- &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
- &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
- &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
- &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
- &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
- &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
- &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
- &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
- &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
- &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
- &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
- &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
- &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
- DATA (XSF_L(K),K= 1369, 1482) /
- &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
- &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
- &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
- &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
- &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
- &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
- &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
- &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
- &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
- &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
- &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
- &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
- &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
- &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
- &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
- &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
- &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
- &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
- &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
- DATA (XSF_L(K),K= 1483, 1596) /
- &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
- &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
- &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
- &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
- &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
- &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
- &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
- &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
- &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
- &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
- &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
- &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
- &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
- &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
- &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
- &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
- &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
- &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
- &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
- DATA (XSF_L(K),K= 1597, 1710) /
- &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
- &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
- &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
- &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
- &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
- &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
- &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
- &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
- &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
- &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
- &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
- &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
- &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
- &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
- &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
- &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
- &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
- &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
- &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
- DATA (XSF_L(K),K= 1711, 1824) /
- &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
- &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
- &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
- &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
- &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
- &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
- &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
- &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
- &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
- &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
- &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
- &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
- &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
- &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
- &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
- &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
- &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
- &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
- &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
- DATA (XSF_L(K),K= 1825, 1836) /
- &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
- &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
- DATA (XGF_L(K),K= 1, 114) /
- &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
- &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
- &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
- &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
- &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
- &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
- &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
- &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
- &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
- &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
- &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
- &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
- &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
- &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
- &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
- &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
- &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
- &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
- &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
- DATA (XGF_L(K),K= 115, 228) /
- &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
- &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
- &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
- &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
- &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
- &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
- &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
- &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
- &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
- &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
- &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
- &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
- &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
- &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
- &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
- &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
- &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
- &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
- &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
- DATA (XGF_L(K),K= 229, 342) /
- &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
- &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
- &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
- &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
- &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
- &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
- &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
- &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
- &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
- &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
- &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
- &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
- &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
- &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
- &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
- &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
- &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
- &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
- &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
- DATA (XGF_L(K),K= 343, 456) /
- &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
- &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
- &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
- &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
- &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
- &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
- &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
- &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
- &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
- &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
- &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
- &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
- &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
- &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
- &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
- &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
- &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
- &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
- &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
- DATA (XGF_L(K),K= 457, 570) /
- &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
- &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
- &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
- &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
- &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
- &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
- &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
- &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
- &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
- &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
- &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
- &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
- &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
- &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
- &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
- &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
- &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
- &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
- &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
- DATA (XGF_L(K),K= 571, 684) /
- &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
- &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
- &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
- &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
- &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
- &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
- &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
- &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
- &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
- &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
- &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
- &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
- &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
- &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
- &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
- &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
- &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
- &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
- &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
- DATA (XGF_L(K),K= 685, 798) /
- &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
- &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
- &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
- &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
- &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
- &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
- &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
- &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
- &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
- &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
- &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
- &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
- &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
- &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
- &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
- &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
- &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
- &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
- &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
- DATA (XGF_L(K),K= 799, 912) /
- &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
- &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
- &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
- &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
- &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
- &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
- &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
- &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
- &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
- &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
- &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
- &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
- &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
- &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
- &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
- &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
- &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
- &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
- &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
- DATA (XGF_L(K),K= 913, 1026) /
- &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
- &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
- &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
- &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
- &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
- &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
- &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
- &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
- &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
- &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
- &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
- &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
- &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
- &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
- &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
- &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
- &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
- &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
- &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
- DATA (XGF_L(K),K= 1027, 1140) /
- &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
- &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
- &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
- &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
- &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
- &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
- &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
- &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
- &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
- &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
- &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
- &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
- &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
- &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
- &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
- &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
- &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
- &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
- &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
- DATA (XGF_L(K),K= 1141, 1254) /
- &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
- &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
- &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
- &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
- &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
- &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
- &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
- &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
- &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
- &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
- &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
- &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
- &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
- &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
- &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
- &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
- &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
- &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
- &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
- DATA (XGF_L(K),K= 1255, 1368) /
- &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
- &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
- &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
- &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
- &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
- &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
- &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
- &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
- &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
- &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
- &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
- &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
- &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
- &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
- &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
- &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
- &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
- &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
- &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
- DATA (XGF_L(K),K= 1369, 1482) /
- &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
- &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
- &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
- &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
- &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
- &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
- &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
- &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
- &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
- &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
- &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
- &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
- &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
- &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
- &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
- &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
- &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
- &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
- &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
- DATA (XGF_L(K),K= 1483, 1596) /
- &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
- &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
- &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
- &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
- &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
- &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
- &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
- &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
- &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
- &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
- &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
- &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
- &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
- &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
- &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
- &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
- &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
- &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
- &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
- DATA (XGF_L(K),K= 1597, 1710) /
- &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
- &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
- &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
- &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
- &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
- &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
- &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
- &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
- &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
- &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
- &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
- &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
- &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
- &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
- &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
- &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
- &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
- &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
- &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
- DATA (XGF_L(K),K= 1711, 1824) /
- &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
- &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
- &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
- &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
- &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
- &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
- &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
- &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
- &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
- &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
- &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
- &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
- &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
- &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
- &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
- &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
- &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
- &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
- &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
- DATA (XGF_L(K),K= 1825, 1836) /
- &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
- &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
-
-*
- X = Xinp
-*...CHECK OF X AND Q2 VALUES :
- IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
-* WRITE(LO,91) X
- 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
- X = 0.99D-9
-* STOP
- ENDIF
-
- Q2 = Q2inp
- IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
-* WRITE(LO,92) Q2
- 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
- Q2 = 0.99E6
-* STOP
- ENDIF
-
-*
-*...INTERPOLATION :
- NA(1) = NX
- NA(2) = NQ
- XT(1) = DLOG(X)
- XT(2) = DLOG(Q2)
- X1 = 1.- X
- XV = X**0.5
- XS = X**(-0.2)
- UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
- DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
- DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
- UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
- US = 0.5 * (UD - DE)
- DS = 0.5 * (UD + DE)
- SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
- GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
-
- END
-
-CDECK ID>, PHO_DOR98SC
- SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
-C***********************************************************************
-C
-C GRV98 parton densities, leading order set
-C
-C For a detailed explanation see
-C M. Glueck, E. Reya, A. Vogt :
-C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
-C (To appear in Eur. Phys. J. C)
-C
-C interpolation routine based on the original GRV98PA routine,
-C adapted to define interpolation table as DATA statements
-C
-C (R.Engel, 09/98)
-C
-C CAUTION: this is a version with gluon shadowing corrections
-C (R.Engel, 09/99)
-C
-C
-C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
-C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
-C
-C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
-C DS = d(bar), SS = s = s(bar), GL = gluon.
-C Always x times the distribution is returned.
-C
-C******************************************************i****************
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
- DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
- 1 XSF(NX,NQ), XGF(NX,NQ),
- 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
-
- DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
- & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
-
- EQUIVALENCE (XUVF(1,1),XUVF_L(1))
- EQUIVALENCE (XDVF(1,1),XDVF_L(1))
- EQUIVALENCE (XDEF(1,1),XDEF_L(1))
- EQUIVALENCE (XUDF(1,1),XUDF_L(1))
- EQUIVALENCE (XSF(1,1),XSF_L(1))
- EQUIVALENCE (XGF(1,1),XGF_L(1))
-
-*#################### data statements for shadowed LO PDF ##############
-C ... deleted ...
-*#######################################################################
-
- X = Xinp
-*...CHECK OF X AND Q2 VALUES :
- IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
-* WRITE(LO,91) X
- 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
- X = 0.99D-9
-* STOP
- ENDIF
-
- Q2 = Q2inp
- IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
-* WRITE(LO,92) Q2
- 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
- Q2 = 0.99E6
-* STOP
- ENDIF
-
-*
-*...INTERPOLATION :
- NA(1) = NX
- NA(2) = NQ
- XT(1) = DLOG(X)
- XT(2) = DLOG(Q2)
- X1 = 1.- X
- XV = X**0.5
- XS = X**(-0.2)
- UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
- DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
- DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
- UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
- US = 0.5 * (UD - DE)
- DS = 0.5 * (UD + DE)
- SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
- GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
-
- END
-
-CDECK ID>, PHO_DOR94LO
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-* *
-* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
-* *
-* 1994 UPDATE *
-* *
-* FOR A DETAILED EXPLANATION SEE *
-* M. GLUECK, E.REYA, A.VOGT : *
-* DO-TH 94/24 = DESY 94-206 *
-* (TO APPEAR IN Z. PHYS. C) *
-* *
-* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
-* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
-* X BETWEEN 1.E-5 AND 1. *
-* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
-* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
-* *
-* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
-* M(C) = 1.5, M(B) = 4.5 *
-* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
-* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.153, *
-* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.131. *
-* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
-* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
-* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
-* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
-* GRV PARAMETRIZATION. *
-* *
-* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
-* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
-* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
-* *
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-*
-*...INPUT PARAMETERS :
-*
-* X = MOMENTUM FRACTION
-* Q2 = SCALE Q**2 IN GEV**2
-*
-*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
-*
-* UV = U(VAL) = U - U(BAR)
-* DV = D(VAL) = D - D(BAR)
-* DEL = D(BAR) - U(BAR)
-* UDB = U(BAR) + D(BAR)
-* SB = S = S(BAR)
-* GL = GLUON
-*
-*...LO PARAMETRIZATION :
-*
- SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.23
- LAM2 = 0.2322 * 0.2322
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-*...UV :
- NU = 2.284 + 0.802 * S + 0.055 * S2
- AKU = 0.590 - 0.024 * S
- BKU = 0.131 + 0.063 * S
- AU = -0.449 - 0.138 * S - 0.076 * S2
- BU = 0.213 + 2.669 * S - 0.728 * S2
- CU = 8.854 - 9.135 * S + 1.979 * S2
- DU = 2.997 + 0.753 * S - 0.076 * S2
- UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
-*...DV :
- ND = 0.371 + 0.083 * S + 0.039 * S2
- AKD = 0.376
- BKD = 0.486 + 0.062 * S
- AD = -0.509 + 3.310 * S - 1.248 * S2
- BD = 12.41 - 10.52 * S + 2.267 * S2
- CD = 6.373 - 6.208 * S + 1.418 * S2
- DD = 3.691 + 0.799 * S - 0.071 * S2
- DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
-*...DEL :
- NE = 0.082 + 0.014 * S + 0.008 * S2
- AKE = 0.409 - 0.005 * S
- BKE = 0.799 + 0.071 * S
- AE = -38.07 + 36.13 * S - 0.656 * S2
- BE = 90.31 - 74.15 * S + 7.645 * S2
- CE = 0.0
- DE = 7.486 + 1.217 * S - 0.159 * S2
- DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
-*...UDB :
- ALX = 1.451
- BEX = 0.271
- AKX = 0.410 - 0.232 * S
- BKX = 0.534 - 0.457 * S
- AGX = 0.890 - 0.140 * S
- BGX = -0.981
- CX = 0.320 + 0.683 * S
- DX = 4.752 + 1.164 * S + 0.286 * S2
- EX = 4.119 + 1.713 * S
- ESX = 0.682 + 2.978 * S
- UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
-*...SB :
- ALS = 0.914
- BES = 0.577
- AKS = 1.798 - 0.596 * S
- AS = -5.548 + 3.669 * DS - 0.616 * S
- BS = 18.92 - 16.73 * DS + 5.168 * S
- DST = 6.379 - 0.350 * S + 0.142 * S2
- EST = 3.981 + 1.638 * S
- ESS = 6.402
- SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-*...GL :
- ALG = 0.524
- BEG = 1.088
- AKG = 1.742 - 0.930 * S
- BKG = - 0.399 * S2
- AG = 7.486 - 2.185 * S
- BG = 16.69 - 22.74 * S + 5.779 * S2
- CG = -25.59 + 29.71 * S - 7.296 * S2
- DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
- EG = 0.807 + 2.005 * S
- ESG = 3.841 + 0.316 * S
- GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
-
- END
-
-*
-*...NLO PARAMETRIZATION (MS(BAR)) :
-*
-CDECK ID>, PHO_DOR94HO
- SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.34
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-*...UV :
- NU = 1.304 + 0.863 * S
- AKU = 0.558 - 0.020 * S
- BKU = 0.183 * S
- AU = -0.113 + 0.283 * S - 0.321 * S2
- BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
- CU = 7.771 - 10.09 * S + 2.630 * S2
- DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
- UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
-*...DV :
- ND = 0.102 - 0.017 * S + 0.005 * S2
- AKD = 0.270 - 0.019 * S
- BKD = 0.260
- AD = 2.393 + 6.228 * S - 0.881 * S2
- BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
- CD = 17.83 - 53.47 * S + 21.24 * S2
- DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
- DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
-*...DEL :
- NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
- AKE = 0.409 - 0.007 * S
- BKE = 0.782 + 0.082 * S
- AE = -29.65 + 26.49 * S + 5.429 * S2
- BE = 90.20 - 74.97 * S + 4.526 * S2
- CE = 0.0
- DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
- DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
-*...UDB :
- ALX = 0.877
- BEX = 0.561
- AKX = 0.275
- BKX = 0.0
- AGX = 0.997
- BGX = 3.210 - 1.866 * S
- CX = 7.300
- DX = 9.010 + 0.896 * DS + 0.222 * S2
- EX = 3.077 + 1.446 * S
- ESX = 3.173 - 2.445 * DS + 2.207 * S
- UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
-*...SB :
- ALS = 0.756
- BES = 0.216
- AKS = 1.690 + 0.650 * DS - 0.922 * S
- AS = -4.329 + 1.131 * S
- BS = 9.568 - 1.744 * S
- DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
- EST = 3.031 + 1.639 * S
- ESS = 5.837 + 0.815 * S
- SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-*...GL :
- ALG = 1.014
- BEG = 1.738
- AKG = 1.724 + 0.157 * S
- BKG = 0.800 + 1.016 * S
- AG = 7.517 - 2.547 * S
- BG = 34.09 - 52.21 * DS + 17.47 * S
- CG = 4.039 + 1.491 * S
- DG = 3.404 + 0.830 * S
- EG = -1.112 + 3.438 * S - 0.302 * S2
- ESG = 3.256 - 0.436 * S
- GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
-
- END
-
-CDECK ID>, PHO_DOR94DI
-*
-*...NLO PARAMETRIZATION (DIS) :
-*
- SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.34
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-*...UV :
- NU = 2.484 + 0.116 * S + 0.093 * S2
- AKU = 0.563 - 0.025 * S
- BKU = 0.054 + 0.154 * S
- AU = -0.326 - 0.058 * S - 0.135 * S2
- BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
- CU = 11.52 - 12.99 * S + 3.161 * S2
- DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
- UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
-*...DV :
- ND = 0.156 - 0.017 * S
- AKD = 0.299 - 0.022 * S
- BKD = 0.259 - 0.015 * S
- AD = 3.445 + 1.278 * S + 0.326 * S2
- BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
- CD = 55.45 - 69.92 * S + 20.78 * S2
- DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
- DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
-*...DEL :
- NE = 0.099 + 0.019 * S + 0.002 * S2
- AKE = 0.419 - 0.013 * S
- BKE = 1.064 - 0.038 * S
- AE = -44.00 + 98.70 * S - 14.79 * S2
- BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
- CE = 84.57 - 108.8 * S + 31.52 * S2
- DE = 7.469 + 2.480 * S - 0.866 * S2
- DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
-*...UDB :
- ALX = 1.215
- BEX = 0.466
- AKX = 0.326 + 0.150 * S
- BKX = 0.956 + 0.405 * S
- AGX = 0.272
- BGX = 3.794 - 2.359 * DS
- CX = 2.014
- DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
- EX = 3.049 + 1.597 * S
- ESX = 4.396 - 4.594 * DS + 3.268 * S
- UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
-*...SB :
- ALS = 0.175
- BES = 0.344
- AKS = 1.415 - 0.641 * DS
- AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
- BS = 5.617 + 5.709 * DS - 3.972 * S
- DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
- EST = 4.546 + 0.372 * S2
- ESS = 5.053 - 1.070 * S + 0.805 * S2
- SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-*...GL :
- ALG = 1.258
- BEG = 1.846
- AKG = 2.423
- BKG = 2.427 + 1.311 * S - 0.153 * S2
- AG = 25.09 - 7.935 * S
- BG = -14.84 - 124.3 * DS + 72.18 * S
- CG = 590.3 - 173.8 * S
- DG = 5.196 + 1.857 * S
- EG = -1.648 + 3.988 * S - 0.432 * S2
- ESG = 3.232 - 0.542 * S
- GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
-
- END
-
-*
-*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
-*
-CDECK ID>, PHO_DOR94FV
- DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
-
- END
-
-CDECK ID>, PHO_DOR94FW
- DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
- & A,B,C,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- LX = LOG (1./X)
- PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
- 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DOR94FS
- DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- LX = LOG (1./X)
- PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
- 1 * DEXP (-E + SQRT (ES * S**BE * LX))
-
- END
-
-CDECK ID>, PHO_DOR92LO
-*
-*
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-* *
-* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
-* *
-* FOR A DETAILED EXPLANATION SEE : *
-* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
-* *
-* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
-* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
-* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
-* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
-* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
-* *
-* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
-* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
-* *
-* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
-* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
-* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
-* *
-* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
-* *
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-C
- SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.25
- LAM2 = 0.232 * 0.232
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- S2 = S * S
- S3 = S2 * S
-C...X * (UV + DV) :
- NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
- AKUD = 0.326
- AGUD = -1.97 + 6.74 * S - 1.96 * S2
- BUD = 24.4 - 20.7 * S + 4.08 * S2
- DUD = 2.86 + 0.70 * S - 0.02 * S2
- UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
-C...X * DV :
- ND = 0.579 + 0.283 * S + 0.047 * S2
- AKD = 0.523 - 0.015 * S
- AGD = 2.22 - 0.59 * S - 0.27 * S2
- BD = 5.95 - 6.19 * S + 1.55 * S2
- DD = 3.57 + 0.94 * S - 0.16 * S2
- DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
-C...X * G :
- ALG = 0.558
- BEG = 1.218
- AKG = 1.00 - 0.17 * S
- BKG = 0.0
- AGG = 0.0 + 4.879 * S - 1.383 * S2
- BGG = 25.92 - 28.97 * S + 5.596 * S2
- CG = -25.69 + 23.68 * S - 1.975 * S2
- DG = 2.537 + 1.718 * S + 0.353 * S2
- EG = 0.595 + 2.138 * S
- ESG = 4.066
- GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
-C...X * UBAR = X * DBAR :
- ALU = 1.396
- BEU = 1.331
- AKU = 0.412 - 0.171 * S
- BKU = 0.566 - 0.496 * S
- AGU = 0.363
- BGU = -1.196
- CU = 1.029 + 1.785 * S - 0.459 * S2
- DU = 4.696 + 2.109 * S
- EU = 3.838 + 1.944 * S
- ESU = 2.845
- UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
-C...X * SBAR = X * S :
- SS = 0.0
- ALS = 0.803
- BES = 0.563
- AKS = 2.082 - 0.577 * S
- AGS = -3.055 + 1.024 * S ** 0.67
- BS = 27.4 - 20.0 * S ** 0.154
- DS = 6.22
- EST = 4.33 + 1.408 * S
- ESS = 8.27 - 0.437 * S
- SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
-C...X * CBAR = X * C :
- SC = 0.888
- ALC = 1.01
- BEC = 0.37
- AKC = 0.0
- AGC = 0.0
- BC = 4.24 - 0.804 * S
- DC = 3.46 + 1.076 * S
- EC = 4.61 + 1.490 * S
- ESC = 2.555 + 1.961 * S
- CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
-C...X * BBAR = X * B :
- SBO = 1.351
- ALB = 1.00
- BEB = 0.51
- AKB = 0.0
- AGB = 0.0
- BBO = 1.848
- DB = 2.929 + 1.396 * S
- EB = 4.71 + 1.514 * S
- ESB = 4.02 + 1.239 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
-
- END
-
-CDECK ID>, PHO_DOR92HO
- SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.3
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-C...X * (UV + DV) :
- NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
- AKUD = 0.285
- AGUD = -2.28 + 15.73 * S - 4.58 * S2
- BUD = 56.7 - 53.6 * S + 11.21 * S2
- DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
- UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
-C...X * DV :
- ND = 0.459 + 0.315 * DS + 0.515 * S
- AKD = 0.624 - 0.031 * S
- AGD = 8.13 - 6.77 * DS + 0.46 * S
- BD = 6.59 - 12.83 * DS + 5.65 * S
- DD = 3.98 + 1.04 * S - 0.34 * S2
- DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
-C...X * G :
- ALG = 1.128
- BEG = 1.575
- AKG = 0.323 + 1.653 * S
- BKG = 0.811 + 2.044 * S
- AGG = 0.0 + 1.963 * S - 0.519 * S2
- BGG = 0.078 + 6.24 * S
- CG = 30.77 - 24.19 * S
- DG = 3.188 + 0.720 * S
- EG = -0.881 + 2.687 * S
- ESG = 2.466
- GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
-C...X * UBAR = X * DBAR :
- ALU = 0.594
- BEU = 0.614
- AKU = 0.636 - 0.084 * S
- BKU = 0.0
- AGU = 1.121 - 0.193 * S
- BGU = 0.751 - 0.785 * S
- CU = 8.57 - 1.763 * S
- DU = 10.22 + 0.668 * S
- EU = 3.784 + 1.280 * S
- ESU = 1.808 + 0.980 * S
- UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
-C...X * SBAR = X * S :
- SS = 0.0
- ALS = 0.756
- BES = 0.101
- AKS = 2.942 - 1.016 * S
- AGS = -4.60 + 1.167 * S
- BS = 9.31 - 1.324 * S
- DS = 11.49 - 1.198 * S + 0.053 * S2
- EST = 2.630 + 1.729 * S
- ESS = 8.12
- SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
-C...X * CBAR = X * C :
- SC = 0.820
- ALC = 0.98
- BEC = 0.0
- AKC = -0.625 - 0.523 * S
- AGC = 0.0
- BC = 1.896 + 1.616 * S
- DC = 4.12 + 0.683 * S
- EC = 4.36 + 1.328 * S
- ESC = 0.677 + 0.679 * S
- CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
-C...X * BBAR = X * B :
- SBO = 1.297
- ALB = 0.99
- BEB = 0.0
- AKB = 0.0 - 0.193 * S
- AGB = 0.0
- BBO = 0.0
- DB = 3.447 + 0.927 * S
- EB = 4.68 + 1.259 * S
- ESB = 1.892 + 2.199 * S
- BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
-
- END
-
-CDECK ID>, PHO_DOR92FV
- DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
- DX = SQRT (X)
- PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DOR92FW
- DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
- & AL,BE,AK,BK,AG,BG,C,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
- LX = LOG (1./X)
- PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
- 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DOR92FS
- DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- LX = LOG (1./X)
- IF (S .LE. ST) THEN
- PHO_DOR92FS = 0.D0
- ELSE
- PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
- 1 * EXP (-E + SQRT (ES * S**BE * LX))
- END IF
-
- END
-
-CDECK ID>, PHO_DORPLO
-*
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-* *
-* G R V - P I O N - P A R A M E T R I Z A T I O N S *
-* *
-* FOR A DETAILED EXPLANATION SEE : *
-* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
-* *
-* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
-* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
-* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
-* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
-* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
-* *
-* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
-* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
-* *
-* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
-* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
-* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
-* *
-* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
-* *
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-C
- SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.25
- LAM2 = 0.232 * 0.232
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
-C...X * VALENCE :
- NV = 0.519 + 0.180 * S - 0.011 * S2
- AKV = 0.499 - 0.027 * S
- AGV = 0.381 - 0.419 * S
- DV = 0.367 + 0.563 * S
- VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
-C...X * GLUON :
- ALG = 0.599
- BEG = 1.263
- AKG = 0.482 + 0.341 * DS
- BKG = 0.0
- AGG = 0.678 + 0.877 * S - 0.175 * S2
- BGG = 0.338 - 1.597 * S
- CG = 0.0 - 0.233 * S + 0.406 * S2
- DG = 0.390 + 1.053 * S
- EG = 0.618 + 2.070 * S
- ESG = 3.676
- GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
-C...X * QBAR (SU(3)-SYMMETRIC SEA) :
- SL = 0.0
- ALS = 0.55
- BES = 0.56
- AKS = 2.538 - 0.763 * S
- AGS = -0.748
- BS = 0.313 + 0.935 * S
- DS = 3.359
- EST = 4.433 + 1.301 * S
- ESS = 9.30 - 0.887 * S
- QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
-C...X * CBAR = X * C :
- SC = 0.888
- ALC = 1.02
- BEC = 0.39
- AKC = 0.0
- AGC = 0.0
- BC = 1.008
- DC = 1.208 + 0.771 * S
- EC = 4.40 + 1.493 * S
- ESC = 2.032 + 1.901 * S
- CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
-C...X * BBAR = X * B :
- SBO = 1.351
- ALB = 1.03
- BEB = 0.39
- AKB = 0.0
- AGB = 0.0
- BBO = 0.0
- DB = 0.697 + 0.855 * S
- EB = 4.51 + 1.490 * S
- ESB = 3.056 + 1.694 * S
- BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
-
- END
-
-CDECK ID>, PHO_DORPHO
- SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.3
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
-C...X * VALENCE :
- NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
- AKV = 0.505 - 0.033 * S
- AGV = 0.748 - 0.669 * DS - 0.133 * S
- DV = 0.365 + 0.197 * DS + 0.394 * S
- VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
-C...X * GLUON :
- ALG = 1.096
- BEG = 1.371
- AKG = 0.437 - 0.689 * DS
- BKG = -0.631
- AGG = 1.324 - 0.441 * DS - 0.130 * S
- BGG = -0.955 + 0.259 * S
- CG = 1.075 - 0.302 * S
- DG = 1.158 + 1.229 * S
- EG = 0.0 + 2.510 * S
- ESG = 2.604 + 0.165 * S
- GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
-C...X * QBAR (SU(3)-SYMMETRIC SEA) :
- SL = 0.0
- ALS = 0.85
- BES = 0.96
- AKS = -0.350 + 0.806 * S
- AGS = -1.663
- BS = 3.148
- DS = 2.273 + 1.438 * S
- EST = 3.214 + 1.545 * S
- ESS = 1.341 + 1.938 * S
- QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
-C...X * CBAR = X * C :
- SC = 0.820
- ALC = 0.98
- BEC = 0.0
- AKC = 0.0 - 0.457 * S
- AGC = 0.0
- BC = -1.00 + 1.40 * S
- DC = 1.318 + 0.584 * S
- EC = 4.45 + 1.235 * S
- ESC = 1.496 + 1.010 * S
- CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
-C...X * BBAR = X * B :
- SBO = 1.297
- ALB = 0.99
- BEB = 0.0
- AKB = 0.0 - 0.172 * S
- AGB = 0.0
- BBO = 0.0
- DB = 1.447 + 0.485 * S
- EB = 4.79 + 1.164 * S
- ESB = 1.724 + 2.121 * S
- BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
-
- END
-
-CDECK ID>, PHO_DORFVP
- DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DORFGP
- DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
- & BG,C,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- LX = LOG (1./X)
- PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
- 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DORFQP
- DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- DX = SQRT (X)
- LX = LOG (1./X)
- IF (S .LE. ST) THEN
- PHO_DORFQP = 0.0
- ELSE
- PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
- 1 * EXP (-E + SQRT (ES * S**BE * LX))
- END IF
-
- END
-
-CDECK ID>, PHO_DORGLO
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-* *
-* G R V - P H O T O N - P A R A M E T R I Z A T I O N S *
-* *
-* FOR A DETAILED EXPLANATION SEE : *
-* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
-* *
-* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
-* *
-* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
-* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
-* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
-* *
-* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
-* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
-* *
-* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
-* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
-* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
-* *
-* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
-* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
-* *
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-C
- SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.25
- LAM2 = 0.232 * 0.232
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- SS = SQRT (S)
- S2 = S * S
-C...X * U = X * UBAR :
- AL = 1.717
- BE = 0.641
- AK = 0.500 - 0.176 * S
- BK = 15.00 - 5.687 * SS - 0.552 * S2
- AG = 0.235 + 0.046 * SS
- BG = 0.082 - 0.051 * S + 0.168 * S2
- C = 0.0 + 0.459 * S
- D = 0.354 - 0.061 * S
- E = 4.899 + 1.678 * S
- ES = 2.046 + 1.389 * S
- UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * D = X * DBAR :
- AL = 1.549
- BE = 0.782
- AK = 0.496 + 0.026 * S
- BK = 0.685 - 0.580 * SS + 0.608 * S2
- AG = 0.233 + 0.302 * S
- BG = 0.0 - 0.818 * S + 0.198 * S2
- C = 0.114 + 0.154 * S
- D = 0.405 - 0.195 * S + 0.046 * S2
- E = 4.807 + 1.226 * S
- ES = 2.166 + 0.664 * S
- DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * G :
- AL = 0.676
- BE = 1.089
- AK = 0.462 - 0.524 * SS
- BK = 5.451 - 0.804 * S2
- AG = 0.535 - 0.504 * SS + 0.288 * S2
- BG = 0.364 - 0.520 * S
- C = -0.323 + 0.115 * S2
- D = 0.233 + 0.790 * S - 0.139 * S2
- E = 0.893 + 1.968 * S
- ES = 3.432 + 0.392 * S
- GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * S = X * SBAR :
- SF = 0.0
- AL = 1.609
- BE = 0.962
- AK = 0.470 - 0.099 * S2
- BK = 3.246
- AG = 0.121 - 0.068 * SS
- BG = -0.090 + 0.074 * S
- C = 0.062 + 0.034 * S
- D = 0.0 + 0.226 * S - 0.060 * S2
- E = 4.288 + 1.707 * S
- ES = 2.122 + 0.656 * S
- SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * C = X * CBAR :
- SF = 0.888
- AL = 0.970
- BE = 0.545
- AK = 1.254 - 0.251 * S
- BK = 3.932 - 0.327 * S2
- AG = 0.658 + 0.202 * S
- BG = -0.699
- C = 0.965
- D = 0.0 + 0.141 * S - 0.027 * S2
- E = 4.911 + 0.969 * S
- ES = 2.796 + 0.952 * S
- CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * B = X * BBAR :
- SF = 1.351
- AL = 1.016
- BE = 0.338
- AK = 1.961 - 0.370 * S
- BK = 0.923 + 0.119 * S
- AG = 0.815 + 0.207 * S
- BG = -2.275
- C = 1.480
- D = -0.223 + 0.173 * S
- E = 5.426 + 0.623 * S
- ES = 3.819 + 0.901 * S
- BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-
- END
-
-CDECK ID>, PHO_DORGHO
- SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.3
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- SS = SQRT (S)
- S2 = S * S
-C...X * U = X * UBAR :
- AL = 0.583
- BE = 0.688
- AK = 0.449 - 0.025 * S - 0.071 * S2
- BK = 5.060 - 1.116 * SS
- AG = 0.103
- BG = 0.319 + 0.422 * S
- C = 1.508 + 4.792 * S - 1.963 * S2
- D = 1.075 + 0.222 * SS - 0.193 * S2
- E = 4.147 + 1.131 * S
- ES = 1.661 + 0.874 * S
- UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * D = X * DBAR :
- AL = 0.591
- BE = 0.698
- AK = 0.442 - 0.132 * S - 0.058 * S2
- BK = 5.437 - 1.916 * SS
- AG = 0.099
- BG = 0.311 - 0.059 * S
- C = 0.800 + 0.078 * S - 0.100 * S2
- D = 0.862 + 0.294 * SS - 0.184 * S2
- E = 4.202 + 1.352 * S
- ES = 1.841 + 0.990 * S
- DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * G :
- AL = 1.161
- BE = 1.591
- AK = 0.530 - 0.742 * SS + 0.025 * S2
- BK = 5.662
- AG = 0.533 - 0.281 * SS + 0.218 * S2
- BG = 0.025 - 0.518 * S + 0.156 * S2
- C = -0.282 + 0.209 * S2
- D = 0.107 + 1.058 * S - 0.218 * S2
- E = 0.0 + 2.704 * S
- ES = 3.071 - 0.378 * S
- GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * S = X * SBAR :
- SF = 0.0
- AL = 0.635
- BE = 0.456
- AK = 1.770 - 0.735 * SS - 0.079 * S2
- BK = 3.832
- AG = 0.084 - 0.023 * S
- BG = 0.136
- C = 2.119 - 0.942 * S + 0.063 * S2
- D = 1.271 + 0.076 * S - 0.190 * S2
- E = 4.604 + 0.737 * S
- ES = 1.641 + 0.976 * S
- SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * C = X * CBAR :
- SF = 0.820
- AL = 0.926
- BE = 0.152
- AK = 1.142 - 0.175 * S
- BK = 3.276
- AG = 0.504 + 0.317 * S
- BG = -0.433
- C = 3.334
- D = 0.398 + 0.326 * S - 0.107 * S2
- E = 5.493 + 0.408 * S
- ES = 2.426 + 1.277 * S
- CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * B = X * BBAR :
- SF = 1.297
- AL = 0.969
- BE = 0.266
- AK = 1.953 - 0.391 * S
- BK = 1.657 - 0.161 * S
- AG = 1.076 + 0.034 * S
- BG = -2.015
- C = 1.662
- D = 0.353 + 0.016 * S
- E = 5.713 + 0.249 * S
- ES = 3.456 + 0.673 * S
- BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-
- END
-
-CDECK ID>, PHO_DORGH0
- SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- MU2 = 0.3
- LAM2 = 0.248 * 0.248
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- SS = SQRT (S)
- S2 = S * S
-C...X * U = X * UBAR :
- AL = 1.447
- BE = 0.848
- AK = 0.527 + 0.200 * S - 0.107 * S2
- BK = 7.106 - 0.310 * SS - 0.786 * S2
- AG = 0.197 + 0.533 * S
- BG = 0.062 - 0.398 * S + 0.109 * S2
- C = 0.755 * S - 0.112 * S2
- D = 0.318 - 0.059 * S
- E = 4.225 + 1.708 * S
- ES = 1.752 + 0.866 * S
- U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * D = X * DBAR :
- AL = 1.424
- BE = 0.770
- AK = 0.500 + 0.067 * SS - 0.055 * S2
- BK = 0.376 - 0.453 * SS + 0.405 * S2
- AG = 0.156 + 0.184 * S
- BG = 0.0 - 0.528 * S + 0.146 * S2
- C = 0.121 + 0.092 * S
- D = 0.379 - 0.301 * S + 0.081 * S2
- E = 4.346 + 1.638 * S
- ES = 1.645 + 1.016 * S
- D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * G :
- AL = 0.661
- BE = 0.793
- AK = 0.537 - 0.600 * SS
- BK = 6.389 - 0.953 * S2
- AG = 0.558 - 0.383 * SS + 0.261 * S2
- BG = 0.0 - 0.305 * S
- C = -0.222 + 0.078 * S2
- D = 0.153 + 0.978 * S - 0.209 * S2
- E = 1.429 + 1.772 * S
- ES = 3.331 + 0.806 * S
- G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * S = X * SBAR :
- SF = 0.0
- AL = 1.578
- BE = 0.863
- AK = 0.622 + 0.332 * S - 0.300 * S2
- BK = 2.469
- AG = 0.211 - 0.064 * SS - 0.018 * S2
- BG = -0.215 + 0.122 * S
- C = 0.153
- D = 0.0 + 0.253 * S - 0.081 * S2
- E = 3.990 + 2.014 * S
- ES = 1.720 + 0.986 * S
- S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * C = X * CBAR :
- SF = 0.820
- AL = 0.929
- BE = 0.381
- AK = 1.228 - 0.231 * S
- BK = 3.806 - 0.337 * S2
- AG = 0.932 + 0.150 * S
- BG = -0.906
- C = 1.133
- D = 0.0 + 0.138 * S - 0.028 * S2
- E = 5.588 + 0.628 * S
- ES = 2.665 + 1.054 * S
- C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-C...X * B = X * BBAR :
- SF = 1.297
- AL = 0.970
- BE = 0.207
- AK = 1.719 - 0.292 * S
- BK = 0.928 + 0.096 * S
- AG = 0.845 + 0.178 * S
- BG = -2.310
- C = 1.558
- D = -0.191 + 0.151 * S
- E = 6.089 + 0.282 * S
- ES = 3.379 + 1.062 * S
- B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
-
- END
-
-CDECK ID>, PHO_DORGF
- DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
- & AG,BG,C,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- SX = SQRT (X)
- LX = LOG (1./X)
- PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
- 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
-
- END
-
-CDECK ID>, PHO_DORGFS
- DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
- & C,D,E,ES)
- IMPLICIT DOUBLE PRECISION (A - Z)
- SAVE
-
- IF (S .LE. SF) THEN
- PHO_DORGFS = 0.0
- ELSE
- SX = SQRT (X)
- LX = LOG (1./X)
- DS = S - SF
- PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
- 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
- END IF
-
- END
-
-CDECK ID>, PHO_DORGLV
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-* *
-* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
-* *
-* FOR A DETAILED EXPLANATION SEE *
-* M. GLUECK, E.REYA, M. STRATMANN : *
-* PHYS. REV. D51 (1995) 3220 *
-* *
-* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
-* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
-* AND (!) Q**2 > 5 P**2 *
-* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
-* P**2 = 0 <=> REAL PHOTON *
-* X BETWEEN 1.E-4 AND 1. *
-* *
-* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
-* M(C) = 1.5, M(B) = 4.5 *
-* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
-* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
-* LAMBDA(5) = 0.153, *
-* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
-* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
-* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
-* *
-* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
-* Marco.Stratmann@durham.ac.uk *
-* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-*
-*...INPUT PARAMETERS :
-*
-* X = MOMENTUM FRACTION
-* Q2 = SCALE Q**2 IN GEV**2
-* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
-*
-*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
-*
-********************************************************
-* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
- subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
- implicit double precision (a-z)
- save
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- integer check
-c
-c check limits :
-c
- check=0
- if(x.lt.0.0001d0) check=1
- if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
- if(q2.lt.5.d0*p2) check=1
-c
-c calculate distributions
-c
- if(check.eq.0) then
- call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
- else
- WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
- WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
- endif
-
- end
-
-CDECK ID>, PHO_grscalc
- subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
- implicit double precision (a-z)
- save
-
- dimension u1(40),ds1(40),g1(40)
- dimension ud2(20),s2(20),g2(20)
- dimension up0(20),dsp0(20),gp0(20)
- save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
-c
- data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
- & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
- & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
- & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
- & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
- & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
- & 0.622d0,0.227d0,-0.184d0/
- data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
- & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
- & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
- & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
- & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
- & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
- & 0.245d0,-0.171d0/
- data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
- & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
- & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
- & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
- & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
- & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
- data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
- & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
- & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
- & -0.614d0,3.548d0/
- data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
- & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
- & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
- & -0.48d0,3.401d0/
- data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
- & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
- & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
- & -0.079d0/
- data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
- & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
- & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
- & 2.294d0/
- data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
- & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
- & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
- & 0.814d0,1.531d0,0.124d0/
- data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
- & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
- & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
- & 2.264d0,0.2675d0/
-c
- mu2=0.25d0
- lam2=0.232d0*0.232d0
-c
- if(p2.le.0.25d0) then
- s=log(log(q2/lam2)/log(mu2/lam2))
- lp1=0.d0
- lp2=0.d0
- else
- s=log(log(q2/lam2)/log(p2/lam2))
- lp1=log(p2/mu2)*log(p2/mu2)
- lp2=log(p2/mu2+log(p2/mu2))
- endif
-c
- alp=up0(1)+lp1*u1(1)+lp2*u1(2)
- bet=up0(2)+lp1*u1(3)+lp2*u1(4)
- a=up0(3)+lp1*u1(5)+lp2*u1(6)+
- & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
- b=up0(5)+lp1*u1(9)+lp2*u1(10)+
- & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
- & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
- gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
- & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
- & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
- ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
- & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
- gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
- & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
- gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
- & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
- ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
- & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
- gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
- & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
- upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
- bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
- a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
- & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
- b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
- & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
- & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
- gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
- & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
- & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
- ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
- & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
- gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
- & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
- gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
- & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
- ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
- & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
- gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
- & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
- dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
- bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
- a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
- & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
- b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
- & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
- gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
- & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
- ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
- & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
- & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
- gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
- & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
- gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
- & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
- & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
- ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
- & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
- gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
- & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
- gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- s=log(log(q2/lam2)/log(mu2/lam2))
- suppr=1.d0/(1.d0+p2/0.59d0)**2
-c
- alp=ud2(1)
- bet=ud2(2)
- a=ud2(3)+ud2(4)*s
- ga=ud2(5)+ud2(6)*s**0.5
- gc=ud2(7)+ud2(8)*s
- b=ud2(9)+ud2(10)*s+ud2(11)*s**2
- gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
- gd=ud2(15)+ud2(16)*s
- ge=ud2(17)+ud2(18)*s
- gep=ud2(19)+ud2(20)*s
- udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- alp=s2(1)
- bet=s2(2)
- a=s2(3)+s2(4)*s
- ga=s2(5)+s2(6)*s**0.5
- gc=s2(7)+s2(8)*s
- b=s2(9)+s2(10)*s+s2(11)*s**2
- gb=s2(12)+s2(13)*s+s2(14)*s**2
- gd=s2(15)+s2(16)*s
- ge=s2(17)+s2(18)*s
- gep=s2(19)+s2(20)*s
- spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- alp=g2(1)
- bet=g2(2)
- a=g2(3)+g2(4)*s**0.5
- b=g2(5)+g2(6)*s**2
- gb=g2(7)+g2(8)*s
- ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
- gc=g2(12)+g2(13)*s**2
- gd=g2(14)+g2(15)*s+g2(16)*s**2
- ge=g2(17)+g2(18)*s
- gep=g2(19)+g2(20)*s
- gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
-c
- ugam=upart1+udpart2
- dgam=dspart1+udpart2
- sgam=dspart1+spart2
- ggam=gpart1+gpart2
-c
- end
-
-CDECK ID>, PHO_grsf1
- DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
- & ge,gep)
- implicit double precision (a-z)
- save
-
- PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
- & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
- & (1.d0-x)**gd
-
- end
-
-CDECK ID>, PHO_grsf2
- DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
- & ge,gep)
- implicit double precision (a-z)
- save
-
- PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
- & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
- & (1.d0-x)**gd
-
- end
-
-CDECK ID>, PHO_CKMTPA
- SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
-C**********************************************************************
-C
-C PDF based on Regge theory, evolved with .... by ....
-C
-C input: IPAR 2212 proton (not installed)
-C 990 Pomeron
-C
-C output: parameters of parametrization
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- CHARACTER*8 PDFNA
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- REAL PROP(40),POMP(40)
- DATA PROP /
- & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
- & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
- & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
- DATA POMP /
- & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
- & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
- & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
-
- IF(IPA.EQ.2212) THEN
- ALA =PROP(1)
- Q2MI = PROP(39)
- Q2MA = PROP(40)
- PDFNA = 'CKMT-PRO'
- ELSE IF(IPA.EQ.990) THEN
- ALA = POMP(1)
- Q2MI = POMP(39)
- Q2MA = POMP(40)
- PDFNA = 'CKMT-POM'
- ELSE
- WRITE(LO,'(1X,A,I7)')
- & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
- STOP
- ENDIF
- XMI = 1.D-4
- XMA = 1.D0
- END
-
-CDECK ID>, PHO_CKMTPD
- SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
-C**********************************************************************
-C
-C PDF based on Regge theory, evolved with .... by ....
-C
-C input: IPAR 2212 proton (not installed)
-C 990 Pomeron
-C
-C output: PD(-6:6) x*f(x) parton distribution functions
-C (PDFLIB convention: d = PD(1), u = PD(2) )
-C
-C**********************************************************************
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
- DIMENSION QQ(7)
-
- Q2=SNGL(SCALE2)
- Q1S=Q2
- XX=SNGL(X)
-C QCD lambda for evolution
- OWLAM = 0.23D0
- OWLAM2=OWLAM**2
-C Q0**2 for evolution
- Q02 = 2.D0
-C
-C
-C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
-C q(6)=x*charm, q(7)=x*gluon
-C
- SB=0.
- IF(Q2-Q02) 1,1,2
- 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
- 1 CONTINUE
- IF(IPAR.EQ.2212) THEN
-* CALL PHO_CKMTPR(XX,SB,QQ
- WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
- CALL PHO_ABORT
- ELSE
- CALL PHO_CKMTPO(XX,SB,QQ)
- ENDIF
-C
- PD(-6) = 0.D0
- PD(-5) = 0.D0
- PD(-4) = DBLE(QQ(6))
- PD(-3) = DBLE(QQ(3))
- PD(-2) = DBLE(QQ(4))
- PD(-1) = DBLE(QQ(5))
- PD(0) = DBLE(QQ(7))
- PD(1) = DBLE(QQ(2))
- PD(2) = DBLE(QQ(1))
- PD(3) = DBLE(QQ(3))
- PD(4) = DBLE(QQ(6))
- PD(5) = 0.D0
- PD(6) = 0.D0
- IF(IPAR.EQ.990) THEN
- CDN = (PD(1)-PD(-1))/2.D0
- CUP = (PD(2)-PD(-2))/2.D0
- PD(-1) = PD(-1) + CDN
- PD(-2) = PD(-2) + CUP
- PD(1) = PD(-1)
- PD(2) = PD(-2)
- ENDIF
- END
-
-CDECK ID>, PHO_CKMTPO
- SUBROUTINE PHO_CKMTPO(X,S,QQ)
-C**********************************************************************
-C
-C calculation partons in Pomeron
-C
-C**********************************************************************
- SAVE
-
- DIMENSION QQ(7)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
- EQUIVALENCE (GF(1,1,1),DL(1))
- DATA DELTA/.10/
-
-C RNG= -.5
-C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
-C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
- DATA (DL(K),K= 1, 85) /
- & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
- & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
- & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
- & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
- & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
- & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
- & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
- & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
- & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
- & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
- & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
- & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
- & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
- & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
- & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
- & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
- & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
- DATA (DL(K),K= 86, 170) /
- & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
- & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
- & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
- & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
- & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
- & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
- & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
- & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
- & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
- & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
- & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
- & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
- DATA (DL(K),K= 171, 255) /
- & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
- & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
- & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
- & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
- & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
- & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
- & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
- & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
- & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
- & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
- & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
- & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
- & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
- & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
- & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
- & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
- & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
- DATA (DL(K),K= 256, 340) /
- & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
- & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
- & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
- & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
- & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
- & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
- & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
- & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
- & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
- & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
- & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
- & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
- DATA (DL(K),K= 341, 425) /
- & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
- & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
- & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
- & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
- & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
- & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
- & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
- & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
- & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
- & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
- & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
- & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
- & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
- & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
- & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
- & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
- & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
- DATA (DL(K),K= 426, 510) /
- & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
- & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
- & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
- & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
- & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
- & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
- & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
- & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
- & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
- & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
- & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
- & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
- DATA (DL(K),K= 511, 595) /
- & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
- & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
- & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
- & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
- & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
- & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
- & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
- & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
- & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
- & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
- & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
- & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
- & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
- & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
- & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
- & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
- & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
- DATA (DL(K),K= 596, 680) /
- & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
- & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
- & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
- & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
- & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
- & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
- & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
- & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
- & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
- & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
- & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
- & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
- DATA (DL(K),K= 681, 765) /
- & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
- & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
- & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
- & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
- & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
- & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
- & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
- & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
- & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
- & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
- & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
- & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
- & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
- & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
- & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
- & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
- & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
- DATA (DL(K),K= 766, 850) /
- & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
- & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
- & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
- & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
- & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
- & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
- & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
- & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
- & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
- & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
- & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
- & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
- DATA (DL(K),K= 851, 935) /
- & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
- & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
- & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
- & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
- & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
- & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
- & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
- & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
- & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
- & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
- & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
- & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
- & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
- & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
- & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
- & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
- & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
- DATA (DL(K),K= 936, 1020) /
- & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
- & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
- & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
- & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
- & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
- & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
- & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
- & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
- & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
- & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
- & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
- & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
- DATA (DL(K),K= 1021, 1105) /
- & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
- & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
- & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
- & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
- & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
- & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
- & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
- & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
- & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
- & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
- & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
- & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
- & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
- & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
- & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
- & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 1106, 1190) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
- & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
- & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
- & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
- & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
- & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
- & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
- & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
- & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
- & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
- & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
- & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
- & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
- & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
- DATA (DL(K),K= 1191, 1275) /
- & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
- & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
- & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
- & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
- & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
- & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
- & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
- & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
- & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
- & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
- & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
- & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
- & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
- & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 1276, 1360) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
- & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
- & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
- & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
- & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
- & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
- & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
- & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
- & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
- & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
- & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
- & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
- & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
- & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
- & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
- & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
- DATA (DL(K),K= 1361, 1445) /
- & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
- & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
- & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
- & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
- & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
- & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
- & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
- & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
- & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
- & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
- & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
- & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
- DATA (DL(K),K= 1446, 1530) /
- & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
- & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
- & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
- & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
- & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
- & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
- & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
- & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
- & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
- & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
- & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
- & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
- & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
- & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
- & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
- & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
- & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
- DATA (DL(K),K= 1531, 1615) /
- & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
- & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
- & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
- & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
- & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
- & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
- & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
- & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
- & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
- & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
- & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
- & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
- DATA (DL(K),K= 1616, 1700) /
- & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
- & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
- & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
- & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
- & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
- & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
- & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
- & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
- & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
- & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
- & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
- & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
- & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
- & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
- & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
- & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
- & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
- DATA (DL(K),K= 1701, 1785) /
- & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
- & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
- & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
- & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
- & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
- & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
- & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
- & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
- & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
- & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
- & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
- & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
- DATA (DL(K),K= 1786, 1870) /
- & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
- & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
- & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
- & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
- & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
- & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
- & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
- & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
- & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
- & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
- & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
- & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
- & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
- & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
- & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
- & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
- & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
- DATA (DL(K),K= 1871, 1955) /
- & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
- & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
- & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
- & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
- & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
- & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
- & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
- & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
- & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
- & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
- & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
- & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
- DATA (DL(K),K= 1956, 2040) /
- & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
- & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
- & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
- & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
- & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
- & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
- & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
- & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
- & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
- & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
- & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
- & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
- & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
- & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
- & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
- & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
- & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
- DATA (DL(K),K= 2041, 2125) /
- & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
- & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
- & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
- & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
- & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
- & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
- & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
- & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
- & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
- & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
- & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
- & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
- DATA (DL(K),K= 2126, 2210) /
- & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
- & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
- & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
- & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
- & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
- & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
- & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
- & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
- & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
- & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
- & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
- & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
- & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
- & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
- & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
- & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
- & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
- DATA (DL(K),K= 2211, 2295) /
- & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
- & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
- & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
- & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
- & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
- & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
- & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
- & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
- & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
- & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
- & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
- & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
- DATA (DL(K),K= 2296, 2380) /
- & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
- & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
- & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
- & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
- & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
- & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
- & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
- & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
- & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
- & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
- & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
- & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
- & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
- & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
- & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
- & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
- & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 2381, 2465) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
- & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
- & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
- & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
- & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
- & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
- & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
- & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
- & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
- & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
- & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
- & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
- & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
- DATA (DL(K),K= 2466, 2550) /
- & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
- & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
- & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
- & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
- & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
- & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
- & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
- & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
- & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
- & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
- & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
- & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
- & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
- & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
- & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 2551, 2635) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
- & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
- & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
- & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
- & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
- & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
- & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
- & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
- & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
- & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
- & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
- & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
- & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
- & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
- & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
- DATA (DL(K),K= 2636, 2720) /
- & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
- & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
- & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
- & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
- & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
- & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
- & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
- & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
- & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
- & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
- & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
- & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
- & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 2721, 2805) /
- & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
- & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
- & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
- & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
- & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
- & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
- & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
- & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
- & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
- & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
- & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
- & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
- & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
- & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
- & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
- & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
- & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
- DATA (DL(K),K= 2806, 2890) /
- & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
- & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
- & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
- & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
- & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
- & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
- & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
- & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
- & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
- & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
- & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
- & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
- DATA (DL(K),K= 2891, 2975) /
- & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
- & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
- & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
- & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
- & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
- & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
- & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
- & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
- & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
- & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
- & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
- & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
- & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
- & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
- & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
- & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
- & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
- DATA (DL(K),K= 2976, 3060) /
- & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
- & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
- & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
- & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
- & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
- & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
- & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
- & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
- & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
- & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
- & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
- & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
- DATA (DL(K),K= 3061, 3145) /
- & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
- & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
- & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
- & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
- & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
- & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
- & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
- & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
- & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
- & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
- & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
- & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
- & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
- & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
- & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
- & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
- & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
- DATA (DL(K),K= 3146, 3230) /
- & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
- & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
- & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
- & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
- & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
- & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
- & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
- & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
- & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
- & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
- & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
- & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
- DATA (DL(K),K= 3231, 3315) /
- & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
- & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
- & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
- & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
- & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
- & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
- & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
- & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
- & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
- & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
- & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
- & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
- & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
- & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
- & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
- & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
- & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
- DATA (DL(K),K= 3316, 3400) /
- & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
- & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
- & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
- & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
- & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
- & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
- & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
- & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
- & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
- & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
- & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
- & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
- DATA (DL(K),K= 3401, 3485) /
- & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
- & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
- & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
- & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
- & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
- & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
- & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
- & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
- & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
- & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
- & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
- & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
- & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
- & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
- & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
- & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
- & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
- DATA (DL(K),K= 3486, 3570) /
- & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
- & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
- & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
- & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
- & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
- & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
- & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
- & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
- & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
- & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
- & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
- & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
- DATA (DL(K),K= 3571, 3655) /
- & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
- & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
- & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
- & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
- & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
- & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
- & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
- & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
- & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
- & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
- & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
- & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
- & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
- & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
- & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
- & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
- & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
- DATA (DL(K),K= 3656, 3740) /
- & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
- & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
- & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
- & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
- & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
- & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
- & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
- & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
- & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
- & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
- & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
- & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
- DATA (DL(K),K= 3741, 3825) /
- & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
- & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
- & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
- & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
- & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
- & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
- & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
- & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
- & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
- & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
- & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
- & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
- & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
- & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
- & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
- & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 3826, 3910) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
- & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
- & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
- & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
- & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
- & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
- & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
- & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
- & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
- & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
- & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
- & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
- & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
- & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
- DATA (DL(K),K= 3911, 3995) /
- & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
- & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
- & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
- & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
- & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
- & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
- & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
- & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
- & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
- & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
- & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
- & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
- & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
- & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
- DATA (DL(K),K= 3996, 4000) /
- & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
-
- DO 10 I=1,7
- QQ(I) = 0.
- 10 CONTINUE
- IF(X.GT.0.9985) RETURN
-
- IS = S/DELTA+1
- IS = MIN(IS,19)
- IS1 = IS+1
- DO 20 I=1,7
- IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
- IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
- DO 30 L=1,25
- F1(L)=GF(I,IS,L)
- F2(L)=GF(I,IS1,L)
- 30 CONTINUE
- S1=(IS-1)*DELTA
- S2=S1+DELTA
- A1 = PHO_CKMTFV(X,F1)
- A2 = PHO_CKMTFV(X,F2)
- QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
- 19 CONTINUE
- 20 CONTINUE
-
- END
-
-CDECK ID>, PHO_CKMTFV
- REAL FUNCTION PHO_CKMTFV(X,FVL)
-C**********************************************************************
-C
-C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
-C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
-C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
-C IN MAIN ROUTINE.
-C
-C**********************************************************************
- SAVE
-
- DIMENSION FVL(25),XGRID(25)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
- *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
-
- PHO_CKMTFV=0.
- DO 1 I=1,NX
- IF(X.LT.XGRID(I)) GO TO 2
- 1 CONTINUE
- 2 I=I-1
- IF(I.EQ.0) THEN
- I=I+1
- ELSE IF(I.GT.23) THEN
- I=23
- ENDIF
- J=I+1
- K=J+1
- AXI=LOG(XGRID(I))
- BXI=LOG(1.-XGRID(I))
- AXJ=LOG(XGRID(J))
- BXJ=LOG(1.-XGRID(J))
- AXK=LOG(XGRID(K))
- BXK=LOG(1.-XGRID(K))
- FI=LOG(ABS(FVL(I)) +1.E-15)
- FJ=LOG(ABS(FVL(J)) +1.E-16)
- FK=LOG(ABS(FVL(K)) +1.E-17)
- DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
- ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
- $ BXI))/DET
- ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
- BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
- IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
- 1RETURN
-C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
-C WRITE(LO,2001) X,FVL
-C 2001 FORMAT(8E12.4)
-C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
-C ENDIF
- PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
-
- END
-
-CDECK ID>, PHO_SASGAM
-C***********************************************************************
-C...SaSgam version 2 - parton distributions of the photon
-C...by Gerhard A. Schuler and Torbjorn Sjostrand
-C...For further information see Z. Phys. C68 (1995) 607
-C...and Phys. Lett. B376 (1996) 193.
-
-C...18 January 1996: original code.
-C...22 July 1996: calculation of BETA moved in SASBEH.
-
-C!!!Note that one further call parameter - IP2 - has been added
-C!!!to the SASGAM argument list compared with version 1.
-
-C...The user should only need to call the SASGAM routine,
-C...which in turn calls the auxiliary routines SASVMD, SASANO,
-C...SASBEH and SASDIR. The package is self-contained.
-
-C...One particular aspect of these parametrizations is that F2 for
-C...the photon is not obtained just as the charge-squared-weighted
-C...sum of quark distributions, but differ in the treatment of
-C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
-C...the kinematics range of heavy-flavour production, but the same
-C...kinematics is not relevant e.g. for jet production) and, for the
-C...'MSbar' fits, in the addition of a Cgamma term related to the
-C...separation of direct processes. Schematically:
-C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
-C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
-C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
-C...The J/psi and Upsilon states have not been included in the VMD sum,
-C...but low c and b masses in the other components should compensate
-C...for this in a duality sense.
-
-C...The calling sequence is the following:
-C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
-C...with the following declaration statement:
-C DIMENSION XPDFGM(-6:6)
-C...and, optionally, further information in:
-C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
-C &XPDIR(-6:6)
-C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
-C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
-C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
-C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
-C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
-C X : x value.
-C Q2 : Q2 value.
-C P2 : P2 value; should be = 0. for an on-shell photon.
-C IP2 : scheme used to evaluate off-shell anomalous component.
-C = 0 : recommended default, see = 7.
-C = 1 : dipole dampening by integration; very time-consuming.
-C = 2 : P_0^2 = max( Q_0^2, P^2 )
-C = 3 : P_0^2 = Q_0^2 + P^2.
-C = 4 : P_{eff} that preserves momentum sum.
-C = 5 : P_{int} that preserves momentum and average
-C evolution range.
-C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
-C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
-C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
-C XPFDGM : x times parton distribution functions of the photon,
-C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
-C 6 = t (always empty!), - for antiquarks (result is same).
-C...The breakdown by component is stored in the commonblock SASCOM,
-C with elements as above.
-C XPVMD : rho, omega, phi VMD part only of output.
-C XPANL : d, u, s anomalous part only of output.
-C XPANH : c, b anomalous part only of output.
-C XPBEH : c, b Bethe-Heitler part only of output.
-C XPDIR : Cgamma (direct contribution) part only of output.
-C...The above arrays do not distinguish valence and sea contributions,
-C...although this information is available internally. The additional
-C...commonblock SASVAL provides the valence part only of the above
-C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
-C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
-C...and therefore not given doubly. VXPDGM gives the sum of valence
-C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
-C...and so on, gives the sea part only.
-C***********************************************************************
-
- SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
-C...Purpose: to construct the F2 and parton distributions of the photon
-C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
-C...For F2, c and b are included by the Bethe-Heitler formula;
-C...in the 'MSbar' scheme additionally a Cgamma term is added.
- SAVE
- DIMENSION XPDFGM(-6:6)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
- &XPDIR(-6:6)
- COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
- SAVE /SASCOM/,/SASVAL/
-
-C...Temporary array.
- DIMENSION XPGA(-6:6), VXPGA(-6:6)
-C...Charm and bottom masses (low to compensate for J/psi etc.).
- DATA PMC/1.3/, PMB/4.6/
-C...alpha_em and alpha_em/(2*pi).
- DATA AEM/0.007297/, AEM2PI/0.0011614/
-C...Lambda value for 4 flavours.
- DATA ALAM/0.20/
-C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
- DATA FRACU/0.8/
-C...VMD couplings f_V**2/(4*pi).
- DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
-C...Masses for rho (=omega) and phi.
- DATA PMRHO/0.770/, PMPHI/1.020/
-C...Number of points in integration for IP2=1.
- DATA NSTEP/100/
-
-C...Reset output.
- F2GM=0.
- DO 100 KFL=-6,6
- XPDFGM(KFL)=0.
- XPVMD(KFL)=0.
- XPANL(KFL)=0.
- XPANH(KFL)=0.
- XPBEH(KFL)=0.
- XPDIR(KFL)=0.
- VXPVMD(KFL)=0.
- VXPANL(KFL)=0.
- VXPANH(KFL)=0.
- VXPDGM(KFL)=0.
- 100 CONTINUE
-
-C...Check that input sensible.
- IF(ISET.LE.0.OR.ISET.GE.5) THEN
- WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
- WRITE(LO,*) ' ISET = ',ISET
- STOP
- ENDIF
- IF(X.LE.0..OR.X.GT.1.) THEN
- WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
- WRITE(LO,*) ' X = ',X
- STOP
- ENDIF
-
-C...Set Q0 cut-off parameter as function of set used.
- IF(ISET.LE.2) THEN
- Q0=0.6
- ELSE
- Q0=2.
- ENDIF
- Q02=Q0**2
-
-C...Scale choice for off-shell photon; common factors.
- Q2A=Q2
- FACNOR=1.
- IF(IP2.EQ.1) THEN
- P2MX=P2+Q02
- Q2A=Q2+P2*Q02/MAX(Q02,Q2)
- FACNOR=LOG(Q2/Q02)/NSTEP
- ELSEIF(IP2.EQ.2) THEN
- P2MX=MAX(P2,Q02)
- ELSEIF(IP2.EQ.3) THEN
- P2MX=P2+Q02
- Q2A=Q2+P2*Q02/MAX(Q02,Q2)
- ELSEIF(IP2.EQ.4) THEN
- P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- ELSEIF(IP2.EQ.5) THEN
- P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=Q0*SQRT(P2MXA)
- FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
- ELSEIF(IP2.EQ.6) THEN
- P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
- ELSE
- P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=Q0*SQRT(P2MXA)
- P2MXB=P2MX
- P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
- P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
- FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
- ENDIF
-
-C...Call VMD parametrization for d quark and use to give rho, omega,
-C...phi. Note dipole dampening for off-shell photon.
- CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- XFVAL=VXPGA(1)
- XPGA(1)=XPGA(2)
- XPGA(-1)=XPGA(-2)
- FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
- FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
- DO 110 KFL=-5,5
- XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
- 110 CONTINUE
- XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
- XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
- XPVMD(3)=XPVMD(3)+FACS*XFVAL
- XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
- XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
- XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
- VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
- VXPVMD(2)=FRACU*FACUD*XFVAL
- VXPVMD(3)=FACS*XFVAL
- VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
- VXPVMD(-2)=FRACU*FACUD*XFVAL
- VXPVMD(-3)=FACS*XFVAL
-
- IF(IP2.NE.1) THEN
-C...Anomalous parametrizations for different strategies
-C...for off-shell photons; except full integration.
-
-C...Call anomalous parametrization for d + u + s.
- CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 120 KFL=-5,5
- XPANL(KFL)=FACNOR*XPGA(KFL)
- VXPANL(KFL)=FACNOR*VXPGA(KFL)
- 120 CONTINUE
-
-C...Call anomalous parametrization for c and b.
- CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 130 KFL=-5,5
- XPANH(KFL)=FACNOR*XPGA(KFL)
- VXPANH(KFL)=FACNOR*VXPGA(KFL)
- 130 CONTINUE
- CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 140 KFL=-5,5
- XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
- VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
- 140 CONTINUE
-
- ELSE
-C...Special option: loop over flavours and integrate over k2.
- DO 170 KF=1,5
- DO 160 ISTEP=1,NSTEP
- Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
- IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
- & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
- CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
- FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
- IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
- IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
- DO 150 KFL=-5,5
- IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
- IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
- IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
- IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
- ENDIF
-
-C...Call Bethe-Heitler term expression for charm and bottom.
- CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
- XPBEH(4)=XPBH
- XPBEH(-4)=XPBH
- CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
- XPBEH(5)=XPBH
- XPBEH(-5)=XPBH
-
-C...For MSbar subtraction call C^gamma term expression for d, u, s.
- IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
- CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
- DO 180 KFL=-5,5
- XPDIR(KFL)=XPGA(KFL)
- 180 CONTINUE
- ENDIF
-
-C...Store result in output array.
- DO 190 KFL=-5,5
- CHSQ=1./9.
- IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
- XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
- IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
- XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
- VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
- 190 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-CDECK ID>, PHO_SASVMD
- SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
-C...Purpose: to evaluate the VMD parton distributions of a photon,
-C...evolved homogeneously from an initial scale P2 to Q2.
-C...Does not include dipole suppression factor.
-C...ISET is parton distribution set, see above;
-C...additionally ISET=0 is used for the evolution of an anomalous photon
-C...which branched at a scale P2 and then evolved homogeneously to Q2.
-C...ALAM is the 4-flavour Lambda, which is automatically converted
-C...to 3- and 5-flavour equivalents as needed.
- SAVE
- DIMENSION XPGA(-6:6), VXPGA(-6:6)
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0.
- VXPGA(KFL)=0.
- 100 CONTINUE
- KFA=IABS(KF)
-
-C...Calculate Lambda; protect against unphysical Q2 and P2 input.
- ALAM3=ALAM*(PMC/ALAM)**(2./27.)
- ALAM5=ALAM*(ALAM/PMB)**(2./23.)
- P2EFF=MAX(P2,1.2*ALAM3**2)
- IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
- IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
-
-C...Find number of flavours at lower and upper scale.
- NFP=4
- IF(P2EFF.LT.PMC**2) NFP=3
- IF(P2EFF.GT.PMB**2) NFP=5
- NFQ=4
- IF(Q2EFF.LT.PMC**2) NFQ=3
- IF(Q2EFF.GT.PMB**2) NFQ=5
-
-C...Find s as sum of 3-, 4- and 5-flavour parts.
- S=0.
- IF(NFP.EQ.3) THEN
- Q2DIV=PMC**2
- IF(NFQ.EQ.3) Q2DIV=Q2EFF
- S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
- ENDIF
- IF(NFP.LE.4.AND.NFQ.GE.4) THEN
- P2DIV=P2EFF
- IF(NFP.EQ.3) P2DIV=PMC**2
- Q2DIV=Q2EFF
- IF(NFQ.EQ.5) Q2DIV=PMB**2
- S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
- ENDIF
- IF(NFQ.EQ.5) THEN
- P2DIV=PMB**2
- IF(NFP.EQ.5) P2DIV=P2EFF
- S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
- ENDIF
-
-C...Calculate frequent combinations of x and s.
- X1=1.-X
- XL=-LOG(X)
- S2=S**2
- S3=S**3
- S4=S**4
-
-C...Evaluate homogeneous anomalous parton distributions below or
-C...above threshold.
- IF(ISET.EQ.0) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = X * 1.5 * (X**2+X1**2)
- XGLU = 0.
- XSEA = 0.
- ELSE
- XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
- & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
- & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
- XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
- & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
- & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
- XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
- & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
- & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
- & (2.*X-1.)*X*XL**2)
- ENDIF
-
-C...Evaluate set 1D parton distributions below or above threshold.
- ELSEIF(ISET.EQ.1) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 1.294 * X**0.80 * X1**0.76
- XGLU = 1.273 * X**0.40 * X1**1.76
- XSEA = 0.100 * X1**3.76
- ELSE
- XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
- & X1**(0.76+0.667*S) * XL**(2.*S)
- XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
- & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
- & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
- XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
- & X**(-7.32*S2/(1.+10.3*S2)) *
- & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
- XSEA0 = 0.100 * X1**3.76
- ENDIF
-
-C...Evaluate set 1M parton distributions below or above threshold.
- ELSEIF(ISET.EQ.2) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 0.8477 * X**0.51 * X1**1.37
- XGLU = 3.42 * X**0.255 * X1**2.37
- XSEA = 0.
- ELSE
- XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
- & * X1**1.37 * XL**(2.667*S)
- XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
- & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
- & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
- & X1**(2.37+3.*S)
- XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
- & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
- & XL**(2.8*S)
- XSEA0 = 0.
- ENDIF
-
-C...Evaluate set 2D parton distributions below or above threshold.
- ELSEIF(ISET.EQ.3) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = X**0.46 * X1**0.64 + 0.76 * X
- XGLU = 1.925 * X1**2
- XSEA = 0.242 * X1**4
- ELSE
- XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
- & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
- & (0.76+0.4*S) * X * X1**(2.667*S)
- XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
- & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
- & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
- XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
- & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
- XSEA0 = 0.242 * X1**4
- ENDIF
-
-C...Evaluate set 2M parton distributions below or above threshold.
- ELSEIF(ISET.EQ.4) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
- XGLU = 1.808 * X1**2
- XSEA = 0.209 * X1**4
- ELSE
- XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
- & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
- & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
- & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
- XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
- & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
- & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
- & XL**(10.9*S/(1.+2.5*S))
- XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
- & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
- & X1**(4.+S) * XL**(0.45*S)
- XSEA0 = 0.209 * X1**4
- ENDIF
- ENDIF
-
-C...Threshold factors for c and b sea.
- SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
- XCHM=0.
- IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
- SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- IF(ISET.EQ.0) THEN
- XCHM=XSEA*(1.-(SCH/SLL)**2)
- ELSE
- XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
- ENDIF
- ENDIF
- XBOT=0.
- IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
- SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- IF(ISET.EQ.0) THEN
- XBOT=XSEA*(1.-(SBT/SLL)**2)
- ELSE
- XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
- ENDIF
- ENDIF
-
-C...Fill parton distributions.
- XPGA(0)=XGLU
- XPGA(1)=XSEA
- XPGA(2)=XSEA
- XPGA(3)=XSEA
- XPGA(4)=XCHM
- XPGA(5)=XBOT
- XPGA(KFA)=XPGA(KFA)+XVAL
- DO 110 KFL=1,5
- XPGA(-KFL)=XPGA(KFL)
- 110 CONTINUE
- VXPGA(KFA)=XVAL
- VXPGA(-KFA)=XVAL
-
- RETURN
- END
-
-C*********************************************************************
-
-CDECK ID>, PHO_SASANO
- SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
-C...Purpose: to evaluate the parton distributions of the anomalous
-C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
-C...to Q2.
-C...KF=0 gives the sum over (up to) 5 flavours,
-C...KF<0 limits to flavours up to abs(KF),
-C...KF>0 is for flavour KF only.
-C...ALAM is the 4-flavour Lambda, which is automatically converted
-C...to 3- and 5-flavour equivalents as needed.
- SAVE
-
-C input/output channels
- INTEGER LI,LO
- COMMON /POINOU/ LI,LO
-
- DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
- DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0.
- VXPGA(KFL)=0.
- 100 CONTINUE
- IF(Q2.LE.P2) RETURN
- KFA=IABS(KF)
-
-C...Calculate Lambda; protect against unphysical Q2 and P2 input.
- ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
- ALAMSQ(4)=ALAM**2
- ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
- P2EFF=MAX(P2,1.2*ALAMSQ(3))
- IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
- IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
- XL=-LOG(X)
-
-C...Find number of flavours at lower and upper scale.
- NFP=4
- IF(P2EFF.LT.PMC**2) NFP=3
- IF(P2EFF.GT.PMB**2) NFP=5
- NFQ=4
- IF(Q2EFF.LT.PMC**2) NFQ=3
- IF(Q2EFF.GT.PMB**2) NFQ=5
-
-C...Define range of flavour loop.
- IF(KF.EQ.0) THEN
- KFLMN=1
- KFLMX=5
- ELSEIF(KF.LT.0) THEN
- KFLMN=1
- KFLMX=KFA
- ELSE
- KFLMN=KFA
- KFLMX=KFA
- ENDIF
-
-C...Loop over flavours the photon can branch into.
- DO 110 KFL=KFLMN,KFLMX
-
-C...Light flavours: calculate t range and (approximate) s range.
- IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- IF(NFQ.GT.NFP) THEN
- Q2DIV=PMB**2
- IF(NFQ.EQ.4) Q2DIV=PMC**2
- SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
- & LOG(P2EFF/ALAMSQ(NFQ-1)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
- ENDIF
- IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
- Q2DIV=PMC**2
- SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
- & LOG(P2EFF/ALAMSQ(4)))
- SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
- & LOG(P2EFF/ALAMSQ(3)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
- ENDIF
-
-C...u and s quark do not need a separate treatment when d has been done.
- ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
-
-C...Charm: as above, but only include range above c threshold.
- ELSEIF(KFL.EQ.4) THEN
- IF(Q2.LE.PMC**2) GOTO 110
- P2EFF=MAX(P2EFF,PMC**2)
- Q2EFF=MAX(Q2EFF,P2EFF)
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
- Q2DIV=PMB**2
- SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
- & LOG(P2EFF/ALAMSQ(NFQ-1)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
- ENDIF
-
-C...Bottom: as above, but only include range above b threshold.
- ELSEIF(KFL.EQ.5) THEN
- IF(Q2.LE.PMB**2) GOTO 110
- P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- ENDIF
-
-C...Evaluate flavour-dependent prefactor (charge^2 etc.).
- CHSQ=1./9.
- IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
- FAC=AEM2PI*2.*CHSQ*TDIFF
-
-C...Evaluate parton distributions (normalized to unit momentum sum).
- IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
- XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
- & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
- & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
- & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
- XGLU= 2.*S/(1.+4.*S+7.*S**2) *
- & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
- & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
- XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
- & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
- & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
- & (2.*X-1.)*X*XL**2)
-
-C...Threshold factors for c and b sea.
- SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
- XCHM=0.
- IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
- SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- XCHM=XSEA*(1.-(SCH/SLL)**3)
- ENDIF
- XBOT=0.
- IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
- SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- XBOT=XSEA*(1.-(SBT/SLL)**3)
- ENDIF
- ENDIF
-
-C...Add contribution of each valence flavour.
- XPGA(0)=XPGA(0)+FAC*XGLU
- XPGA(1)=XPGA(1)+FAC*XSEA
- XPGA(2)=XPGA(2)+FAC*XSEA
- XPGA(3)=XPGA(3)+FAC*XSEA
- XPGA(4)=XPGA(4)+FAC*XCHM
- XPGA(5)=XPGA(5)+FAC*XBOT
- XPGA(KFL)=XPGA(KFL)+FAC*XVAL
- VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
- 110 CONTINUE
- DO 120 KFL=1,5
- XPGA(-KFL)=XPGA(KFL)
- VXPGA(-KFL)=VXPGA(KFL)
- 120 CONTINUE
-
- END
-
-C*********************************************************************
-
-CDECK ID>, PHO_SASBEH
- SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
-C...Purpose: to evaluate the Bethe-Heitler cross section for
-C...heavy flavour production.
- SAVE
- DATA AEM2PI/0.0011614/
-
-C...Reset output.
- XPBH=0.
- SIGBH=0.
-
-C...Check kinematics limits.
- IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
- W2=Q2*(1.-X)/X-P2
- BETA2=1.-4.*PM2/W2
- IF(BETA2.LT.1E-10) RETURN
- BETA=SQRT(BETA2)
- RMQ=4.*PM2/Q2
-
-C...Simple case: P2 = 0.
- IF(P2.LT.1E-4) THEN
- IF(BETA.LT.0.99) THEN
- XBL=LOG((1.+BETA)/(1.-BETA))
- ELSE
- XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
- ENDIF
- SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
- & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
-
-C...Complicated case: P2 > 0, based on approximation of
-C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
- ELSE
- RPQ=1.-4.*X**2*P2/Q2
- IF(RPQ.GT.1E-10) THEN
- RPBE=SQRT(RPQ*BETA2)
- IF(RPBE.LT.0.99) THEN
- XBL=LOG((1.+RPBE)/(1.-RPBE))
- XBI=2.*RPBE/(1.-RPBE**2)
- ELSE
- RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
- XBL=LOG((1.+RPBE)**2/RPBESN)
- XBI=2.*RPBE/RPBESN
- ENDIF
- SIGBH=BETA*(6.*X*(1.-X)-1.)+
- & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
- & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
- ENDIF
- ENDIF
-
-C...Multiply by charge-squared etc. to get parton distribution.
- CHSQ=1./9.
- IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
- XPBH=3.*CHSQ*AEM2PI*X*SIGBH
-
- END
-
-C*********************************************************************
-
-CDECK ID>, PHO_SASDIR
- SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
-C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
-C...as needed in MSbar parametrizations.
- SAVE
- DIMENSION XPGA(-6:6)
- DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0.
- 100 CONTINUE
-
-C...Evaluate common x-dependent expression.
- XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
- CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
-
-C...d, u, s part by simple charge factor.
- XPGA(1)=(1./9.)*CGAM
- XPGA(2)=(4./9.)*CGAM
- XPGA(3)=(1./9.)*CGAM
-
-C...Also fill for antiquarks.
- DO 110 KF=1,5
- XPGA(-KF)=XPGA(KF)
- 110 CONTINUE
-
- END
-
-CDECK ID>, PHO_PHGAL
- SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
-C***********************************************************************
-C
-C photon parton densities with built-in momentum sum rule and
-C Regge-based low-x behaviour
-C
-C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
-C e-Print Archive: hep-ph/9711355
-C
-C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION(A-H,O-Z)
- SAVE
-
- PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
- DOUBLE PRECISION
- & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
- & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
-
- DIMENSION NA(NARG)
-
- DATA ZEROD/0.D0/
-
-C...100 x values; in (D-4,.77) log spaced (78 points)
-C... in (.78,.995) lineary spaced (22 points)
- DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
- DATA XT/
- &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
- &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
- &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
- &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
- &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
- &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
- &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
- &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
- &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
- &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
- &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
- &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
- &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
- &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
- &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
- &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
- &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
-
-C...place for DATA blocks
- DATA (XPV(I,1,0),I=1,100)/
- &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
- &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
- &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
- &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
- &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
- &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
- &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
- &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
- &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
- &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
- &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
- &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
- &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
- &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
- &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
- &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
- &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
- DATA (XPV(I,1,1),I=1,100)/
- &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
- &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
- &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
- &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
- &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
- &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
- &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
- &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
- &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
- &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
- &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
- &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
- &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
- &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
- &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
- &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
- &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
- DATA (XPV(I,1,2),I=1,100)/
- &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
- &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
- &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
- &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
- &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
- &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
- &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
- &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
- &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
- &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
- &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
- &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
- &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
- &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
- &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
- &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
- &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
- DATA (XPV(I,1,3),I=1,100)/
- &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
- &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
- &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
- &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
- &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
- &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
- &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
- &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
- &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
- &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
- &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
- &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
- &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
- &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
- &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
- &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
- &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
- DATA (XPV(I,1,4),I=1,100)/
- &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
- &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
- &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
- &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
- &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
- &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
- &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
- &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
- &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
- &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
- &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
- &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
- &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
- &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
- &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
- &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
- &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
- DATA (XPV(I,2,0),I=1,100)/
- &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
- &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
- &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
- &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
- &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
- &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
- &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
- &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
- &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
- &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
- &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
- &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
- &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
- &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
- &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
- &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
- &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
- DATA (XPV(I,2,1),I=1,100)/
- &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
- &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
- &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
- &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
- &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
- &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
- &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
- &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
- &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
- &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
- &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
- &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
- &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
- &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
- &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
- &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
- &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
- DATA (XPV(I,2,2),I=1,100)/
- &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
- &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
- &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
- &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
- &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
- &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
- &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
- &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
- &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
- &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
- &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
- &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
- &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
- &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
- &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
- &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
- &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
- DATA (XPV(I,2,3),I=1,100)/
- &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
- &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
- &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
- &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
- &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
- &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
- &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
- &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
- &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
- &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
- &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
- &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
- &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
- &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
- &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
- &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
- &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
- DATA (XPV(I,2,4),I=1,100)/
- &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
- &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
- &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
- &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
- &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
- &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
- &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
- &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
- &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
- &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
- &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
- &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
- &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
- &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
- &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
- &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
- &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
- DATA (XPV(I,3,0),I=1,100)/
- &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
- &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
- &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
- &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
- &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
- &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
- &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
- &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
- &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
- &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
- &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
- &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
- &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
- &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
- &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
- &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
- &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
- DATA (XPV(I,3,1),I=1,100)/
- &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
- &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
- &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
- &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
- &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
- &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
- &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
- &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
- &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
- &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
- &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
- &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
- &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
- &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
- &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
- &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
- &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
- DATA (XPV(I,3,2),I=1,100)/
- &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
- &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
- &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
- &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
- &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
- &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
- &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
- &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
- &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
- &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
- &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
- &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
- &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
- &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
- &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
- &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
- &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
- DATA (XPV(I,3,3),I=1,100)/
- &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
- &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
- &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
- &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
- &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
- &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
- &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
- &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
- &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
- &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
- &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
- &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
- &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
- &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
- &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
- &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
- &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
- DATA (XPV(I,3,4),I=1,100)/
- &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
- &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
- &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
- &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
- &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
- &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
- &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
- &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
- &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
- &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
- &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
- &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
- &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
- &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
- &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
- &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
- &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
- DATA (XPV(I,4,0),I=1,100)/
- &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
- &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
- &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
- &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
- &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
- &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
- &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
- &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
- &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
- &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
- &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
- &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
- &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
- &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
- &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
- &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
- &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
- DATA (XPV(I,4,1),I=1,100)/
- &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
- &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
- &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
- &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
- &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
- &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
- &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
- &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
- &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
- &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
- &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
- &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
- &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
- &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
- &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
- &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
- &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
- DATA (XPV(I,4,2),I=1,100)/
- &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
- &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
- &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
- &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
- &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
- &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
- &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
- &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
- &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
- &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
- &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
- &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
- &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
- &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
- &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
- &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
- &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
- DATA (XPV(I,4,3),I=1,100)/
- &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
- &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
- &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
- &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
- &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
- &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
- &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
- &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
- &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
- &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
- &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
- &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
- &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
- &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
- &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
- &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
- &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
- DATA (XPV(I,4,4),I=1,100)/
- &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
- &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
- &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
- &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
- &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
- &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
- &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
- &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
- &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
- &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
- &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
- &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
- &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
- &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
- &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
- &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
- &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
- DATA (XPV(I,5,0),I=1,100)/
- &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
- &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
- &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
- &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
- &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
- &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
- &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
- &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
- &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
- &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
- &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
- &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
- &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
- &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
- &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
- &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
- &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
- DATA (XPV(I,5,1),I=1,100)/
- &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
- &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
- &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
- &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
- &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
- &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
- &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
- &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
- &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
- &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
- &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
- &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
- &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
- &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
- &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
- &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
- &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
- DATA (XPV(I,5,2),I=1,100)/
- &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
- &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
- &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
- &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
- &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
- &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
- &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
- &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
- &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
- &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
- &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
- &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
- &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
- &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
- &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
- &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
- &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
- DATA (XPV(I,5,3),I=1,100)/
- &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
- &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
- &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
- &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
- &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
- &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
- &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
- &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
- &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
- &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
- &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
- &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
- &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
- &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
- &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
- &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
- &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
- DATA (XPV(I,5,4),I=1,100)/
- &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
- &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
- &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
- &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
- &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
- &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
- &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
- &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
- &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
- &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
- &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
- &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
- &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
- &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
- &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
- &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
- &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
- DATA (XPV(I,6,0),I=1,100)/
- &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
- &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
- &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
- &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
- &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
- &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
- &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
- &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
- &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
- &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
- &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
- &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
- &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
- &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
- &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
- &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
- &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
- DATA (XPV(I,6,1),I=1,100)/
- &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
- &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
- &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
- &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
- &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
- &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
- &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
- &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
- &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
- &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
- &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
- &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
- &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
- &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
- &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
- &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
- &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
- DATA (XPV(I,6,2),I=1,100)/
- &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
- &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
- &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
- &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
- &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
- &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
- &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
- &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
- &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
- &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
- &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
- &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
- &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
- &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
- &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
- &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
- &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
- DATA (XPV(I,6,3),I=1,100)/
- &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
- &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
- &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
- &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
- &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
- &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
- &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
- &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
- &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
- &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
- &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
- &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
- &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
- &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
- &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
- &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
- &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
- DATA (XPV(I,6,4),I=1,100)/
- &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
- &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
- &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
- &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
- &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
- &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
- &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
- &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
- &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
- &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
- &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
- &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
- &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
- &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
- &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
- &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
- &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
- DATA (XPV(I,7,0),I=1,100)/
- &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
- &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
- &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
- &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
- &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
- &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
- &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
- &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
- &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
- &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
- &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
- &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
- &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
- &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
- &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
- &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
- &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
- DATA (XPV(I,7,1),I=1,100)/
- &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
- &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
- &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
- &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
- &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
- &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
- &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
- &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
- &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
- &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
- &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
- &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
- &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
- &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
- &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
- &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
- &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
- DATA (XPV(I,7,2),I=1,100)/
- &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
- &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
- &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
- &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
- &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
- &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
- &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
- &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
- &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
- &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
- &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
- &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
- &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
- &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
- &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
- &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
- &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
- DATA (XPV(I,7,3),I=1,100)/
- &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
- &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
- &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
- &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
- &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
- &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
- &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
- &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
- &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
- &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
- &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
- &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
- &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
- &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
- &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
- &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
- &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
- DATA (XPV(I,7,4),I=1,100)/
- &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
- &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
- &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
- &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
- &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
- &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
- &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
- &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
- &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
- &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
- &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
- &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
- &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
- &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
- &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
- &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
- &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
-
-C..fetching pdfs
- DO 5 IP=-6,6
- XPDF(IP)=ZEROD
- 5 CONTINUE
- DO 2 I=1,IX
- ENT(I)=LOG10(XT(I))
- 2 CONTINUE
- NA(1)=IX
- NA(2)=IQ
- DO 3 I=1,IQ
- ENT(IX+I)=LOG10(Q2T(I))
- 3 CONTINUE
- ARG(1)=LOG10(X)
- ARG(2)=LOG10(Q2)
-C..various flavours (u-->2,d-->1)
- XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
- XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
- XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
- XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
- XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
- DO 21 JF=1,4
- XPDF(-JF)=XPDF(JF)
- 21 CONTINUE
-
- END
-
-CDECK ID>, PHO_DBFINT
- DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
-C***********************************************************************
-C
-C routine based on CERN library E104
-C
-C multi-dimensional interpolation routine, needed for PHOJET
-C internal cross section tables and several PDF sets (GRV98 and AGL)
-C
-C changed to avoid recursive function calls (R.Engel, 09/98)
-C
-C***********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- INTEGER NA(NARG), INDEX(32)
- DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
-
- DATA ZEROD/0.D0/
- DATA ONED/1.D0/
-
- DBFINT = ZEROD
- PHO_DBFINT = ZEROD
- IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
-
- LMAX = 0
- ISTEP = 1
- KNOTS = 1
- INDEX(1) = 1
- WEIGHT(1) = ONED
- DO 100 N = 1, NARG
- X = ARG(N)
- NDIM = NA(N)
- LOCA = LMAX
- LMIN = LMAX + 1
- LMAX = LMAX + NDIM
- IF(NDIM .GT. 2) GOTO 10
- IF(NDIM .EQ. 1) GOTO 100
- H = X - ENT(LMIN)
- IF(H .EQ. ZEROD) GOTO 90
- ISHIFT = ISTEP
- IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
- ISHIFT = 0
- ETA = H / (ENT(LMIN+1) - ENT(LMIN))
- GOTO 30
- 10 LOCB = LMAX + 1
- 11 LOCC = (LOCA+LOCB) / 2
- IF(X-ENT(LOCC)) 12, 20, 13
- 12 LOCB = LOCC
- GOTO 14
- 13 LOCA = LOCC
- 14 IF(LOCB-LOCA .GT. 1) GOTO 11
- LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
- ISHIFT = (LOCA - LMIN) * ISTEP
- ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
- GOTO 30
- 20 ISHIFT = (LOCC - LMIN) * ISTEP
- 21 DO 22 K = 1, KNOTS
- INDEX(K) = INDEX(K) + ISHIFT
- 22 CONTINUE
- GOTO 90
- 30 DO 31 K = 1, KNOTS
- INDEX(K) = INDEX(K) + ISHIFT
- INDEX(K+KNOTS) = INDEX(K) + ISTEP
- WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
- WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
- 31 CONTINUE
- KNOTS = 2*KNOTS
- 90 ISTEP = ISTEP * NDIM
- 100 CONTINUE
- DO 200 K = 1, KNOTS
- I = INDEX(K)
- DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
- 200 CONTINUE
-
- PHO_DBFINT = DBFINT
-
- END
-
-CDECK ID>, PHVAL
- SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
-C**********************************************************************
-C
-C dummy subroutine, remove to link PHOLIB
-C
-C**********************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION PD(-6:6)
- END
git://git.uio.no / u / mrichter / AliRoot.git / blobdiff