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 *