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,)',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,,',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 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