1 C***********************************************************************
12 C Authors: Ralph Engel
13 C (eng@lepton.bartol.udel.edu)
16 C (johannes.ranft@cern.ch)
19 C (sroesler@SLAC.Stanford.EDU)
22 C For the latest version and documentation check
23 C http://lepton.bartol.udel.edu/~eng/phojet.html
26 C Bug reports, questions, complaints are welcome
27 C (please send a mail to eng@lepton.bartol.udel).
30 C Note that the code is available with several interfaces to
31 C Lund fragmentation programs (JETSET7.x, 1.x and a double
32 C precision JETSET version). This file is the code with
35 C interface to PYTHIA 6.1 (or higher)
37 C for usage in DPMJET 3.x (Lund common block dimensions increased)
40 C***********************************************************************
43 C List of subroutines and functions
44 C ---------------------------------
47 C main event simulation routines
57 C user steering interface
63 C experimental setup / photon flux calculation
97 C cross section calculation
117 C multiple interaction structure
125 C hadron / photon remnant treatment, soft x selection
146 C primordial kt and soft parton pt
157 C simulation of hard scattering, initial state radiation
187 C diffraction dissociation
215 C fragmentation, treatment of low-mass strings
234 C particle code tables, particle numbering conversion
253 C Lorentz transformations, rotations and mass adjustment
269 C program debugging and internal cross-checks
282 C cross section fitting
296 C cross section parametrizations
307 C DPMJET random number generator DT_RNDM used
315 C auxiliary routines / numerical methods
337 C parton density parametrization management / interface
350 C parton density parametrizations from other authors
395 C***********************************************************************
398 **sr temporarily changed
399 C SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
400 SUBROUTINE PHO_INIT(LINP,IREJ)
402 C***********************************************************************
404 C main subroutine to configure and manage PHOJET calculations
406 C input: LINP input unit to read from
407 C -1 to skip reading of input file
408 C LOUT output unit to write to
410 C output: IREJ 0 success
413 C***********************************************************************
414 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
417 C input/output channels
419 COMMON /POINOU/ LI,LO
420 C event debugging information
422 PARAMETER (NMAXD=100)
423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
427 C model switches and parameters
429 INTEGER ISWMDL,IPAMDL
430 DOUBLE PRECISION PARMDL
431 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
432 C general process information
433 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
434 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
436 C global event kinematics and particle IDs
438 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
439 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
440 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
441 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
442 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
443 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
444 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
445 C integration precision for hard cross sections (obsolete)
446 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
447 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
448 C some hadron information, will be deleted in future versions
450 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
451 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
452 C obsolete cut-off information
453 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
454 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
455 C photon flux kinematics and cuts
456 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
457 & YMIN1,YMAX1,YMIN2,YMAX2,
458 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
459 & THMIN1,THMAX1,THMIN2,THMAX2
461 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
462 & YMIN1,YMAX1,YMIN2,YMAX2,
463 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
464 & THMIN1,THMAX1,THMIN2,THMAX2,
466 C cut probability distribution
467 INTEGER IEETA1,IIMAX,KKMAX
468 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
469 INTEGER IEEMAX,IMAX,KMAX
471 DOUBLE PRECISION EPTAB
472 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
474 C event weights and generated cross section
475 INTEGER IPOWGC,ISWCUT,IVWGHT
476 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
477 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
478 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
479 C names of hard scattering processes
481 PARAMETER ( Max_pro_1 = 16 )
483 COMMON /POHPRO/ PROC(0:Max_pro_1)
484 C hard cross sections and MC selection weights
486 PARAMETER ( Max_pro_2 = 16 )
487 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
489 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
490 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
491 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
492 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
493 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
494 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
497 DOUBLE PRECISION PARU,PARJ
498 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
501 DOUBLE PRECISION PMAS,PARF,VCKM
502 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
504 INTEGER MDCY,MDME,KFDP
505 DOUBLE PRECISION BRAT
506 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
512 CHARACTER*70 NUMBER,FILENA
517 C define input/output units
523 **sr temporarily changed
531 WRITE(LO,*) ' ==================================================='
533 WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
535 WRITE(LO,*) ' ==================================================='
536 WRITE(LO,*) ' Authors: Ralph Engel (Bartol Res. Inst.)'
537 WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
538 WRITE(LO,*) ' Stefan Roesler (SLAC)'
539 WRITE(LO,*) ' ---------------------------------------------------'
540 WRITE(LO,*) ' Manual, updates, and further information:'
541 WRITE(LO,*) ' http://lepton.bartol.udel.edu/~eng/phojet.html'
542 WRITE(LO,*) ' ---------------------------------------------------'
543 WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
544 WRITE(LO,*) ' eng@lepton.bartol.udel.edu'
545 WRITE(LO,*) ' ==================================================='
546 WRITE(LO,*) ' $Date$'
547 WRITE(LO,*) ' $Revision$'
549 WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
551 WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
553 WRITE(LO,*) ' ==================================================='
556 C standard initializations
559 DUM = PHO_PMASS(0,-1)
561 C initialize standard PDFs
563 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
564 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
566 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
567 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
569 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
571 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
573 CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
574 CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
575 CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
577 CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
578 CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
579 CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
580 CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
585 C main loop to read input cards
587 READ(LINP,14,END=1300) CNAME,NUMBER
588 IF(CNAME.EQ.'ENDINPUT ') THEN
590 ELSE IF(CNAME.EQ.'STOP ') THEN
593 ELSE IF(CNAME.EQ.'COMMENT ') THEN
594 WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
595 ELSE IF(CNAME(1:1).EQ.'*') THEN
596 WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
597 ELSE IF(CNAME.EQ.'PTCUT ') THEN
598 READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
599 WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
600 & PARMDL(38),PARMDL(39)
601 ELSE IF(CNAME.EQ.'PROCESS ') THEN
602 READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
603 WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
604 ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
605 READ(NUMBER,*) (ITMP(KK),KK=0,11)
606 WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
608 IPRON(KK,ITMP(0)) = ITMP(KK)
610 ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
611 READ(NUMBER,*) IMPRO,IP,ION
612 WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
613 MH_pro_on(IMPRO,IP) = ION
614 ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
615 READ(NUMBER,*) IDPDG,PVIR
618 CALL PHO_SETPAR(1,IDPDG,0,PVIR)
619 WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
620 ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
621 READ(NUMBER,*) IDPDG,PVIR
624 CALL PHO_SETPAR(2,IDPDG,0,PVIR)
625 WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
626 ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
627 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
633 CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
634 WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
635 ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
636 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
642 CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
643 WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
644 ELSE IF(CNAME.EQ.'PDF ') THEN
645 READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
646 WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
647 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
648 ELSE IF(CNAME.EQ.'SETMODEL ') THEN
649 READ(NUMBER,*) I,IVAL
650 WRITE(LO,*) 'SETMODEL ',I,IVAL
651 CALL PHO_SETMDL(I,IVAL,1)
652 ELSE IF(CNAME.EQ.'SETPARAM ') THEN
653 READ(NUMBER,*) I,PARNEW
654 WRITE(LO,*) 'SETPARAM ',I,PARNEW
656 ELSE IF(CNAME.EQ.'DEBUG ') THEN
657 READ(NUMBER,*) IDEBF,IDEBN,IDLEV
658 WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
659 CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
660 ELSE IF(CNAME.EQ.'TRACE ') THEN
661 READ(NUMBER,*) IDEBF,IDLEV
662 WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
664 ELSE IF(CNAME.EQ.'SETICUT ') THEN
665 READ(NUMBER,*) I,ICUT
666 WRITE(LO,*) 'SETICUT ',I,ICUT
668 ELSE IF(CNAME.EQ.'SETFCUT ') THEN
669 READ(NUMBER,*) I,PARNEW
670 WRITE(LO,*) 'SETFCUT ',I,PARNEW
672 ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
673 READ(NUMBER,*) I,IVAL
674 WRITE(LO,*) 'LUND-MSTU ',I,IVAL
676 ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
677 READ(NUMBER,*) I,IVAL
678 WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
680 ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
682 WRITE(LO,*) 'LUND-PARJ ',I,EE
684 ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
686 WRITE(LO,*) 'LUND-PARU ',I,EE
688 ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
689 READ(NUMBER,*) ID,ION
690 WRITE(LO,*) 'LUND-DECAY ',ID,ION
695 ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
696 READ(NUMBER,*) PSOMIN
697 WRITE(LO,*) 'PSOFTMIN ',PSOMIN
698 ELSE IF(CNAME.EQ.'INTPREC ') THEN
699 READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
700 WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
703 ELSE IF(CNAME.EQ.'PDFTEST ') THEN
704 READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
706 WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
707 CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
709 C mass cut on gamma-gamma or gamma-hadron system
710 ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
711 READ(NUMBER,*) ECMIN,ECMAX
712 WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
714 C beam lepton (anti-)tagging system
715 ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
716 READ(NUMBER,*) ITAG1,ITAG2
717 WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
718 ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
720 & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
721 WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
722 & Q2MIN1,Q2MAX1,THMIN1,THMAX1
723 ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
725 & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
726 WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
727 & Q2MIN2,Q2MAX2,THMIN2,THMAX2
729 C sampling of gamma-p events in ep (HERA)
730 ELSE IF( (CNAME.EQ.'WW-HERA ')
731 & .OR.(CNAME.EQ.'GP-HERA ')) THEN
732 READ(NUMBER,*) EE1,EE2,NEV
733 WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
734 IF(YMAX2.LT.0.D0) THEN
735 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
737 CALL PHO_GPHERA(NEV,EE1,EE2)
741 C sampling of gamma-gamma events in e+e- (LEP)
742 ELSE IF( (CNAME.EQ.'GG-EPEM ')
743 & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
744 READ(NUMBER,*) EE1,EE2,NEV
745 WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
746 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
747 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
749 CALL PHO_GGEPEM(-1,EE1,EE2)
750 CALL PHO_GGEPEM(NEV,EE1,EE2)
751 CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
755 C sampling of gamma-gamma in heavy-ion collisions
756 ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
757 READ(NUMBER,*) EE,NA,NZ,NEV
758 WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
759 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
760 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
762 CALL PHO_GGHIOF(NEV,EE,NA,NZ)
765 ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
766 READ(NUMBER,*) EE,NA,NZ,NEV
767 WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
768 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
769 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
771 CALL PHO_GGHIOG(NEV,EE,NA,NZ)
775 C sampling of gamma-hadron events in heavy ion collisions
776 ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
777 READ(NUMBER,*) EE,NA,NZ,NEV
778 WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
779 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
780 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
782 CALL PHO_GHHIOF(NEV,EE,NA,NZ)
786 C sampling of hadron-gamma events in hadron - heavy ion collisions
787 ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
788 READ(NUMBER,*) EP,EE,NA,NZ,NEV
789 WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
790 IF(YMAX2.LT.0.D0) THEN
791 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
793 CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
797 C sampling of photoproduction events e+e-, backscattered laser
798 ELSE IF(CNAME.EQ.'BLASER ') THEN
799 READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
800 WRITE(LO,*) 'BLASER ',EE1,EE2,
801 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
802 CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
805 C sampling of photoproduction events beamstrahlung
806 ELSE IF(CNAME.EQ.'BEAMST ') THEN
807 READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
808 WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
809 IF(YMAX1.LT.0.D0) THEN
810 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
812 CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
816 C fixed-energy events in LAB system of particle 2
817 ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
818 READ(NUMBER,*) PLAB,NEV
819 WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
820 CALL PHO_FIXLAB(PLAB,NEV)
823 C fixed-energy events in CM system
824 ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
825 READ(NUMBER,*) ECM,NEV
826 WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
827 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
828 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
829 CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
834 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
837 C fixed-energy events for collider setup with crossing angle
838 ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
839 READ(NUMBER,*) E1,E2,THETA,PHI,NEV
840 WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
841 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
846 WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
851 WRITE(LO,*) ' RETURN'
855 CDECK ID>, PHO_SETMDL
856 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
857 C**********************************************************************
861 C input: INDX model parameter number
862 C (positive: ISWMDL, negative: IPAMDL)
864 C IMODE -1 print value of parameter INDX
866 C -2 print current settings
868 C**********************************************************************
869 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
872 C input/output channels
874 COMMON /POINOU/ LI,LO
875 C model switches and parameters
877 INTEGER ISWMDL,IPAMDL
878 DOUBLE PRECISION PARMDL
879 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
882 C *** Commented by Chiara
883 C WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
884 C & '----------------------------'
886 IF(ISWMDL(I).EQ.-9999) GOTO 200
887 IF(ISWMDL(I+1).EQ.-9999) THEN
888 C *** Commented by Chiara
889 C WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
891 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
892 C WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
893 C & I+1,':',MDLNA(I+1),ISWMDL(I+1)
896 C WRITE(LO,'(3(5X,I3,A1,A,I6))')
897 C & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
901 ELSE IF(IMODE.EQ.-1) THEN
902 C WRITE(LO,'(1X,A,1X,A,I6)')
903 C & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
904 ELSE IF(IMODE.EQ.1) THEN
906 IF(ISWMDL(INDX).NE.IVAL) THEN
907 WRITE(LO,'(1X,A,I4,1X,A,2I6)')
908 & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
909 & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
912 ELSE IF(INDX.LT.0) THEN
913 IF(IPAMDL(-INDX).NE.IVAL) THEN
914 WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
915 & -INDX,IPAMDL(-INDX),IVAL
920 WRITE(LO,'(/1X,A,I6)')
921 & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
925 CDECK ID>, PHO_DATINI
926 SUBROUTINE PHO_DATINI
927 C*********************************************************************
929 C initialization of variables and switches
931 C*********************************************************************
932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
935 C input/output channels
937 COMMON /POINOU/ LI,LO
939 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
940 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
941 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
942 C event debugging information
944 PARAMETER (NMAXD=100)
945 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
946 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
947 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
948 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
949 C event weights and generated cross section
950 INTEGER IPOWGC,ISWCUT,IVWGHT
951 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
952 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
953 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
954 C scale parameters for parton model calculations
955 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
956 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
957 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
958 & NQQAL,NQQALI,NQQALF,NQQPD
959 C integration precision for hard cross sections (obsolete)
960 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
961 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
962 C hard scattering parameters used for most recent hard interaction
964 DOUBLE PRECISION ALQCD2,BQCD
965 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
966 C cut probability distribution
967 INTEGER IEETA1,IIMAX,KKMAX
968 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
969 INTEGER IEEMAX,IMAX,KMAX
971 DOUBLE PRECISION EPTAB
972 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
974 C gamma-lepton or gamma-hadron vertex information
975 INTEGER IGHEL,IDPSRC,IDBSRC
976 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
977 & RADSRC,AMSRC,GAMSRC
978 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
979 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
980 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
981 C photon flux kinematics and cuts
982 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
983 & YMIN1,YMAX1,YMIN2,YMAX2,
984 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
985 & THMIN1,THMAX1,THMIN2,THMAX2
987 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
988 & YMIN1,YMAX1,YMIN2,YMAX2,
989 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
990 & THMIN1,THMAX1,THMIN2,THMAX2,
992 C obsolete cut-off information
993 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
994 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
995 C global event kinematics and particle IDs
997 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
998 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
999 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
1000 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
1001 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
1002 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
1003 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
1004 C some hadron information, will be deleted in future versions
1006 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
1007 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
1008 C model switches and parameters
1010 INTEGER ISWMDL,IPAMDL
1011 DOUBLE PRECISION PARMDL
1012 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
1013 C general process information
1014 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1015 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1016 C parameters of the "simple" Vector Dominance Model
1017 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1018 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1019 C parameters for DGLAP backward evolution in ISR
1021 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1022 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1023 C particles created by initial state evolution
1024 INTEGER MXISR1,MXISR2
1025 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1026 INTEGER IFLISR,IPOISR,IMXISR
1027 DOUBLE PRECISION PHISR
1028 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1029 & IPOISR(2,2,MXISR2),IMXISR(2)
1030 C names of hard scattering processes
1032 PARAMETER ( Max_pro_1 = 16 )
1034 COMMON /POHPRO/ PROC(0:Max_pro_1)
1035 C hard cross sections and MC selection weights
1037 PARAMETER ( Max_pro_2 = 16 )
1038 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1040 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1041 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1042 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1043 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1044 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1045 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1046 C interpolation tables for hard cross section and MC selection weights
1047 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1048 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1049 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1050 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1051 & HQ2a_tab,HQ2b_tab,HEcm_tab
1053 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1054 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1055 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1056 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1057 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1058 & HEcm_tab(1:Max_tab_E,0:4),
1059 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1061 C initialize /POCONS/
1062 PI = ATAN(1.D0)*4.D0
1065 C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1067 C precalculate quark charges
1069 Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1072 Q_ch2(i) = Q_ch(i)**2
1073 Q_ch2(-i) = Q_ch2(i)
1075 Q_ch4(i) = Q_ch2(i)**2
1076 Q_ch4(-i) = Q_ch4(i)
1082 C initialize /GLOCMS/
1090 C initialize /HADVAL/
1097 C initialize /MODELS/
1099 MDLNA(1) = 'AMPL MOD'
1101 MDLNA(2) = 'MIN-BIAS'
1103 MDLNA(3) = 'PTS DISH'
1105 MDLNA(4) = 'PTS DISP'
1107 MDLNA(5) = 'PTS ASSI'
1109 MDLNA(6) = 'HADRONIZ'
1111 MDLNA(7) = 'MASS COR'
1113 MDLNA(8) = 'PAR SHOW'
1115 MDLNA(9) = 'GLU SPLI'
1117 MDLNA(10) = 'VIRT PHO'
1119 MDLNA(11) = 'LARGE NC'
1121 MDLNA(12) = 'LIPA POM'
1123 MDLNA(13) = 'QELAS VM'
1125 MDLNA(14) = 'ENHA GRA'
1127 MDLNA(15) = 'MULT SCA'
1129 MDLNA(16) = 'MULT DIF'
1131 MDLNA(17) = 'MULT CDF'
1133 MDLNA(18) = 'BALAN PT'
1135 MDLNA(19) = 'POMV FLA'
1137 MDLNA(20) = 'SEA FLA'
1139 MDLNA(21) = 'SPIN DEC'
1141 MDLNA(22) = 'DIF.MASS'
1143 MDLNA(23) = 'DIFF RES'
1145 MDLNA(24) = 'PTS HPOM'
1147 MDLNA(25) = 'POM CORR'
1149 MDLNA(26) = 'OVERLAP '
1151 MDLNA(27) = 'MUL R/AN'
1153 MDLNA(28) = 'SUR PROB'
1155 MDLNA(29) = 'PRIMO KT'
1157 MDLNA(30) = 'DIFF. CS'
1159 C mass-independent sea flavour ratios (for low-mass strings)
1166 C suppression by energy momentum conservation
1170 PARMDL(10) = 0.866D0
1171 PARMDL(11) = 0.288D0
1172 PARMDL(12) = 0.288D0
1173 PARMDL(13) = 0.288D0
1174 PARMDL(14) = 0.866D0
1175 PARMDL(15) = 0.288D0
1176 PARMDL(16) = 0.288D0
1177 PARMDL(17) = 0.288D0
1179 C lower energy limit for initialization
1181 C soft pt for hard scattering remnants
1183 C low energy beta of soft pt distribution 1
1185 C high energy beta of soft pt distribution 1
1187 C low energy beta of soft pt distribution 0
1189 C high energy beta of soft pt distribution 0
1191 C effective quark mass in photon wave function
1193 C normalization of unevolved Pomeron PDFs
1195 C effective VDM parameters for Q**2 dependence of cross section
1200 PARMDL(31) = 0.589824D0
1201 PARMDL(32) = 0.609961D0
1202 PARMDL(33) = 1.038361D0
1204 C Q**2 suppression of multiple interactions
1206 C pt cutoff defaults
1211 C enhancement factor for diffractive cross sections
1215 C mass in soft pt distribution
1217 C maximum of x allowed for leading particle
1219 C max. mass sampled in diffraction
1220 PARMDL(45) = sqrt(0.4D0)
1221 C mass threshold in diffraction (2pi mass)
1223 C regularization of slope parameter in diffraction
1225 C renormalized intercept for enhanced graphs
1227 C coherence constraint for diff. cross sections
1228 PARMDL(49) = sqrt(0.05D0)
1229 C exponents of x distributions
1233 PARMDL(52) = -0.99D0
1234 PARMDL(53) = -0.99D0
1235 C meson (non-strangeness part)
1238 PARMDL(56) = -0.99D0
1239 PARMDL(57) = -0.99D0
1240 C meson (strangeness part)
1243 PARMDL(60) = -0.99D0
1244 PARMDL(61) = -0.99D0
1245 C particle remnant (no valence quarks)
1248 PARMDL(64) = -0.99D0
1249 PARMDL(65) = -0.99D0
1250 C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1252 C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1254 C min. abs(t) in diffraction
1256 C max. abs(t) in diffraction
1258 C min. mass for elastic pomerons in central diffraction
1260 C min. mass of diffractive blob in central diffraction
1262 C min. Feynman x cut in central diffraction
1264 C direct pomeron coupling
1266 C relative deviation allowed for energy-momentum conservation
1267 C energy-momentum relative deviation
1269 C transverse momentum deviation
1271 C couplings for unitarization in diffraction
1272 C non-unitarized pomeron coupling (sqrt(mb))
1274 C rescaling factor for pomeron PDF
1276 C coupling probabilities
1279 C scales to calculate alpha-s of matrix element
1283 C scales to calculate alpha-s of initial state radiation
1287 C scales to calculate alpha-s of final state radiation
1291 C scales to calculate PDFs
1295 C scale for ISR starting virtuality
1297 C min. virtuality to generate time-like showers in ISR
1299 C factor to scale the max. allowed time-like parton shower virtuality
1301 C max. transverse momentum for primordial kt
1303 C weight factors for pt-distribution
1311 * PARMDL(110-125) reserved for hard scattering
1312 C currently chosen scales for hard scattering
1314 PARMDL(109+I) = 0.D0
1316 C virtuality cutoff in initial state evolution
1317 PARMDL(126) = PARMDL(36)**2
1318 PARMDL(127) = PARMDL(37)**2
1319 PARMDL(128) = PARMDL(38)**2
1320 PARMDL(129) = PARMDL(39)**2
1321 C virtuality cutoff for direct contribution to photon PDF
1326 C fraction of events without popcorn
1328 C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1330 C soft color re-connection (fraction)
1332 PARMDL(140) = 1.D0/64.D0
1334 PARMDL(141) = 1.D0/24.D0
1336 PARMDL(142) = 1.D0/9.D0
1337 C effective scale in Drees-Godbole like suppresion in photon PDF
1338 PARMDL(144) = 0.766D0**2
1339 C QCD scales (if PDF scales are not used, 4 active flavours)
1340 PARMDL(145) = 0.2D0**2
1341 PARMDL(146) = 0.2D0**2
1342 PARMDL(147) = 0.2D0**2
1343 C threshold scales for variable flavour calculation (GeV**2)
1344 PARMDL(148) = 1.5D0**2
1345 PARMDL(149) = 4.5D0**2
1346 PARMDL(150) = 175.D0**2
1347 C constituent quark masses
1353 PARMDL(156) = 174.D0
1354 C min. masses of valence quark
1356 C min. masses of valence diquark
1358 C min. mass of sea quark
1360 C suppression of strange quarks as photon valences
1362 C min. masses for strings (used in PHO_SOFTXX)
1367 C min. momentum fraction for soft processes
1369 C min. phase space for x-sampling
1370 PARMDL(166) = 0.135D0
1371 C Ross-Stodolsky exponent
1373 C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1377 * extra factor multiplying difference between Goulianos and PHOJET-
1378 * diff. cross sections
1382 C complex amplitudes, eikonal functions
1384 C allow for Reggeon cuts
1386 C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1388 C polarization of photon resonances (0 none, 1 trans, 2 long)
1390 C pt of valence partons
1392 C pt of hard scattering remnant
1394 C running cutoff for hard scattering
1396 C intercept used for the calculation of enhanced graphs
1398 C effective slope of hard scattering amplitde
1400 C mass dependence of slope parameters
1402 C lepton-photon vertex 1
1404 C lepton-photon vertex 2
1408 C method to sample x distributions
1410 C energy-momentum check
1412 C phase space correction for DPMJET interface
1414 C fragment strings from projectile/target/central diff. separately
1416 C method to construct strings for hard interactions
1418 C method to construct strings for soft sea (pomeron cuts)
1420 C method to construct strings in pomeron interactions
1422 C soft color re-connection
1424 C resummation of triple- and loop-Pomeron
1426 C resummation of X iterated triple-Pomeron
1428 C dimension of interpolation table for weights in hard scattering
1429 IPAMDL(30) = Max_tab_E
1430 C dimension of interpolation table for pomeron cut distribution
1432 C number of cut soft pomerons (restriction by field dimension)
1434 C number of cut hard pomerons (restriction by field dimension)
1436 C tau pair production in direct photon-photon collisions
1438 C currently chosen scales for hard scattering
1439 C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1441 IPAMDL(64+I) = -99999
1443 C scales to calculate alpha-s of matrix element
1447 C scales to calculate alpha-s of initial state radiation
1451 C scales to calculate alpha-s of final state radiation
1455 C scales to calculate PDFs
1459 C where to get the parameter sets from
1461 C program PHO_ABORT for fatal errors (simulation of division by zero)
1463 C initial state parton showers for all / hardest interaction(s)
1465 C final state parton showers for all / hardest interaction(s)
1467 C initial virtuality for ISR generation
1469 C qqbar-gamma coupling in initial state showers
1471 C generation of time-like showers during ISR
1473 C reweighting of multiple soft contributions for virtual photons
1475 C reweighting / use photon virtuality in photon PDF calculations
1477 C use full QPM model incl. interference terms (direct part in gam-gam)
1479 C matching sigma_tot to F2 as given by parton density at high Q2
1481 C use virtuality of target in F2 calculations (two-gamma only)
1483 C calculation of alpha_em
1485 C strict pt cutoff for gamma-gamma events
1487 C photon virtuality sampled in photon flux approximations
1489 C photon-pomeron: 0,1,2: both,left,right photon emission
1491 C keep full history information in PHOJET-JETSET interface
1493 C max. number of conservation law violations allowed in one run
1495 C selection of soft X values
1496 C max. iteration number in PHO_SELSXS
1498 C max. iteration number in PHO_SELSXR
1500 C max. iteration number in PHO_SELSX2
1502 C max. iteration number in PHO_SELSXI
1505 C initialize /PROBAB/
1511 PARMDL(300+I) = -100000.D0
1513 C initialize /POHDRN/
1514 QMASS(1) = PARMDL(151)
1515 QMASS(2) = PARMDL(152)
1516 QMASS(3) = PARMDL(153)
1517 QMASS(4) = PARMDL(154)
1518 QMASS(5) = PARMDL(155)
1519 QMASS(6) = PARMDL(156)
1524 C number of light flavours (quarks treated as massless)
1526 C initialize /POCUT1/
1527 PTCUT(1) = PARMDL(36)
1528 PTCUT(2) = PARMDL(37)
1529 PTCUT(3) = PARMDL(38)
1530 PTCUT(4) = PARMDL(39)
1533 C initialize /POHAPA/
1536 BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1537 BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1538 BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1539 BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1540 C initialize /POGAUP/
1550 C initialize /PROCES/
1555 C DPMJET default: no elastic scattering
1565 C initialize /POSVDM/
1579 RMAX(1) = VMAS(1)+TWOPIM
1580 RMAX(2) = VMAS(2)+TWOPIM
1581 RMAX(3) = VMAS(3)+TWOPIM
1582 RMAX(4) = VMAS(1)+TWOPIM
1591 C initialize /PODGL1/
1592 Q2MISR(1) = PARMDL(36)**2
1593 Q2MISR(2) = PARMDL(36)**2
1601 C initialize /POPISR/
1606 C initialize /POHPRO/
1607 PROC(0) = 'sum over processes'
1608 PROC(1) = 'G +G --> G +G '
1609 PROC(2) = 'Q +QB --> G +G '
1610 PROC(3) = 'G +Q --> G +Q '
1611 PROC(4) = 'G +G --> Q +QB '
1612 PROC(5) = 'Q +QB --> Q +QB '
1613 PROC(6) = 'Q +QB --> QP +QBP'
1614 PROC(7) = 'Q +Q --> Q +Q '
1615 PROC(8) = 'Q +QP --> Q +QP '
1616 PROC(9) = 'resolved processes'
1617 PROC(10) = 'gam+Q --> G +Q '
1618 PROC(11) = 'gam+G --> Q +QB '
1619 PROC(12) = 'Q +gam--> G +Q '
1620 PROC(13) = 'G +gam--> Q +QB '
1621 PROC(14) = 'gam+gam--> Q +QB '
1622 PROC(15) = 'direct processes '
1623 PROC(16) = 'gam+gam--> l+ +l- '
1625 C initialize /POHRCS/
1633 C switch all hard subprocesses on
1635 C reset all counters
1643 C initialize /POHTAB/
1648 HEcm_tab(1,I) = 0.D0
1654 C initialize /POFSRC/
1657 C initialize /LEPCUT/
1670 C initialize /POWGHT/
1684 CDECK ID>, PHO_PARDAT
1685 SUBROUTINE PHO_PARDAT
1686 C***********************************************************************
1688 C particle data (based on 1996 PDG naming scheme and data tables)
1690 C***********************************************************************
1696 C input/output channels
1698 COMMON /POINOU/ LI,LO
1699 C event debugging information
1701 PARAMETER (NMAXD=100)
1702 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
1703 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1704 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
1705 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1706 C particle ID translation table
1707 integer ID_pdg_list,ID_list,ID_pdg_max
1708 character*12 name_list
1709 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
1711 C general particle data
1712 double precision xm_list,tau_list,gam_list,
1713 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
1714 & xm_bb82_list,xm_bb102_list
1715 integer ich3_list,iba3_list,iq_list,
1716 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
1717 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
1718 & xm_psm2_list(6,6),xm_vem2_list(6,6),
1719 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
1720 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
1721 & ich3_list(300),iba3_list(300),iq_list(3,300),
1722 & id_psm_list(6,6),id_vem_list(6,6),
1723 & id_b8_list(6,6,6),id_b10_list(6,6,6)
1724 C particle decay data
1725 double precision wg_sec_list
1726 integer idec_list,isec_list
1727 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
1730 C external functions
1733 double precision pho_pmass
1735 C local variables for storing data tables
1737 integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
1738 & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
1740 dimension number(300),ich3(300),iba3(300),iq_linear(900),
1741 & idec_linear(900),isec_linear(900),id_psm_linear(36),
1742 & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
1744 double precision xmass,gamma,wg_chan
1745 dimension xmass(300),gamma(300),wg_chan(300)
1750 integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
1751 double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
1755 DATA i_tab_max /260/
1757 DATA (number(K),K= 1, 171) /
1758 & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
1759 & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
1760 & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
1761 & 110, 990, 21, 22, 24, 23, 11, 13, 15,
1762 & 12, 14, 16, 211, 111, 221, 113, 213, 223,
1763 & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
1764 & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
1765 & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
1766 & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
1767 & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
1768 & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
1769 & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
1770 & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
1771 & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
1772 & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
1773 & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
1774 & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
1775 & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
1776 & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
1777 DATA (number(K),K= 172, 260) /
1778 & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
1779 & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
1780 & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
1781 & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
1782 & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
1783 & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
1784 & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
1785 & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
1786 & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
1787 & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
1788 DATA (name(K),K= 1, 76) /
1789 &'d ','u ','s ','c ',
1790 &'b ','t ','(dd)_1 ','(ud)_0 ',
1791 &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
1792 &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
1793 &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
1794 &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
1795 &'string ','mod. string ','coll. string','reggeon ',
1796 &'pomeron ','gluon ','gamma ','W ',
1797 &'Z ','e ','mu ','tau ',
1798 &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
1799 &'pi ','eta ','rho(770) ','rho(770) ',
1800 &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
1801 &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
1802 &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
1803 &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
1804 &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
1805 &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
1806 &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
1807 &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
1808 DATA (name(K),K= 77, 152) /
1809 &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
1810 &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
1811 &'K ','K(S) ','K(L) ','K*(892) ',
1812 &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
1813 &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
1814 &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
1815 &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
1816 &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
1817 &'K(4)*(2045) ','D ','D ','D*(2007) ',
1818 &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
1819 &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
1820 &'B ','B* ','B* ','B(s) ',
1821 &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
1822 &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
1823 &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
1824 &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
1825 &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
1826 &'Ups(10860) ','Ups(11020) ','p ','n ',
1827 &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
1828 DATA (name(K),K= 153, 228) /
1829 &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
1830 &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
1831 &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
1832 &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
1833 &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
1834 &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
1835 &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
1836 &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
1837 &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
1838 &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
1839 &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
1840 &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
1841 &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
1842 &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
1843 &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
1844 &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
1845 &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
1846 &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
1847 &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
1848 DATA (name(K),K= 229, 260) /
1849 &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
1850 &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
1851 &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
1852 &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
1853 &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
1854 &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
1855 &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
1856 &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
1857 DATA (ich3(K),K= 1, 260) /
1858 &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
1859 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
1860 & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
1861 & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
1862 & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
1863 & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1864 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
1865 & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
1866 &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
1867 & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
1868 & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
1869 & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
1870 DATA (iba3(K),K= 1, 260) /
1871 &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,
1872 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1873 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1874 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1875 &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,
1876 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1877 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1878 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
1879 DATA (iq_linear(K),K= 1, 418) /
1880 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
1881 & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
1882 & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
1883 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1884 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1885 & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1886 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
1887 &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
1888 & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1889 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
1890 &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
1891 & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
1892 & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
1893 &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
1894 & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
1895 & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
1896 &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
1897 & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
1898 & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
1899 DATA (iq_linear(K),K= 419, 780) /
1900 &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
1901 & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
1902 & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
1903 & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
1904 & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
1905 & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
1906 & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
1907 & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
1908 & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
1909 & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
1910 & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
1911 & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
1912 & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
1913 & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
1914 & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
1915 & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
1916 & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
1917 DATA (xmass(K),K= 1, 114) /
1918 &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
1919 &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
1920 &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
1921 &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
1922 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1923 &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
1924 &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
1925 &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
1926 &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
1927 &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
1928 &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
1929 &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
1930 &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
1931 &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
1932 &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
1933 &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
1934 &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
1935 &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
1936 &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
1937 DATA (xmass(K),K= 115, 228) /
1938 &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
1939 &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
1940 &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
1941 &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
1942 &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
1943 &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
1944 &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
1945 &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
1946 &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
1947 &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
1948 &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
1949 &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
1950 &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
1951 &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
1952 &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
1953 &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
1954 &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
1955 &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
1956 &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
1957 DATA (xmass(K),K= 229, 260) /
1958 &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
1959 &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
1960 &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
1961 &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
1962 &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
1963 &2.7040E+00,5.6240E+00/
1964 DATA (gamma(K),K= 1, 114) /
1965 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1966 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1967 &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
1968 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1969 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1970 &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
1971 &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
1972 &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
1973 &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
1974 &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
1975 &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
1976 &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
1977 &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
1978 &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
1979 &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
1980 &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
1981 &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
1982 &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
1983 &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
1984 DATA (gamma(K),K= 115, 228) /
1985 &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
1986 &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
1987 &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
1988 &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
1989 &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
1990 &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
1991 &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1992 &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
1993 &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
1994 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
1995 &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1996 &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
1997 &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
1998 &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
1999 &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
2000 &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
2001 &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
2002 &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
2003 &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
2004 DATA (gamma(K),K= 229, 260) /
2005 &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
2006 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
2007 &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
2008 &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
2009 &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
2010 &1.0200E-11,5.3100E-13/
2011 DATA (idec_linear(K),K= 1, 304) /
2012 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2013 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2014 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2015 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2016 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2017 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2018 & 0, 0, 0, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
2019 & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
2020 & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
2021 & 0, 0, 0, 1, 25, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2022 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2023 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 30, 32,
2024 & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
2025 & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
2026 & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2027 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
2028 & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
2029 & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
2030 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
2031 DATA (idec_linear(K),K= 305, 608) /
2032 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2033 & 0, 0, 0, 0, 0, 0, 0, 2, 77, 78, 2, 79, 82, 1, 83, 84,
2034 & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
2035 & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2036 & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
2037 & 0, 0, 0, 1, 99,101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2038 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2039 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2040 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
2041 &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 0, 0,
2042 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2043 & 0, 0, 0, 0, 0, 0, 1,137,144, 1,145,152, 0, 0, 0, 0,
2044 & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
2045 &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2046 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
2047 &163,169, 1,170,176, 1,177,180, 0, 0, 0, 0, 0, 0, 0, 0,
2048 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2049 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2050 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
2051 DATA (idec_linear(K),K= 609, 780) /
2052 & 0, 0, 0, 0, 3,181,182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2053 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2054 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,183,184, 3,185,
2055 &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 0, 0, 0,
2056 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2057 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,195,203, 0, 0,
2058 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2059 & 0, 0, 0, 0, 0, 0, 1,204,216, 0, 0, 0, 3,217,217, 3,
2060 &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
2061 &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
2062 & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
2063 DATA (isec_linear(K),K= 1, 152) /
2064 & 11, 12, -12, 13, -14, 16, 11, -12,
2065 & 16, -213, 16, 0, -211, 16, 0, -323,
2066 & 16, 0, -13, 12, 0, 22, 22, 0,
2067 & 22, -11, 11, 22, 22, 0, 111, 22,
2068 & 22, 111, 111, 111, 211, -211, 111, 211,
2069 & -211, 22, 211, -211, 0, 111, 111, 0,
2070 & 211, 111, 0, 211, -211, 111, 211, -211,
2071 & 0, 111, 22, 0, 221, 211, -211, 221,
2072 & 111, 111, 211, -211, 22, 22, 22, 0,
2073 & 321, -321, 0, 130, 310, 0, 113, 111,
2074 & 0, 211, -211, 111, 221, 22, 0, 113,
2075 & 111, 0, -213, 211, 0, 213, -211, 0,
2076 & 211, -211, 0, 111, 111, 0, 113, 111,
2077 & 0, -213, 211, 0, 213, -211, 0, 311,
2078 & -313, 0, -311, 313, 0, 113, 211, -211,
2079 & -13, 12, 0, 211, 111, 0, 211, 211,
2080 & -211, 211, 111, 111, -13, 111, 12, -11,
2081 & 111, 12, 211, -211, 0, 111, 111, 0,
2082 & 111, 111, 111, 211, -211, 111, 211, 13/
2083 DATA (isec_linear(K),K= 153, 304) /
2084 & 12, 211, 11, 12, 321, 111, 0, 311,
2085 & 211, 0, 311, 111, 0, 321, -211, 0,
2086 & 311, 111, 0, 321, -211, 0, 321, 111,
2087 & 0, 311, 211, 0, 311, 111, 0, 321,
2088 & -211, 0, 313, 111, 0, 323, -211, 0,
2089 & 311, 113, 0, 321, -213, 0, 311, 223,
2090 & 0, 311, 221, 0, 321, 111, 0, 311,
2091 & 211, 0, 323, 111, 0, 313, 211, 0,
2092 & 321, 113, 0, 311, 213, 0, 321, 223,
2093 & 0, 321, 221, 0, -321, 211, 211, -311,
2094 & 211, 0, -321, 211, 0, -321, 211, 111,
2095 & 311, 211, -211, 311, 111, 0, 421, 111,
2096 & 0, 421, 22, 0, 421, 211, 0, 411,
2097 & 111, 0, 411, 22, 0, 221, 211, 0,
2098 & 321, -321, 321, 321, -311, 0, 431, 22,
2099 & 0, 431, 22, 0, 111, 111, 0, 211,
2100 & -211, 0, 22, 22, 0, -11, 11, 0,
2101 & -13, 13, 0, 211, -211, 111, 443, 211,
2102 & -211, 443, 111, 111, 443, 221, 0, 2212/
2103 DATA (isec_linear(K),K= 305, 456) /
2104 & 11, 12, 2112, 111, 0, 2212, -211, 0,
2105 & 2112, 111, 111, 2112, 211, -211, 1114, 211,
2106 & 0, 2114, 111, 0, 2214, -211, 0, 2112,
2107 & 113, 0, 2212, -213, 0, 2112, 221, 0,
2108 & 2212, 111, 0, 2112, 211, 0, 2212, 111,
2109 & 111, 2212, 211, -211, 2224, -211, 0, 2214,
2110 & 111, 0, 2114, 211, 0, 2212, 113, 0,
2111 & 2112, 213, 0, 2212, 221, 0, 2212, -211,
2112 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2113 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2114 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2115 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2116 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2117 & 2212, -211, 0, 2112, 111, 0, 2212, -213,
2118 & 0, 2112, 113, 0, 3122, 311, 0, 3212,
2119 & 311, 0, 3112, 321, 0, 2112, 221, 0,
2120 & 2212, 111, 0, 2112, 211, 0, 2212, 113,
2121 & 0, 2112, 213, 0, 3122, 321, 0, 3222,
2122 & 311, 0, 3212, 321, 0, 2212, 221, 0/
2123 DATA (isec_linear(K),K= 457, 608) /
2124 & 2112, -211, 0, 2212, -211, 0, 2112, 111,
2125 & 0, 2212, 111, 0, 2112, 211, 0, 2212,
2126 & 211, 0, 2112, -211, 0, 2114, -211, 0,
2127 & 1114, 111, 0, 2112, -213, 0, 2212, -211,
2128 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2129 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2130 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2131 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2132 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2133 & 2212, 211, 0, 2224, 111, 0, 2214, 211,
2134 & 0, 2212, 213, 0, 2212, -211, 0, 2112,
2135 & 111, 0, 2212, 111, 0, 2112, 211, 0,
2136 & 3122, 22, 0, 2112, -211, 0, 3122, 211,
2137 & 0, 3212, 211, 0, 3222, 111, 0, 3122,
2138 & 111, 0, 3222, -211, 0, 3112, 211, 0,
2139 & 3122, -211, 0, 3212, -211, 0, 2112, -311,
2140 & 0, 2212, -321, 0, 3222, -211, 0, 3212,
2141 & 111, 0, 3112, 211, 0, 3122, 221, 0,
2142 & 3224, -211, 0, 3114, 211, 0, 3214, 111/
2143 DATA (isec_linear(K),K= 609, 760) /
2144 & 0, 2112, -311, 0, 2212, -321, 0, 3122,
2145 & 111, 0, 3122, 223, 0, 3122, 113, 0,
2146 & 3222, -213, 0, 3112, 213, 0, 3212, 113,
2147 & 0, 3122, 221, 0, 3212, 221, 0, 3222,
2148 & -211, 0, 3112, 211, 0, 3212, 111, 0,
2149 & 3122, 111, 0, 3122, -211, 0, 3322, 111,
2150 & 0, 3312, 211, 0, 3322, -211, 0, 3312,
2151 & 111, 0, 3322, -211, 0, 3312, 111, 0,
2152 & 3122, -321, 0, 3222, 221, 0, 3222, 331,
2153 & 0, 2212, -311, 0, 3322, 321, 0, 3224,
2154 & 221, 0, 2214, 331, 0, 2224, -321, 0,
2155 & 3122, 213, 0, 3212, 213, 0, 3222, 113,
2156 & 0, 3222, 223, 0, 2212, -313, 0, 2214,
2157 & -313, 0, 2224, -323, 0, 4122, 211, 0,
2158 & 4122, 111, 0, 4122, -211, 0, 3222, -311,
2159 & 0, 3322, 211, 0, 3222, -313, 0, 3322,
2160 & 213, 0, 3212, -313, 0, 3222, -323, 0,
2161 & 3322, 223, 0, 3312, 213, 0, 3214, -313,
2162 & 0, 3322, -311, 0, 3322, 313, 0, 3334/
2163 DATA (isec_linear(K),K= 761, 765) /
2164 & 213, 0, 3334, 211, 0/
2165 DATA (wg_chan(K),K= 1, 114) /
2166 &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
2167 &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
2168 &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
2169 &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
2170 &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
2171 &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
2172 &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
2173 &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
2174 &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
2175 &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
2176 &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
2177 &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
2178 &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
2179 &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
2180 &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
2181 &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
2182 &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
2183 &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
2184 &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
2185 DATA (wg_chan(K),K= 115, 228) /
2186 &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
2187 &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
2188 &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
2189 &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
2190 &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
2191 &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
2192 &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
2193 &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
2194 &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
2195 &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
2196 &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
2197 &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
2198 &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
2199 &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
2200 &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
2201 &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
2202 &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
2203 &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
2204 &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
2205 DATA (wg_chan(K),K= 229, 255) /
2206 &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
2207 &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
2208 &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
2209 &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
2210 &2.0000E-01,3.6000E-01,7.0000E-02/
2211 DATA (id_psm_linear(K),K= 1, 36) /
2212 & 111, 211, -311, 411, 0, 0, -211, 111,
2213 & -321, 421, 0, 0, 311, 321, 221, 431,
2214 & 0, 0, -411, -421, -431, 441, 0, 0,
2215 & 0, 0, 0, 0, 0, 0, 0, 0,
2217 DATA (id_vem_linear(K),K= 1, 36) /
2218 & 113, 213, -313, 413, 0, 0, -213, 113,
2219 & -323, 423, 0, 0, 313, 323, 333, 433,
2220 & 0, 0, -413, -423, -433, 20443, 0, 0,
2221 & 0, 0, 0, 0, 0, 0, 0, 0,
2223 DATA (id_b8_linear(K),K= 1, 171) /
2224 & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
2225 & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
2226 & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
2227 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2228 & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
2229 & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
2230 & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
2231 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2232 & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
2233 & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
2234 & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
2235 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2236 & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
2237 & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
2238 & 4412, 4422, 4432, 4444, 0, 0, 0, 0, 0,
2239 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2240 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2241 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2242 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2243 DATA (id_b8_linear(K),K= 172, 216) /
2244 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2245 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2246 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2247 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2248 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2249 DATA (id_b10_linear(K),K= 1, 171) /
2250 & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
2251 & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
2252 & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
2253 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2254 & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
2255 & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
2256 & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
2257 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2258 & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
2259 & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
2260 & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
2261 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2262 & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
2263 & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
2264 & 4414, 4424, 4434, 4444, 0, 0, 0, 0, 0,
2265 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2266 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2267 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2268 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2269 DATA (id_b10_linear(K),K= 172, 216) /
2270 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2271 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2272 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2274 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2276 ID_pdg_max = i_tab_max
2278 C copy from local to global variables
2280 ID_pdg_list(i) = number(i)
2281 name_list(i) = name(i)
2282 xm_list(i) = xmass(i)
2283 gam_list(i) = gamma(i)
2284 ich3_list(i) = ich3(i)
2285 iba3_list(i) = iba3(i)
2287 iq_list(j,i) = iq_linear(3*(i-1)+j)
2288 idec_list(j,i) = idec_linear(3*(i-1)+j)
2292 C initialize hash table
2293 call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
2298 C quark index table for mesons
2301 id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
2302 id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
2306 C quark index table for baryons
2311 & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
2312 id_b10_list(i,j,k) =
2313 & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
2320 C copy secondary particles
2321 C (translate PDG-ID to CPC and sort according to CPC)
2324 if(idec_list(1,i).ne.0) then
2325 do j=idec_list(2,i),idec_list(3,i)
2327 wg_sec_list(ichan) = wg_chan(j)
2329 if(isec_linear(3*(j-1)+k).ne.0) then
2330 isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
2332 isec_list(k,ichan) = 0
2339 C add two-pion background (low-mass photon dissociation)
2343 idec_list(2,i) = ichan
2344 idec_list(3,i) = ichan
2345 wg_sec_list(ichan) = 1.D0
2346 isec_list(1,ichan) = ipho_pdg2id(211)
2347 isec_list(2,ichan) = ipho_pdg2id(-211)
2348 isec_list(3,ichan) = 0
2350 C min. mass limits for strings: q-qbar
2356 C pseudo-scalar mesons
2357 i1 = iabs(id_psm_list(i,k))
2361 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2363 i2 = iabs(id_psm_list(k,j))
2367 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2369 AM2P = MIN(AM2P,AM1+AM2)
2371 i1 = iabs(id_vem_list(i,k))
2375 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2377 i2 = iabs(id_vem_list(k,j))
2381 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2383 AM2V = MIN(AM2V,AM1+AM2)
2385 xm_psm2_list(i,j) = AM2P
2386 xm_vem2_list(i,j) = AM2V
2390 C min. mass limits for strings: qq-q
2397 C pseudo-scalar meson
2398 i1 = iabs(id_psm_list(k,l))
2402 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2405 i2 = iabs(id_vem_list(k,l))
2409 AM2 = pho_pmass(i,3)+pho_pmass(k,3)
2413 K8 = id_b8_list(i,j,l)
2417 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2419 AM82 = MIN(AM82, AM1 + AMM)
2421 K10 = id_b10_list(i,j,l)
2425 AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2427 AM102 = MIN(AM102, AM2 + AMM)
2429 xm_b82_list(i,j,k) = AM82
2430 xm_b102_list(i,j,k) = AM102
2435 C min. mass limits for strings: qq-qbarqbar
2444 K8 = id_b8_list(i,j,l)
2448 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2450 L8 = id_b8_list(ii,jj,l)
2454 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2456 AM82 = MIN(AM82, AM1+AM2)
2458 K10 = id_b10_list(i,j,l)
2462 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2464 L10 = id_b10_list(ii,jj,l)
2468 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2470 AM102 = MIN(AM102, AM1+AM2)
2472 xm_bb82_list(i,j,ii,jj) = AM82
2473 xm_bb102_list(i,j,ii,jj) = AM102
2481 CDECK ID>, PHO_PRESEL
2482 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2483 C**********************************************************************
2485 C user specific function to pre-select events during generation
2487 C input: MODE 5 electron and photon kinematics
2488 C 10 process and number of cut Pomerons
2489 C 15 partons without construction of strings
2490 C 20 partons assigned to strings
2491 C 25 after fragmentation, complete final state
2493 C output: IREJ 0 event accepted
2496 C**********************************************************************
2497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2500 C input/output channels
2502 COMMON /POINOU/ LI,LO
2503 C event debugging information
2505 PARAMETER (NMAXD=100)
2506 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2507 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2508 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2509 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2511 C standard particle data interface
2514 PARAMETER (NMXHEP=4000)
2516 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2517 DOUBLE PRECISION PHEP,VHEP
2518 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2519 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2521 C extension to standard particle data interface (PHOJET specific)
2522 INTEGER IMPART,IPHIST,ICOLOR
2523 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2525 C global event kinematics and particle IDs
2527 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2528 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2529 C gamma-lepton or gamma-hadron vertex information
2530 INTEGER IGHEL,IDPSRC,IDBSRC
2531 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2532 & RADSRC,AMSRC,GAMSRC
2533 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2534 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2535 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2536 C hard scattering data
2538 PARAMETER ( MSCAHD = 50 )
2539 INTEGER LSCAHD,LSC1HD,LSIDX,
2540 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2541 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2542 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2543 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2544 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2545 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2546 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2547 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2548 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2549 C event weights and generated cross section
2550 INTEGER IPOWGC,ISWCUT,IVWGHT
2551 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2552 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2553 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2557 * XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2558 * IF(XBJ.LT.0.002D0) IREJ = 1
2562 CDECK ID>, PHO_FIXCOL
2563 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2564 C**********************************************************************
2566 C interface to call PHOJET (fixed energy run) with
2567 C collider kinematics
2569 C equivalen photon approximation to get photon flux
2571 C input: NEV number of events to generate
2572 C THETA azimuthal angle (micro radians)
2573 C PHI beam crossing angle
2574 C (with respect to x, in degrees)
2575 C E1 energy of particle 1 (+z direction, GeV)
2576 C E2 energy of particle 2 (-z direction, GeV)
2578 C note: particle types have to be specified before
2581 C**********************************************************************
2582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2585 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2587 C input/output channels
2589 COMMON /POINOU/ LI,LO
2590 C event debugging information
2592 PARAMETER (NMAXD=100)
2593 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2594 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2595 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2596 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2597 C general process information
2598 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2599 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2600 C global event kinematics and particle IDs
2602 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2603 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2604 C model switches and parameters
2606 INTEGER ISWMDL,IPAMDL
2607 DOUBLE PRECISION PARMDL
2608 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2609 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2610 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2611 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2612 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2613 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2614 C integration precision for hard cross sections (obsolete)
2615 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2616 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2617 C event weights and generated cross section
2618 INTEGER IPOWGC,ISWCUT,IVWGHT
2619 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2620 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2621 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2623 DIMENSION P1(4),P2(4)
2625 C remnant initialization (only needed for DPMJET)
2628 IF(IFPAP(1).EQ.81) THEN
2634 IF(IFPAP(2).EQ.82) THEN
2638 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2639 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2640 PP1 = SQRT(E1**2-PMASS1**2)
2641 PP2 = SQRT(E2**2-PMASS2**2)
2642 C beam crossing angle
2643 TH = 1.D-6*THETA/2.D0
2645 P1(1) = PP1*SIN(TH)*COS(PH)
2646 P1(2) = PP1*SIN(TH)*SIN(PH)
2649 P2(1) = PP2*SIN(TH)*COS(PH)
2650 P2(2) = PP2*SIN(TH)*SIN(PH)
2651 P2(3) = -PP2*COS(TH)
2653 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2659 CALL PHO_PHIST(-1,SIGMAX)
2660 CALL PHO_LHIST(-1,SIGMAX)
2661 C test of DPMJET interface (default is IPAMDL(13)=0)
2662 if(IPAMDL(13).gt.0) then
2668 C main generation loop
2672 CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2673 IF(IREJ.NE.0) GOTO 55
2674 CALL PHO_PHIST(1,HSWGHT(0))
2675 CALL PHO_LHIST(1,HSWGHT(0))
2679 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2680 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2681 & '=========================================================',
2682 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2683 & '========================================================='
2684 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2685 CALL PHO_PHIST(-2,SIGMAX)
2686 CALL PHO_LHIST(-2,SIGMAX)
2688 WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2693 CDECK ID>, PHO_FIXLAB
2694 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2695 C**********************************************************************
2697 C interface to call PHOJET (fixed energy run) with
2698 C LAB kinematics (second particle as target)
2700 C equivalent photon approximation to get photon flux
2702 C input: NEV number of events to generate
2703 C PLAB LAB momentum of particle 1
2705 C note: particle types have to be specified before
2708 C**********************************************************************
2709 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2712 C input/output channels
2714 COMMON /POINOU/ LI,LO
2715 C event debugging information
2717 PARAMETER (NMAXD=100)
2718 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2719 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2720 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2721 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2722 C general process information
2723 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2724 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2725 C global event kinematics and particle IDs
2727 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2728 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2729 C model switches and parameters
2731 INTEGER ISWMDL,IPAMDL
2732 DOUBLE PRECISION PARMDL
2733 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2734 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2735 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2736 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2737 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2738 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2739 C integration precision for hard cross sections (obsolete)
2740 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2741 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2742 C event weights and generated cross section
2743 INTEGER IPOWGC,ISWCUT,IVWGHT
2744 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2745 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2746 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2748 DIMENSION P1(4),P2(4)
2750 C remnant initialization (only needed for DPMJET)
2754 IF(IFPAP(1).EQ.81) THEN
2760 IF(IFPAP(2).EQ.82) THEN
2764 C get momenta in LAB system
2765 PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2766 PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2767 IF(PMASS2.LT.0.1D0) THEN
2768 WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2769 & 'no LAB system possible',IFPAB(1),IFPAB(2)
2774 P1(4) = SQRT(PMASS1+PLAB**2)
2778 P2(4) = SQRT(PMASS2)
2779 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2785 CALL PHO_PHIST(-1,SIGMAX)
2786 CALL PHO_LHIST(-1,SIGMAX)
2787 C event generation loop
2791 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2792 IF(IREJ.NE.0) GOTO 45
2793 CALL PHO_LHIST(1,HSWGHT(0))
2795 CALL PHO_PHIST(10,HSWGHT(0))
2799 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2800 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2801 & '=========================================================',
2802 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2803 & '========================================================='
2804 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2805 CALL PHO_PHIST(-2,SIGMAX)
2806 CALL PHO_LHIST(-2,SIGMAX)
2808 WRITE(LO,'(1X,A,I5)')
2809 & 'PHO_FIXLAB: no events simulated',NEV
2815 CDECK ID>, PHO_GPHERA
2816 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2817 C**********************************************************************
2819 C interface to call PHOJET (variable energy run) with
2820 C HERA kinematics, photon as particle 2
2822 C equivalent photon approximation to get photon flux
2824 C input: NEVENT number of events to generate
2825 C EE1 proton energy (LAB system)
2826 C EE2 electron energy (LAB system)
2828 C YMIN2 lower limit of Y
2829 C (energy fraction taken by photon from electron)
2830 C YMAX2 upper limit of Y
2831 C Q2MIN2 lower limit of photon virtuality
2832 C Q2MAX2 upper limit of photon virtuality
2834 C**********************************************************************
2835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2838 PARAMETER ( DEPS = 1.D-10,
2839 & PI = 3.14159265359D0 )
2841 C input/output channels
2843 COMMON /POINOU/ LI,LO
2844 C event debugging information
2846 PARAMETER (NMAXD=100)
2847 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2848 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2849 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2850 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2851 C model switches and parameters
2853 INTEGER ISWMDL,IPAMDL
2854 DOUBLE PRECISION PARMDL
2855 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2856 C photon flux kinematics and cuts
2857 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2858 & YMIN1,YMAX1,YMIN2,YMAX2,
2859 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2860 & THMIN1,THMAX1,THMIN2,THMAX2
2862 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2863 & YMIN1,YMAX1,YMIN2,YMAX2,
2864 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2865 & THMIN1,THMAX1,THMIN2,THMAX2,
2867 C gamma-lepton or gamma-hadron vertex information
2868 INTEGER IGHEL,IDPSRC,IDBSRC
2869 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2870 & RADSRC,AMSRC,GAMSRC
2871 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2872 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2873 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2874 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2875 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2876 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2877 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2878 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2879 C event weights and generated cross section
2880 INTEGER IPOWGC,ISWCUT,IVWGHT
2881 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2882 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2883 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2885 DIMENSION P1(4),P2(4)
2887 WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2888 C assign particle momenta according to HERA kinematics
2890 PROM = PHO_PMASS(2212,1)
2899 IDBSRC(2) = ipho_pdg2id(11)
2908 IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2909 & WRITE(LO,'(/1X,A,1P2E11.4)')
2910 & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2911 & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2914 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2917 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2918 & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2920 Y = EXP(XIMIN+DELLY*DBLE(I-1))
2921 Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2922 FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923 & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2924 FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2925 FLUXT = FLUXT + Y*FFT
2926 FLUXL = FLUXL + Y*FFL
2927 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2931 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2932 & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2937 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2938 WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2939 & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2940 IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2942 C initialization of PHOJET at upper energy limit
2946 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2954 C sum of both photon polarizations
2957 CALL PHO_SETPAR(1,2212,0,0.D0)
2958 CALL PHO_SETPAR(2,22,0,0.D0)
2959 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2960 CALL PHO_PHIST(-1,SIGMAX)
2961 CALL PHO_LHIST(-1,SIGMAX)
2963 C generation of events, flux calculation
2986 YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2987 IF(ISWMDL(10).GE.2) THEN
2988 YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2990 YEFF = 1.D0+(1.D0-YY)**2
2992 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2993 Q2LOG = LOG(Q2MAX/Q2LOW)
2994 WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
2995 IF(WGMAX.LT.WGH) THEN
2996 WRITE(LO,'(1X,A,3E12.5)')
2997 & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
2999 IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
3001 IF(IPAMDL(174).EQ.1) THEN
3003 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3004 WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
3005 IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
3018 YQ2 = SQRT((1.D0-YY)*Q2)
3021 CALL PHO_SFECFE(SIF,COF)
3024 PFIN(3,2) = -E1Y+Q2E
3031 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3033 IF(PFIN(4,2).GT.EEMIN2) THEN
3034 IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3037 PFPHI(2) = ATAN2(COF,SIF)
3041 P2(3) = PINI(3,2)-PFIN(3,2)
3042 P2(4) = PINI(4,2)-PFIN(4,2)
3046 P1(3) = SQRT(EE1**2-PROM2)
3049 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3050 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3051 IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3058 PGAM(5,2) = -SQRT(Q2)
3060 IF(ISWMDL(10).GE.2) THEN
3061 WGH = YEFF-2.D0*ELEM2*YY**2/Q2
3063 IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3072 CALL PHO_PRESEL(5,IREJ)
3073 IF(IREJ.NE.0) GOTO 175
3075 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3076 IF(IREJ.NE.0) GOTO 150
3081 YY2MIN = MIN(YY2MIN,YY)
3082 YY2MAX = MAX(YY2MAX,YY)
3083 Q22MIN = MIN(Q22MIN,Q2)
3084 Q22MAX = MAX(Q22MAX,Q2)
3086 Q22AV2 = Q22AV2+Q2*Q2
3087 AN2MIN = MIN(AN2MIN,PFTHE(2))
3088 AN2MAX = MAX(AN2MAX,PFTHE(2))
3090 CALL PHO_PHIST(1,HSWGHT(0))
3091 CALL PHO_LHIST(1,HSWGHT(0))
3094 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3095 WGY = WGY*LOG(YMAX2/YMIN2)
3097 AY2 = AY2/DBLE(NITER)
3098 DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3099 Q22AVE = Q22AVE/DBLE(NITER)
3100 Q22AV2 = Q22AV2/DBLE(NITER)
3101 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3102 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3103 C output of histograms
3104 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3105 &'=========================================================',
3106 &' ***** simulated cross section: ',WEIGHT,' mb *****',
3107 &'========================================================='
3108 WRITE(LO,'(//1X,A,3I10)')
3109 & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3110 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3112 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
3113 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
3115 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
3117 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
3119 WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3120 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3122 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3124 CALL PHO_PHIST(-2,WEIGHT)
3125 CALL PHO_LHIST(-2,WEIGHT)
3127 WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3132 CDECK ID>, PHO_GGEPEM
3133 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3134 C**********************************************************************
3136 C interface to call PHOJET (variable energy run) for
3137 C gamma-gamma collisions on e+e- collider
3139 C fully differential equivalent (improved) photon approximation
3140 C to get photon flux
3142 C input: EE1 LAB system energy of electron/positron 1
3143 C EE2 LAB system energy of electron/positron 2
3144 C NEVENT >0 number of events to generate
3146 C -2 final call (cross section calculation)
3148 C YMIN1 lower limit of Y1
3149 C (energy fraction taken by photon from electron)
3150 C YMAX1 upper limit of Y1
3151 C Q2MIN1 lower limit of photon virtuality
3152 C Q2MAX1 upper limit of photon virtuality
3153 C THMIN1 lower limit of scattered electron
3154 C THMAX1 upper limit of scattered electron
3155 C YMIN2 lower limit of Y2
3156 C (energy fraction taken by photon from electron)
3157 C YMAX2 upper limit of Y2
3158 C Q2MIN2 lower limit of photon virtuality
3159 C Q2MAX2 upper limit of photon virtuality
3160 C THMIN2 lower limit of scattered electron
3161 C THMAX2 upper limit of scattered electron
3163 C output: after final call with NEVENT=-2
3164 C EE1 e+ e- cross section (mb)
3165 C EE2 gamma-gamma cross section (mb)
3167 C**********************************************************************
3173 DOUBLE PRECISION EE1,EE2
3176 C input/output channels
3178 COMMON /POINOU/ LI,LO
3179 C event debugging information
3181 PARAMETER (NMAXD=100)
3182 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3183 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3184 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3185 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3186 C model switches and parameters
3188 INTEGER ISWMDL,IPAMDL
3189 DOUBLE PRECISION PARMDL
3190 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3192 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3193 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3194 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3195 C photon flux kinematics and cuts
3196 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3197 & YMIN1,YMAX1,YMIN2,YMAX2,
3198 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3199 & THMIN1,THMAX1,THMIN2,THMAX2
3201 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3202 & YMIN1,YMAX1,YMIN2,YMAX2,
3203 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3204 & THMIN1,THMAX1,THMIN2,THMAX2,
3206 C gamma-lepton or gamma-hadron vertex information
3207 INTEGER IGHEL,IDPSRC,IDBSRC
3208 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3209 & RADSRC,AMSRC,GAMSRC
3210 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3211 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3212 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3213 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3214 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3215 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3216 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3217 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3218 C event weights and generated cross section
3219 INTEGER IPOWGC,ISWCUT,IVWGHT
3220 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3221 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3222 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3224 C external functions
3225 DOUBLE PRECISION DT_RNDM
3228 DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3229 & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3230 & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3231 & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3232 & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3233 & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3234 & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3235 & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3236 & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3238 INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3239 & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3241 DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3244 C initialization of event generation
3246 if(NEVENT.eq.-1) then
3254 WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3264 IDBSRC(1) = ipho_pdg2id(11)
3265 IDBSRC(2) = ipho_pdg2id(-11)
3267 C check/update kinematic limitations
3269 Ymi = min(Ymax1,1.D0-ELEM/EE1)
3270 if(Ymi.lt.Ymax1) then
3271 WRITE(LO,'(/1X,A,2E12.5)')
3272 & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3275 Ymi = min(Ymax2,1.D0-ELEM/EE2)
3276 if(Ymi.lt.Ymax2) then
3277 WRITE(LO,'(/1X,A,2E12.5)')
3278 & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3282 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3283 IF(YMIN1.LT.YMI) THEN
3284 WRITE(LO,'(/1X,A,2E12.5)')
3285 & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3287 ELSE IF(YMIN1.GT.YMI) THEN
3288 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3289 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3290 & ' INSTEAD OF',YMIN1
3292 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3293 IF(YMIN2.LT.YMI) THEN
3294 WRITE(LO,'(/1X,A,2E12.5)')
3295 & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3297 ELSE IF(YMIN2.GT.YMI) THEN
3298 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3299 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3300 & ' INSTEAD OF',YMIN2
3303 C store COS of angular tagging range
3304 THMIC1 = COS(MAX(0.D0,THMIN1))
3305 THMAC1 = COS(MIN(THMAX1,PI))
3306 THMIC2 = COS(MAX(0.D0,THMIN2))
3307 THMAC2 = COS(MIN(THMAX2,PI))
3316 C debug: integrated photon flux
3318 if(IDEB(30).ge.1) then
3322 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3323 IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3324 & 'table of photon flux (trans/long side 1)',Max_tab
3326 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3327 if((1.D0-Y1).gt.1.D-8) then
3328 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3330 Q2low1 = 2.D0*Q2max1
3332 if(Q2low1.lt.Q2max1) then
3333 FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3334 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3335 FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3340 FLUXT = FLUXT + Y1*FFL
3341 FLUXL = FLUXL + Y1*FFT
3342 IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3346 WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3347 & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
3352 Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3353 Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3356 IF(ISWMDL(10).GE.2) THEN
3357 C long. and transversely polarized photons
3358 WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3359 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3360 & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3361 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3363 C transversely polarized photons only
3364 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3365 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3366 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3367 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3370 C initialize gamma-gamma event generator
3376 P1(3) = SQRT(EGAM**2-Q2LOW1)
3382 P2(3) = -SQRT(EGAM**2-Q2LOW2)
3388 C set min. energy for interpolation tables
3389 parmdl(19) = min(parmdl(19),ecmin)
3391 C initialize event gneration
3392 CALL PHO_SETPAR(1,22,0,0.D0)
3393 CALL PHO_SETPAR(2,22,0,0.D0)
3394 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3395 CALL PHO_PHIST(-1,SIGMAX)
3396 CALL PHO_LHIST(-1,SIGMAX)
3398 C generation of events, flux calculation
3402 ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3429 C generate NEVENT events (might be just 1 per call)
3431 else if(NEVENT.gt.0) then
3433 NITER = NITER+NEVENT
3439 ITRY_low = ITRY_low+1
3440 if(ITRY_low.eq.1000000) then
3442 ITRY_high = ITRY_high+1
3446 ITRW_low = ITRW_low+1
3447 if(ITRW_low.eq.1000000) then
3449 ITRW_high = ITRW_high+1
3452 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3453 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3454 IF(Y1*Y2.LT.ECFRAC) GOTO 175
3455 IF(ISWMDL(10).GE.2) THEN
3456 YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3457 YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3459 YEFF1 = 1.D0+(1.D0-Y1)**2
3460 YEFF2 = 1.D0+(1.D0-Y2)**2
3463 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3464 Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3465 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3466 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3468 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3470 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3471 IF(WGMAX.LT.WGH) THEN
3472 WRITE(LO,'(1X,A,4E12.5)')
3473 & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3475 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3477 C limit on Ecm_gg (app. cut, precise cut applied later)
3478 GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3479 if(GGECM2.lt.ECMIN2) goto 175
3482 IF(IPAMDL(174).EQ.1) THEN
3484 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3485 WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3486 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3491 IF(IPAMDL(174).EQ.1) THEN
3493 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3494 WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3495 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3505 C incoming electron 1
3508 PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3512 PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3513 PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3514 & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3515 IF(PT2.LT.0.D0) GOTO 175
3517 CALL PHO_SFECFE(SIF1,COF1)
3522 C outgoing electron 1
3525 PFIN(3,1) = PINI(3,1)-P1(3)
3526 PFIN(4,1) = PINI(4,1)-P1(4)
3528 C incoming electron 2
3531 PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3535 PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3536 PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3537 & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3538 IF(PT2.LT.0.D0) GOTO 175
3540 CALL PHO_SFECFE(SIF2,COF2)
3545 C outgoing electron 2
3548 PFIN(3,2) = PINI(3,2)-P2(3)
3549 PFIN(4,2) = PINI(4,2)-P2(4)
3554 GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3555 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3556 IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3557 GGECM = SQRT(GGECM2)
3559 C beam lepton detector acceptance
3562 CPFTHE = PFIN(3,1)/PFIN(4,1)
3564 IF(PFIN(4,1).GE.EEMIN1) THEN
3565 IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3569 CPFTHE = PFIN(3,2)/PFIN(4,2)
3571 IF(PFIN(4,2).GE.EEMIN2) THEN
3572 IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3575 C beam lepton taggers
3578 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3579 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3581 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3582 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3583 C single-tag inclusive
3584 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3586 C single-tag/anti-tag
3587 IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3594 PGAM(5,1) = -SQRT(Q2P1)
3599 PGAM(5,2) = -SQRT(Q2P2)
3602 IF(ISWMDL(10).GE.2) THEN
3603 WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3605 IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3610 WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3612 IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3617 K = 2*IGHEL(1)+IGHEL(2)+1
3618 IHETRY(K) = IHETRY(K)+1
3625 CALL PHO_PRESEL(5,IREJ)
3626 IF(IREJ.NE.0) GOTO 175
3629 C reweight according to LO photon emission diagrams (Budnev et al.)
3630 IF(IPAMDL(116).GE.1) THEN
3631 CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3632 WGFX = FLXQPM/FLXAPP
3633 if(WGFX.gt.1.D0) then
3634 WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3635 & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3636 & Y1,Y2,Q2P1,Q2P2,GGECM
3642 * EVWGHT(1) = MAX(WGFX,1.D0)
3643 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3644 IF(IREJ.NE.0) GOTO 150
3645 IF(ISWMDL(10).GE.2) THEN
3646 K = 2*IGHEL(1)+IGHEL(2)+1
3647 IHEAC1(K) = IHEAC1(K)+1
3650 C reweight according to QPM model (e+e- collider only)
3651 IF((KHDIR.GT.0).AND.
3652 & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3653 CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3654 WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3655 IF(DT_RNDM(WG).GT.WG) GOTO 150
3656 ELSE IF(IPAMDL(116).GE.1) THEN
3657 IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3661 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3662 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3664 PFPHI(1) = ATAN2(COF1,SIF1)
3665 PFPHI(2) = ATAN2(COF2,SIF2)
3672 Q21MIN = MIN(Q21MIN,Q2P1)
3673 Q22MIN = MIN(Q22MIN,Q2P2)
3674 Q21MAX = MAX(Q21MAX,Q2P1)
3675 Q22MAX = MAX(Q22MAX,Q2P2)
3676 AN1MIN = MIN(AN1MIN,PFTHE(1))
3677 AN2MIN = MIN(AN2MIN,PFTHE(2))
3678 AN1MAX = MAX(AN1MAX,PFTHE(1))
3679 AN2MAX = MAX(AN2MAX,PFTHE(2))
3680 YY1MIN = MIN(YY1MIN,Y1)
3681 YY2MIN = MIN(YY2MIN,Y2)
3682 YY1MAX = MAX(YY1MAX,Y1)
3683 YY2MAX = MAX(YY2MAX,Y2)
3684 Q21AVE = Q21AVE+Q2P1
3685 Q22AVE = Q22AVE+Q2P2
3686 Q21AV2 = Q21AV2+Q2P1*Q2P1
3687 Q22AV2 = Q22AV2+Q2P2*Q2P2
3688 IF(ISWMDL(10).GE.2) THEN
3689 K = 2*IGHEL(1)+IGHEL(2)+1
3690 IHEAC2(K) = IHEAC2(K)+1
3693 C external histograms
3694 CALL PHO_PHIST(1,HSWGHT(0))
3695 CALL PHO_LHIST(1,HSWGHT(0))
3698 C final cross section calculation and event generation summary
3700 else if(NEVENT.eq.-2) then
3704 DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3705 DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3706 WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3707 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3708 AY1 = AY1/DBLE(NITER)
3709 AYS1 = AYS1/DBLE(NITER)
3710 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3711 AY2 = AY2/DBLE(NITER)
3712 AYS2 = AYS2/DBLE(NITER)
3713 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3714 Q21AVE = Q21AVE/DBLE(NITER)
3715 Q21AV2 = Q21AV2/DBLE(NITER)
3716 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3717 Q22AVE = Q22AVE/DBLE(NITER)
3718 Q22AV2 = Q22AV2/DBLE(NITER)
3719 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3720 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3722 EE2 = SIGMAX*DBLE(NITER)/DITRY
3724 C output of statistics, histograms
3725 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3726 & '=========================================================',
3727 & ' ***** simulated cross section: ',WEIGHT,' mb *****',
3728 & '========================================================='
3729 WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3730 & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3731 WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3733 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
3735 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
3737 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
3739 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
3741 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
3743 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
3745 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
3747 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
3749 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3751 WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3752 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3754 IF(ISWMDL(10).GE.2) THEN
3755 WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3756 & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
3758 & 'accepted (1): ',IHEAC1,
3759 & 'accepted (2): ',IHEAC2
3762 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3764 CALL PHO_PHIST(-2,WEIGHT)
3765 CALL PHO_LHIST(-2,WEIGHT)
3767 WRITE(LO,'(1X,A,I4)')
3768 & 'PHO_GGEPEM: no output of histograms',NITER
3775 CDECK ID>, PHO_WGEPEM
3776 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3777 C**********************************************************************
3779 C calculate cross section weights for
3780 C fully differential equivalent (improved) photon approximation
3782 C fully differential QPM model with exact one-photon exchange graphs
3784 C (unpolarized lepton beams)
3786 C input: IMODE 0 flux calculation only
3787 C 1 flux folded with QPM cross section
3788 C /POFSRC/ photon and electron momenta
3789 C /POPRCS/ process type
3790 C /POCKIN/ kinematics of hard scattering
3792 C output: WGHAPP weight of event according to approximation
3793 C WGHQPM weight of event according to one-photon exchange
3795 C**********************************************************************
3801 DOUBLE PRECISION WGHAPP,WGHQPM
3804 C input/output channels
3806 COMMON /POINOU/ LI,LO
3807 C event debugging information
3809 PARAMETER (NMAXD=100)
3810 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3811 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3812 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3813 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3814 C model switches and parameters
3816 INTEGER ISWMDL,IPAMDL
3817 DOUBLE PRECISION PARMDL
3818 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3820 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3821 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3822 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3823 C gamma-lepton or gamma-hadron vertex information
3824 INTEGER IGHEL,IDPSRC,IDBSRC
3825 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3826 & RADSRC,AMSRC,GAMSRC
3827 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3828 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3829 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3830 C general process information
3831 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3832 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3833 C data on most recent hard scattering
3834 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3835 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3836 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3837 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3838 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3839 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3840 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3841 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3842 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3843 C hard scattering parameters used for most recent hard interaction
3845 DOUBLE PRECISION ALQCD2,BQCD
3846 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3847 C currently activated parton density parametrizations
3849 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3850 DOUBLE PRECISION PDFLAM,PDFQ2M
3851 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3852 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3854 C standard particle data interface
3857 PARAMETER (NMXHEP=4000)
3859 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3860 DOUBLE PRECISION PHEP,VHEP
3861 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3862 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3864 C extension to standard particle data interface (PHOJET specific)
3865 INTEGER IMPART,IPHIST,ICOLOR
3866 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3868 DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3869 & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3870 & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3871 & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3872 & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3873 & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3874 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3876 INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3878 DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3879 DIMENSION HELFLX(6),SIGQPM(6)
3884 C strict pt cutoff after putting partons on mass shell,
3885 C calculated in gamma-gamma CMS
3886 if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3887 if(PTfin.lt.PTwant) then
3888 if(ipamdl(121).gt.1) return
3889 if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3893 C cross section of sampled event (approximate treatment)
3897 XM2(K) = AMSRC(K)**2
3898 IF(abs(IGHEL(K)).EQ.1) THEN
3899 WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3900 & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3902 WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3910 C direct or single-resolved gam-gam interaction
3911 IF((IMODE.GE.1).AND.
3912 & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3915 C determine final state partons
3917 IF(ISTHEP(I).EQ.25) GOTO 110
3919 WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3920 & 'inconsistent process information (MSPR)',MSPR
3924 C final state flavors
3925 IPFL1 = ABS(IDHEP(IPOS+3))
3926 IPFL2 = ABS(IDHEP(IPOS+4))
3928 C calculate alpha-em
3929 ALPHA1 = pho_alphae(QQAL)
3932 ALPHA2 = PHO_ALPHAS(QQAL,3)
3934 C LO matrix element (8 pi s dsig/dt)
3935 * QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3938 WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3939 & 'invalid hard process - flavor combination',
3940 & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3943 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3945 ELSE IF(MSPR.EQ.11) THEN
3946 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3948 ELSE IF(MSPR.EQ.12) THEN
3949 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3951 ELSE IF(MSPR.EQ.13) THEN
3952 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3954 ELSE IF(MSPR.EQ.14) THEN
3955 WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3960 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3961 WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3963 C full leading-order QPM prediction (Budnev et al.)
3965 C full two-gamma flux
3967 P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3968 & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3969 P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3970 & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3971 Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3972 & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3973 P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3974 & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3976 P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3977 P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3979 XTM1 = 2.D0*P1Q2-Q1Q2
3980 XTM2 = 2.D0*P2Q1-Q1Q2
3981 XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3982 XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3983 YCAP = P1P2**2-XM2(1)*XM2(2)
3984 CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3986 RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3987 RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
3988 RHO100 = XTM1**2/XCAP-1.D0
3989 RHO200 = XTM2**2/XCAP-1.D0
3990 RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
3991 RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
3992 SS = 2.D0*P1P2+XM2(1)+XM2(2)
3994 HELFLX(1) = 4.D0*RHO1PP*RHO2PP
3996 HELFLX(3) = 2.D0*RHO1PP*RHO200
3997 HELFLX(4) = 2.D0*RHO100*RHO2PP
3998 HELFLX(5) = RHO100*RHO200
4001 C only flux calculation
4004 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4006 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4008 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4010 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4012 ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
4015 WRITE(LO,'(/1X,A,2I3)')
4016 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4017 WRITE(LO,'(1X,A,I12)')
4018 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4022 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4023 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4024 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4028 C flux folded with cross section
4029 C polarized, leading order gam gam --> q qbar cross sections
4034 C momenta of produced parton pair
4044 C direct photon-photon interaction
4045 XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4046 & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4047 & +(PGAM(3,1)-XK1(3))**2
4048 XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4049 & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4050 & +(PGAM(3,1)-XK2(3))**2
4052 AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4053 BB = CC**2-XKAP*XKAM
4054 DD = CC**2-GQ2(1)*GQ2(2)
4055 RR = -XQ2+W2*AA/(4.D0*DD)
4058 FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4061 C single-resolved photon-hadron interactions
4062 C Mandelstam variables
4064 TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4065 & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4066 UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4067 & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4069 TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4070 & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4071 UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4072 & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4079 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4080 IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4090 SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4091 & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4092 & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4093 & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4094 & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4095 & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4096 & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4097 & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4098 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4099 ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4107 SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4108 & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4109 & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4110 & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4111 & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4112 & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4113 & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4114 & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4115 & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4116 & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4117 & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4118 & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4119 & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4120 & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4121 & (Q2-SP-TP+XQ2)**2)
4122 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4123 ELSE IF(MSPR.EQ.14) THEN
4124 SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4125 SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4126 SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4127 & -2.D0*XKAP*XKAM*AA
4128 SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4129 SIGQPM(2) = SWPPMM*FAC
4130 WEIGHT = HELFLX(1)*SIGQPM(1)
4131 & +HELFLX(2)*SIGQPM(2)
4133 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4138 SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4139 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4140 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4141 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4142 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4143 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4144 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4145 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4146 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4147 ELSE IF(MSPR.EQ.13) THEN
4151 SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4152 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4153 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4154 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4155 ELSE IF(MSPR.EQ.14) THEN
4156 SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4157 & -XKAP*XKAM*Q1KK**2)/DD
4158 SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4159 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4160 & *SQRT(GQ2(1)*GQ2(2))/DD
4161 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4162 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4163 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4164 & *SQRT(GQ2(1)*GQ2(2))/DD
4165 SIGQPM(3) = SWP0P0*FAC
4166 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4167 WEIGHT = HELFLX(3)*SIGQPM(3)
4168 & +HELFLX(6)*SIGQPM(6)/2.D0
4170 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4175 SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4176 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4177 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4178 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4179 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4180 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4181 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4182 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4183 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4184 ELSE IF(MSPR.EQ.11) THEN
4188 SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4189 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4190 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4191 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4192 ELSE IF(MSPR.EQ.14) THEN
4193 SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4194 & -XKAP*XKAM*Q2KK**2)/DD
4195 SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4196 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4197 & *SQRT(GQ2(1)*GQ2(2))/DD
4198 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4199 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4200 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4201 & *SQRT(GQ2(1)*GQ2(2))/DD
4202 SIGQPM(4) = SW0P0P*FAC
4203 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4204 WEIGHT = HELFLX(4)*SIGQPM(4)
4205 & +HELFLX(6)*SIGQPM(6)/2.D0
4207 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4209 SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4210 SIGQPM(5) = SW0000*FAC
4211 WEIGHT = HELFLX(5)*SIGQPM(5)
4214 WRITE(LO,'(/1X,A,2I3)')
4215 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4216 WRITE(LO,'(1X,A,I12)')
4217 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4221 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4223 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4224 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4230 CDECK ID>, PHO_GGBLSR
4231 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4232 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4233 C***********************************************************************
4235 C interface to call PHOJET (variable energy run) for
4236 C gamma-gamma collisions via laser backscattering
4238 C input: EE1 lab. system energy of electron/positron 1
4239 C EE2 lab. system energy of electron/positron 2
4240 C NEVENT number of events to generate
4241 C Pl_lam_1/2 product of electron and photon pol.
4242 C X_1/2 standard X parameter
4243 C rho ratio of distance to conversion point and
4244 C transverse beam size
4245 C A ellipticity of electon beam
4247 C (see Ginzburg & Kotkin hep-ph/9905462)
4250 C YMIN1 lower limit of Y1
4251 C (energy fraction taken by photon from electron)
4252 C YMAX1 upper limit of Y1
4253 C YMIN2 lower limit of Y2
4254 C (energy fraction taken by photon from electron)
4255 C YMAX2 upper limit of Y2
4257 C***********************************************************************
4258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4261 PARAMETER ( PI = 3.14159265359D0 )
4263 C input/output channels
4265 COMMON /POINOU/ LI,LO
4266 C event debugging information
4268 PARAMETER (NMAXD=100)
4269 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4270 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4271 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4272 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4273 C photon flux kinematics and cuts
4274 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4275 & YMIN1,YMAX1,YMIN2,YMAX2,
4276 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4277 & THMIN1,THMAX1,THMIN2,THMAX2
4279 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4280 & YMIN1,YMAX1,YMIN2,YMAX2,
4281 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4282 & THMIN1,THMAX1,THMIN2,THMAX2,
4284 C gamma-lepton or gamma-hadron vertex information
4285 INTEGER IGHEL,IDPSRC,IDBSRC
4286 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4287 & RADSRC,AMSRC,GAMSRC
4288 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4289 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4290 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4291 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4292 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4293 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4294 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4295 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4296 C event weights and generated cross section
4297 INTEGER IPOWGC,ISWCUT,IVWGHT
4298 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4299 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4300 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4302 parameter (N_dim=100)
4303 dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4304 & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4305 & Xgrid(96),Wgrid(96)
4307 DIMENSION P1(4),P2(4)
4311 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4313 YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4314 YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4315 IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4316 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4317 & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
4325 C initialize sampling
4328 DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4329 DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4331 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4332 & 'PHO_GGBLSR: table of photon flux ',Max_tab
4336 y1 = YMIN1+DELY1*DBLE(I-1)
4337 r1 = y1/(X_1*(1.D0-y1))
4339 F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4340 & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4342 y2 = YMIN2+DELY2*DBLE(I-1)
4343 r2 = y2/(X_2*(1.D0-y2))
4345 F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4346 & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4348 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4349 & y1,F_inp_1(i),y2,F_inp_2(i)
4353 call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4354 call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4356 C initialize event generator
4370 CALL PHO_SETPAR(1,22,0,0.D0)
4371 CALL PHO_SETPAR(2,22,0,0.D0)
4372 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4373 CALL PHO_PHIST(-1,SIGMAX)
4374 CALL PHO_LHIST(-1,SIGMAX)
4376 C generation of events
4391 call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4392 call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4394 g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4395 g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4396 if(abs(1.D0-A).lt.1.D-3) then
4397 v = rho**2/4.D0*g_1*g_2
4398 Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4401 call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4403 fac = rho**2/(4.D0*(1.D0+A2))
4410 & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4411 & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4412 & *Wgrid(i1)*Wgrid(i2)
4418 IF(Wght.GT.1.D0) THEN
4419 WRITE(LO,'(1X,A,5E11.4)')
4420 & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4422 IF(DT_RNDM(dum).GT.Wght) GOTO 175
4433 C incoming electron 1
4439 C outgoing electron 1
4440 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4441 Q2E = Q2P1/(4.D0*EE1)
4443 CALL PHO_SFECFE(SIF,COF)
4452 P1(3) = PINI(3,1)-PFIN(3,1)
4453 P1(4) = PINI(4,1)-PFIN(4,1)
4454 C incoming electron 2
4460 C outgoing electron 2
4461 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4462 Q2E = Q2P2/(4.D0*EE2)
4464 CALL PHO_SFECFE(SIF,COF)
4467 PFIN(3,2) = -E1Y+Q2E
4473 P2(3) = PINI(3,2)-PFIN(3,2)
4474 P2(4) = PINI(4,2)-PFIN(4,2)
4476 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4477 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4478 IF(GGECM.LT.0.1D0) GOTO 175
4480 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4496 CALL PHO_PRESEL(5,IREJ)
4497 IF(IREJ.NE.0) GOTO 175
4499 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4500 IF(IREJ.NE.0) GOTO 150
4508 CALL PHO_PHIST(1,HSWGHT(0))
4509 CALL PHO_LHIST(1,HSWGHT(0))
4512 WGY = DBLE(ITRY)/DBLE(ITRW)
4513 AY1 = AY1/DBLE(NITER)
4514 AYS1 = AYS1/DBLE(NITER)
4515 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4516 AY2 = AY2/DBLE(NITER)
4517 AYS2 = AYS2/DBLE(NITER)
4518 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4519 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4520 C output of statistics, histograms
4521 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4522 &'=========================================================',
4523 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4524 &'========================================================='
4525 WRITE(LO,'(//1X,A,3I10)')
4526 & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4527 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4529 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4530 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4532 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4534 CALL PHO_PHIST(-2,WEIGHT)
4535 CALL PHO_LHIST(-2,WEIGHT)
4537 WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4542 CDECK ID>, pho_samp1d
4543 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4544 C***********************************************************************
4546 C Monte Carlo sampling from arbitrary 1d distribution
4547 C (linear interpolation to improve reproduction of initial function)
4549 C input: Imode -1 initialization
4550 C 1 sampling (after initialization)
4551 C X_inp(N_dim) array with x values
4552 C F_inp(N_dim) array with function values
4553 C F_int(N_dim) array with integral
4555 C output: X_out sampled value (Imode=1)
4559 C***********************************************************************
4563 C input/output channels
4565 COMMON /POINOU/ LI,LO
4568 double precision X_inp,F_inp,F_int,X_out
4569 dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4573 double precision dum,xi,a,b
4575 C external functions
4576 double precision DT_RNDM
4579 if(Imode.eq.-1) then
4585 F_int(i) = F_int(i-1)
4586 & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4589 else if(Imode.eq.1) then
4591 C sample from previously calculated integral
4593 xi = DT_RNDM(dum)*F_int(N_dim)
4596 if(xi.lt.F_int(i)) then
4597 a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4598 b = F_inp(i)-a*X_inp(i)
4599 xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4600 X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4604 X_out = X_inp(N_dim)
4608 C invalid option Imode
4610 WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4617 CDECK ID>, pho_ExpBessI0
4618 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4619 C**********************************************************************
4621 C Bessel Function I0 times exponential function from neg. arg.
4622 C (defined for pos. arguments only)
4624 C**********************************************************************
4625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4629 IF (AX .LT. 3.75D0) THEN
4632 & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4633 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4637 & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4638 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4639 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4640 & +Y*0.392377D-2))))))))
4645 CDECK ID>, PHO_GGBEAM
4646 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4647 C**********************************************************************
4649 C interface to call PHOJET (variable energy run) for
4650 C gamma-gamma collisions via beamstrahlung
4652 C input: EE LAB system energy of electron/positron
4653 C YPSI beamstrahlung parameter
4654 C SIGX,Y transverse bunch dimensions
4655 C SIGZ longitudinal bunch dimension
4656 C AEB number of electrons/positrons in a bunch
4657 C NEVENT number of events to generate
4659 C YMIN1 lower limit of Y
4660 C (energy fraction taken by photon from electron)
4661 C YMAX1 upper cutoff for Y, necessary to avoid
4664 C**********************************************************************
4665 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4668 PARAMETER ( DEPS = 1.D-20,
4669 & PI = 3.14159265359D0 )
4671 C input/output channels
4673 COMMON /POINOU/ LI,LO
4674 C event debugging information
4676 PARAMETER (NMAXD=100)
4677 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4678 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4679 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4680 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4681 C photon flux kinematics and cuts
4682 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4683 & YMIN1,YMAX1,YMIN2,YMAX2,
4684 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4685 & THMIN1,THMAX1,THMIN2,THMAX2
4687 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4688 & YMIN1,YMAX1,YMIN2,YMAX2,
4689 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4690 & THMIN1,THMAX1,THMIN2,THMAX2,
4692 C gamma-lepton or gamma-hadron vertex information
4693 INTEGER IGHEL,IDPSRC,IDBSRC
4694 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4695 & RADSRC,AMSRC,GAMSRC
4696 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4697 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4698 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4699 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4700 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4701 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4702 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4703 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4704 C event weights and generated cross section
4705 INTEGER IPOWGC,ISWCUT,IVWGHT
4706 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4707 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4708 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4710 PARAMETER (Max_tab=100)
4711 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4714 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4722 C table of flux function, log interpolation
4723 IF(YPSI.LE.0.D0) THEN
4724 YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4726 WRITE(LO,'(/1X,A,E12.4)')
4727 & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4728 WRITE(LO,'(/1X,A,2E12.4)')
4729 & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4733 GAOT = 2.6789385347D0
4735 WW = 1.D0/(6.D0*SQRT(AKAP))
4736 ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4737 & *YPSI/SQRT(1.D0+YPSI**TT)
4740 YMAX = MIN(YMAX1,0.9D0)
4742 TABYL(0) = LOG(YMIN)
4743 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4745 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4746 & 'PHO_GGBEAM: table of photon flux',Max_tab
4748 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4749 GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4750 FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4751 & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4752 & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4753 TABCU(I) = TABCU(I-1)+FF*Y
4756 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4759 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4760 & 'PHO_GGBEAM: integrated flux (one side):',FLUX
4776 CALL PHO_SETPAR(1,22,0,0.D0)
4777 CALL PHO_SETPAR(2,22,0,0.D0)
4778 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4779 CALL PHO_PHIST(-1,SIGMAX)
4780 CALL PHO_LHIST(-1,SIGMAX)
4782 C generation of events
4796 XI = DT_RNDM(AY1)*TABCU(Max_tab)
4798 IF(TABCU(K).GE.XI) THEN
4799 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4806 XI = DT_RNDM(AY2)*TABCU(Max_tab)
4808 IF(TABCU(K).GE.XI) THEN
4809 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4823 C incoming electron 1
4829 C outgoing electron 1
4830 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4831 Q2E = Q2P1/(4.D0*EE1)
4833 CALL PHO_SFECFE(SIF,COF)
4842 P1(3) = PINI(3,1)-PFIN(3,1)
4843 P1(4) = PINI(4,1)-PFIN(4,1)
4844 C incoming electron 2
4850 C outgoing electron 2
4851 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4852 Q2E = Q2P2/(4.D0*EE2)
4854 CALL PHO_SFECFE(SIF,COF)
4857 PFIN(3,2) = -E1Y+Q2E
4863 P2(3) = PINI(3,2)-PFIN(3,2)
4864 P2(4) = PINI(4,2)-PFIN(4,2)
4866 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4867 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4868 IF(GGECM.LT.0.1D0) GOTO 175
4870 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4886 CALL PHO_PRESEL(5,IREJ)
4887 IF(IREJ.NE.0) GOTO 175
4889 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4890 IF(IREJ.NE.0) GOTO 150
4899 CALL PHO_PHIST(1,HSWGHT(0))
4900 CALL PHO_LHIST(1,HSWGHT(0))
4903 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4904 AY1 = AY1/DBLE(NITER)
4905 AYS1 = AYS1/DBLE(NITER)
4906 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4907 AY2 = AY2/DBLE(NITER)
4908 AYS2 = AYS2/DBLE(NITER)
4909 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4910 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4911 C output of statistics, histograms
4912 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4913 &'=========================================================',
4914 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4915 &'========================================================='
4916 WRITE(LO,'(//1X,A,2I10)')
4917 & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4918 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4920 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4921 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4923 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4925 CALL PHO_PHIST(-2,WEIGHT)
4926 CALL PHO_LHIST(-2,WEIGHT)
4928 WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4933 CDECK ID>, PHO_GGHIOF
4934 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4935 C**********************************************************************
4937 C interface to call PHOJET (variable energy run) for
4938 C gamma-gamma collisions via heavy ions (form factor approach)
4940 C input: EEN LAB system energy per nucleon
4941 C NA atomic number of ion/hadron
4942 C NZ charge number of ion/hadron
4943 C NEVENT number of events to generate
4945 C YMIN1,2 lower limit of Y
4946 C (energy fraction taken by photon from hadron)
4947 C YMAX1,2 upper cutoff for Y, necessary to avoid
4949 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4950 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4951 C corrected according size of hadron)
4953 C currently implemented approximation similar to:
4954 C E.Papageorgiu PhysLettB250(1990)155
4956 C**********************************************************************
4957 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4960 PARAMETER ( PI = 3.14159265359D0 )
4962 C input/output channels
4964 COMMON /POINOU/ LI,LO
4965 C model switches and parameters
4967 INTEGER ISWMDL,IPAMDL
4968 DOUBLE PRECISION PARMDL
4969 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4970 C event debugging information
4972 PARAMETER (NMAXD=100)
4973 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4974 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4975 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4976 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4977 C photon flux kinematics and cuts
4978 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4979 & YMIN1,YMAX1,YMIN2,YMAX2,
4980 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4981 & THMIN1,THMAX1,THMIN2,THMAX2
4983 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4984 & YMIN1,YMAX1,YMIN2,YMAX2,
4985 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4986 & THMIN1,THMAX1,THMIN2,THMAX2,
4988 C gamma-lepton or gamma-hadron vertex information
4989 INTEGER IGHEL,IDPSRC,IDBSRC
4990 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4991 & RADSRC,AMSRC,GAMSRC
4992 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4993 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4994 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4995 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4996 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4997 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4998 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4999 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5000 C event weights and generated cross section
5001 INTEGER IPOWGC,ISWCUT,IVWGHT
5002 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5003 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5004 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5006 DIMENSION P1(4),P2(4),BIMP(2,2)
5009 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5010 & '--------------------------------------'
5011 C hadron size and mass
5013 HIMASS = DBLE(NA)*0.938D0
5015 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5016 ALPHA = DBLE(NZ**2)/137.D0
5017 C correct Q2MAX1,2 according to hadron size
5018 Q2MAXH = 2.D0/HIRADI**2
5019 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
5020 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
5021 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
5022 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5023 C total hadron / heavy ion energy
5033 C kinematic limitations
5034 YMI = (ECMIN/(2.D0*EE))**2
5035 IF(YMIN1.LT.YMI) THEN
5036 WRITE(LO,'(/1X,A,2E12.5)')
5037 & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5039 ELSE IF(YMIN1.GT.YMI) THEN
5040 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5041 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5042 & ' INSTEAD OF',YMIN1
5044 IF(YMIN2.LT.YMI) THEN
5045 WRITE(LO,'(/1X,A,2E12.5)')
5046 & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5048 ELSE IF(YMIN2.GT.YMI) THEN
5049 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5050 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5051 & ' INSTEAD OF',YMIN2
5053 C kinematic limitation
5054 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5055 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5057 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5058 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5059 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5060 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5062 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5064 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5066 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5068 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5070 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5071 IF(Q2LOW1.GE.Q2MAX1) THEN
5072 WRITE(LO,'(/1X,A,2E12.4)')
5073 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5076 IF(Q2LOW2.GE.Q2MAX2) THEN
5077 WRITE(LO,'(/1X,A,2E12.4)')
5078 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5081 C hadron numbers set to 0
5093 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5095 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5096 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5097 IF(Q2LOW1.GE.Q2MAX1) THEN
5098 WRITE(LO,'(/1X,A,2E12.4)')
5099 & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5100 YMAX1 = MIN(Y1,YMAX1)
5110 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5112 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5113 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5114 IF(Q2LOW2.GE.Q2MAX2) THEN
5115 WRITE(LO,'(/1X,A,2E12.4)')
5116 & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5117 YMAX2 = MIN(Y1,YMAX2)
5122 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5123 IF(YMI.GT.YMIN1) THEN
5124 WRITE(LO,'(/1X,A,2E12.4)')
5125 & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5128 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5129 IF(YMI.GT.YMIN2) THEN
5130 WRITE(LO,'(/1X,A,2E12.4)')
5131 & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5141 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5143 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5144 & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5146 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5147 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5148 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5149 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5151 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5154 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5155 & 'PHO_GGHIOF: integrated flux (one side):',FLUX
5157 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5158 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5161 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5162 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5163 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5164 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5178 CALL PHO_SETPAR(1,22,0,0.D0)
5179 CALL PHO_SETPAR(2,22,0,0.D0)
5180 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5181 CALL PHO_PHIST(-1,SIGMAX)
5182 CALL PHO_LHIST(-1,SIGMAX)
5184 C generation of events, flux calculation
5186 ECFRAC = ECMIN**2/(4.D0*EE*EE)
5212 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5213 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5214 IF(Y1*Y2.LT.ECFRAC) GOTO 175
5216 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5217 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5218 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5219 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5220 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5221 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5222 WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5223 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5224 & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5225 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5226 IF(WGMAX.LT.WGH) THEN
5227 WRITE(LO,'(1X,A,4E12.5)')
5228 & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5230 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5232 IF(IPAMDL(174).EQ.1) THEN
5233 YEFF = 1.D0+(1.D0-Y1)**2
5235 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5236 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5237 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5241 IF(IPAMDL(174).EQ.1) THEN
5242 YEFF = 1.D0+(1.D0-Y2)**2
5244 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5245 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5246 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5251 GAIMP(1) = 1.D0/SQRT(Q2P1)
5252 GAIMP(2) = 1.D0/SQRT(Q2P2)
5253 C form factor (squared)
5255 IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5257 IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5258 IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5259 C do the hadrons overlap?
5260 IF(ISWMDL(26).GT.0) THEN
5262 CALL PHO_SFECFE(SIF,COF)
5263 BIMP(1,K) = SIF*GAIMP(K)
5264 BIMP(2,K) = COF*GAIMP(K)
5266 BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5267 & +(BIMP(2,1)-BIMP(2,2))**2)
5268 IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5284 YQ2 = SQRT((1.D0-Y1)*Q2P1)
5285 Q2E = Q2P1/(4.D0*EE)
5287 CALL PHO_SFECFE(SIF,COF)
5293 PFPHI(1) = ATAN2(COF,SIF)
5294 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5298 P1(3) = PINI(3,1)-PFIN(3,1)
5299 P1(4) = PINI(4,1)-PFIN(4,1)
5307 YQ2 = SQRT((1.D0-Y2)*Q2P2)
5308 Q2E = Q2P2/(4.D0*EE)
5310 CALL PHO_SFECFE(SIF,COF)
5313 PFIN(3,2) = -E1Y+Q2E
5316 PFPHI(2) = ATAN2(COF,SIF)
5317 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5321 P2(3) = PINI(3,2)-PFIN(3,2)
5322 P2(4) = PINI(4,2)-PFIN(4,2)
5324 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5325 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5326 IF(GGECM.LT.0.1D0) GOTO 175
5328 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5334 PGAM(5,1) = -SQRT(Q2P1)
5339 PGAM(5,2) = -SQRT(Q2P2)
5344 CALL PHO_PRESEL(5,IREJ)
5345 IF(IREJ.NE.0) GOTO 175
5347 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5348 IF(IREJ.NE.0) GOTO 150
5355 Q21MIN = MIN(Q21MIN,Q2P1)
5356 Q22MIN = MIN(Q22MIN,Q2P2)
5357 Q21MAX = MAX(Q21MAX,Q2P1)
5358 Q22MAX = MAX(Q22MAX,Q2P2)
5359 YY1MIN = MIN(YY1MIN,Y1)
5360 YY2MIN = MIN(YY2MIN,Y2)
5361 YY1MAX = MAX(YY1MAX,Y1)
5362 YY2MAX = MAX(YY2MAX,Y2)
5363 Q21AVE = Q21AVE+Q2P1
5364 Q22AVE = Q22AVE+Q2P2
5365 Q21AV2 = Q21AV2+Q2P1*Q2P1
5366 Q22AV2 = Q22AV2+Q2P2*Q2P2
5368 CALL PHO_PHIST(1,HSWGHT(0))
5369 CALL PHO_LHIST(1,HSWGHT(0))
5372 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5373 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5374 AY1 = AY1/DBLE(NITER)
5375 AYS1 = AYS1/DBLE(NITER)
5376 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5377 AY2 = AY2/DBLE(NITER)
5378 AYS2 = AYS2/DBLE(NITER)
5379 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5380 Q21AVE = Q21AVE/DBLE(NITER)
5381 Q21AV2 = Q21AV2/DBLE(NITER)
5382 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5383 Q22AVE = Q22AVE/DBLE(NITER)
5384 Q22AV2 = Q22AV2/DBLE(NITER)
5385 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5386 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5387 C output of statistics, histograms
5388 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5389 &'=========================================================',
5390 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5391 &'========================================================='
5392 WRITE(LO,'(//1X,A,3I10)')
5393 & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5394 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5396 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5398 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5400 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5402 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5404 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
5406 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
5408 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
5410 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
5413 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5415 CALL PHO_PHIST(-2,WEIGHT)
5416 CALL PHO_LHIST(-2,WEIGHT)
5418 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5423 CDECK ID>, PHO_GGHIOG
5424 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5425 C**********************************************************************
5427 C interface to call PHOJET (variable energy run) for
5428 C gamma-gamma collisions via heavy ions (geometrical approach)
5431 C input: EEN LAB system energy per nucleon
5432 C NA atomic number of ion/hadron
5433 C NZ charge number of ion/hadron
5434 C NEVENT number of events to generate
5436 C YMIN1,2 lower limit of Y
5437 C (energy fraction taken by photon from hadron)
5438 C YMAX1,2 upper cutoff for Y, necessary to avoid
5441 C currently implemented approximation similar to:
5444 C**********************************************************************
5445 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5448 PARAMETER ( DEPS = 1.D-20,
5449 & PI = 3.14159265359D0 )
5451 C input/output channels
5453 COMMON /POINOU/ LI,LO
5454 C event debugging information
5456 PARAMETER (NMAXD=100)
5457 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5458 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5459 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5460 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5461 C photon flux kinematics and cuts
5462 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5463 & YMIN1,YMAX1,YMIN2,YMAX2,
5464 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5465 & THMIN1,THMAX1,THMIN2,THMAX2
5467 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5468 & YMIN1,YMAX1,YMIN2,YMAX2,
5469 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5470 & THMIN1,THMAX1,THMIN2,THMAX2,
5472 C gamma-lepton or gamma-hadron vertex information
5473 INTEGER IGHEL,IDPSRC,IDBSRC
5474 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5475 & RADSRC,AMSRC,GAMSRC
5476 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5477 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5478 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5479 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5480 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5481 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5482 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5483 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5484 C event weights and generated cross section
5485 INTEGER IPOWGC,ISWCUT,IVWGHT
5486 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5487 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5488 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5490 PARAMETER (Max_tab=100)
5491 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5494 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5495 & '---------------------------------------'
5496 C hadron size and mass
5498 HIMASS = DBLE(NA)*0.938D0
5500 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5501 ALPHA = DBLE(NZ**2)/137.D0
5502 C total hadron / heavy ion energy
5512 C kinematic limitations
5513 YMI = (ECMIN/(2.D0*EE))**2
5514 IF(YMIN1.LT.YMI) THEN
5515 WRITE(LO,'(/1X,A,2E12.5)')
5516 & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5518 ELSE IF(YMIN1.GT.YMI) THEN
5519 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5520 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5521 & ' INSTEAD OF',YMIN1
5523 IF(YMIN2.LT.YMI) THEN
5524 WRITE(LO,'(/1X,A,2E12.5)')
5525 & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5527 ELSE IF(YMIN2.GT.YMI) THEN
5528 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5529 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5530 & ' INSTEAD OF',YMIN2
5533 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5534 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5535 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5536 WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
5537 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5539 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5541 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5543 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5544 C hadron numbers set to 0
5549 C table of flux function, log interpolation
5552 YMAX = MIN(YMAX,0.9999999D0)
5553 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5554 TABYL(0) = LOG(YMIN)
5557 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5559 XI = WG*HIRADI/GAMMA
5560 FF = ALPHA*PHO_GGFLCL(XI)/Y
5561 FFMAX = MAX(FF,FFMAX)
5562 IF(FF.LT.1.D-10*FFMAX) THEN
5563 WRITE(LO,'(/1X,A,2E12.4)')
5564 & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5565 YMAX1 = MIN(Y,YMAX1)
5572 YMAX = MIN(YMAX,0.9999999D0)
5573 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5574 TABYL(0) = LOG(YMIN)
5577 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5579 XI = WG*HIRADI/GAMMA
5580 FF = ALPHA*PHO_GGFLCL(XI)/Y
5581 FFMAX = MAX(FF,FFMAX)
5582 IF(FF.LT.1.D-10*FFMAX) THEN
5583 WRITE(LO,'(/1X,A,2E12.4)')
5584 & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5585 YMAX2 = MIN(Y,YMAX2)
5590 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5591 IF(YMI.GT.YMIN1) THEN
5592 WRITE(LO,'(/1X,A,2E12.4)')
5593 & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5596 YMAX1 = MIN(YMAX,YMAX1)
5597 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5598 IF(YMI.GT.YMIN2) THEN
5599 WRITE(LO,'(/1X,A,2E12.4)')
5600 & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5606 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5608 TABYL(0) = LOG(YMIN)
5610 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5611 & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5613 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5615 XI = WG*HIRADI/GAMMA
5616 FF = ALPHA*PHO_GGFLCL(XI)/Y
5617 FFMAX = MAX(FF,FFMAX)
5618 TABCU(I) = TABCU(I-1)+FF*Y
5621 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5624 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5625 & 'PHO_GGHIOG: integrated flux (one side):',FLUX
5640 CALL PHO_SETPAR(1,22,0,0.D0)
5641 CALL PHO_SETPAR(2,22,0,0.D0)
5642 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5643 CALL PHO_PHIST(-1,SIGMAX)
5644 CALL PHO_LHIST(-1,SIGMAX)
5646 C generation of events
5664 XI = DT_RNDM(AY1)*TABCU(Max_tab)
5666 IF(TABCU(K).GE.XI) THEN
5667 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5674 XI = DT_RNDM(AY2)*TABCU(Max_tab)
5676 IF(TABCU(K).GE.XI) THEN
5677 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5690 C incoming electron 1
5696 C outgoing electron 1
5706 P1(3) = PINI(3,1)-PFIN(3,1)
5707 P1(4) = PINI(4,1)-PFIN(4,1)
5708 C incoming electron 2
5714 C outgoing electron 2
5724 P2(3) = PINI(3,2)-PFIN(3,2)
5725 P2(4) = PINI(4,2)-PFIN(4,2)
5727 GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5728 IF(GGECM.LT.0.1D0) GOTO 175
5730 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5741 C impact parameter constraints
5742 XI1 = P1(4)*HIRADI/GAMMA
5743 XI2 = P2(4)*HIRADI/GAMMA
5744 FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5745 FCORR = PHO_GGFLCR(HIRADI)
5746 WGX = (FLX-FCORR)/FLX
5747 IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5752 CALL PHO_PRESEL(5,IREJ)
5753 IF(IREJ.NE.0) GOTO 175
5755 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5756 IF(IREJ.NE.0) GOTO 150
5763 YY1MIN = MIN(YY1MIN,Y1)
5764 YY2MIN = MIN(YY2MIN,Y2)
5765 YY1MAX = MAX(YY1MAX,Y1)
5766 YY2MAX = MAX(YY2MAX,Y2)
5768 CALL PHO_PHIST(1,HSWGHT(0))
5769 CALL PHO_LHIST(1,HSWGHT(0))
5772 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5773 AY1 = AY1/DBLE(NITER)
5774 AYS1 = AYS1/DBLE(NITER)
5775 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5776 AY2 = AY2/DBLE(NITER)
5777 AYS2 = AYS2/DBLE(NITER)
5778 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5779 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5780 C output of statistics, histograms
5781 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5782 &'=========================================================',
5783 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5784 &'========================================================='
5785 WRITE(LO,'(//1X,A,3I12)')
5786 & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5787 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5789 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5791 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5793 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5795 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5799 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5801 CALL PHO_PHIST(-2,WEIGHT)
5802 CALL PHO_LHIST(-2,WEIGHT)
5804 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5809 CDECK ID>, PHO_GGFLCL
5810 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5811 C*********************************************************************
5813 C semi-classical photon flux (geometrical model)
5815 C*********************************************************************
5816 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5819 PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5820 & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5824 CDECK ID>, PHO_GGFLCR
5825 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5826 C*********************************************************************
5828 C semi-classical photon flux correction due to
5829 C overlap in impact parameter space (geometrical model)
5831 C*********************************************************************
5832 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5835 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5837 C input/output channels
5839 COMMON /POINOU/ LI,LO
5840 C gamma-lepton or gamma-hadron vertex information
5841 INTEGER IGHEL,IDPSRC,IDBSRC
5842 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5843 & RADSRC,AMSRC,GAMSRC
5844 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5845 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5846 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5848 DIMENSION XGAUSS(126),WGAUSS(126)
5850 DATA XGAUSS(1)/ .57735026918962576D0/
5851 DATA XGAUSS(2)/-.57735026918962576D0/
5852 DATA WGAUSS(1)/ 1.00000000000000000D0/
5853 DATA WGAUSS(2)/ 1.00000000000000000D0/
5855 DATA XGAUSS(3)/ .33998104358485627D0/
5856 DATA XGAUSS(4)/ .86113631159405258D0/
5857 DATA XGAUSS(5)/-.33998104358485627D0/
5858 DATA XGAUSS(6)/-.86113631159405258D0/
5859 DATA WGAUSS(3)/ .65214515486254613D0/
5860 DATA WGAUSS(4)/ .34785484513745385D0/
5861 DATA WGAUSS(5)/ .65214515486254613D0/
5862 DATA WGAUSS(6)/ .34785484513745385D0/
5864 DATA XGAUSS(7)/ .18343464249564981D0/
5865 DATA XGAUSS(8)/ .52553240991632899D0/
5866 DATA XGAUSS(9)/ .79666647741362674D0/
5867 DATA XGAUSS(10)/ .96028985649753623D0/
5868 DATA XGAUSS(11)/-.18343464249564981D0/
5869 DATA XGAUSS(12)/-.52553240991632899D0/
5870 DATA XGAUSS(13)/-.79666647741362674D0/
5871 DATA XGAUSS(14)/-.96028985649753623D0/
5872 DATA WGAUSS(7)/ .36268378337836198D0/
5873 DATA WGAUSS(8)/ .31370664587788727D0/
5874 DATA WGAUSS(9)/ .22238103445337448D0/
5875 DATA WGAUSS(10)/ .10122853629037627D0/
5876 DATA WGAUSS(11)/ .36268378337836198D0/
5877 DATA WGAUSS(12)/ .31370664587788727D0/
5878 DATA WGAUSS(13)/ .22238103445337448D0/
5879 DATA WGAUSS(14)/ .10122853629037627D0/
5881 DATA XGAUSS(15)/ .0950125098376374402D0/
5882 DATA XGAUSS(16)/ .281603550779258913D0/
5883 DATA XGAUSS(17)/ .458016777657227386D0/
5884 DATA XGAUSS(18)/ .617876244402643748D0/
5885 DATA XGAUSS(19)/ .755404408355003034D0/
5886 DATA XGAUSS(20)/ .865631202387831744D0/
5887 DATA XGAUSS(21)/ .944575023073232576D0/
5888 DATA XGAUSS(22)/ .989400934991649933D0/
5889 DATA XGAUSS(23)/-.0950125098376374402D0/
5890 DATA XGAUSS(24)/-.281603550779258913D0/
5891 DATA XGAUSS(25)/-.458016777657227386D0/
5892 DATA XGAUSS(26)/-.617876244402643748D0/
5893 DATA XGAUSS(27)/-.755404408355003034D0/
5894 DATA XGAUSS(28)/-.865631202387831744D0/
5895 DATA XGAUSS(29)/-.944575023073232576D0/
5896 DATA XGAUSS(30)/-.989400934991649933D0/
5897 DATA WGAUSS(15)/ .189450610455068496D0/
5898 DATA WGAUSS(16)/ .182603415044923589D0/
5899 DATA WGAUSS(17)/ .169156519395002538D0/
5900 DATA WGAUSS(18)/ .149595988816576732D0/
5901 DATA WGAUSS(19)/ .124628971255533872D0/
5902 DATA WGAUSS(20)/ .0951585116824927848D0/
5903 DATA WGAUSS(21)/ .0622535239386478929D0/
5904 DATA WGAUSS(22)/ .0271524594117540949D0/
5905 DATA WGAUSS(23)/ .189450610455068496D0/
5906 DATA WGAUSS(24)/ .182603415044923589D0/
5907 DATA WGAUSS(25)/ .169156519395002538D0/
5908 DATA WGAUSS(26)/ .149595988816576732D0/
5909 DATA WGAUSS(27)/ .124628971255533872D0/
5910 DATA WGAUSS(28)/ .0951585116824927848D0/
5911 DATA WGAUSS(29)/ .0622535239386478929D0/
5912 DATA WGAUSS(30)/ .0271524594117540949D0/
5914 DATA XGAUSS(31)/ .0483076656877383162D0/
5915 DATA XGAUSS(32)/ .144471961582796493D0/
5916 DATA XGAUSS(33)/ .239287362252137075D0/
5917 DATA XGAUSS(34)/ .331868602282127650D0/
5918 DATA XGAUSS(35)/ .421351276130635345D0/
5919 DATA XGAUSS(36)/ .506899908932229390D0/
5920 DATA XGAUSS(37)/ .587715757240762329D0/
5921 DATA XGAUSS(38)/ .663044266930215201D0/
5922 DATA XGAUSS(39)/ .732182118740289680D0/
5923 DATA XGAUSS(40)/ .794483795967942407D0/
5924 DATA XGAUSS(41)/ .849367613732569970D0/
5925 DATA XGAUSS(42)/ .896321155766052124D0/
5926 DATA XGAUSS(43)/ .934906075937739689D0/
5927 DATA XGAUSS(44)/ .964762255587506430D0/
5928 DATA XGAUSS(45)/ .985611511545268335D0/
5929 DATA XGAUSS(46)/ .997263861849481564D0/
5930 DATA XGAUSS(47)/-.0483076656877383162D0/
5931 DATA XGAUSS(48)/-.144471961582796493D0/
5932 DATA XGAUSS(49)/-.239287362252137075D0/
5933 DATA XGAUSS(50)/-.331868602282127650D0/
5934 DATA XGAUSS(51)/-.421351276130635345D0/
5935 DATA XGAUSS(52)/-.506899908932229390D0/
5936 DATA XGAUSS(53)/-.587715757240762329D0/
5937 DATA XGAUSS(54)/-.663044266930215201D0/
5938 DATA XGAUSS(55)/-.732182118740289680D0/
5939 DATA XGAUSS(56)/-.794483795967942407D0/
5940 DATA XGAUSS(57)/-.849367613732569970D0/
5941 DATA XGAUSS(58)/-.896321155766052124D0/
5942 DATA XGAUSS(59)/-.934906075937739689D0/
5943 DATA XGAUSS(60)/-.964762255587506430D0/
5944 DATA XGAUSS(61)/-.985611511545268335D0/
5945 DATA XGAUSS(62)/-.997263861849481564D0/
5946 DATA WGAUSS(31)/ .0965400885147278006D0/
5947 DATA WGAUSS(32)/ .0956387200792748594D0/
5948 DATA WGAUSS(33)/ .0938443990808045654D0/
5949 DATA WGAUSS(34)/ .0911738786957638847D0/
5950 DATA WGAUSS(35)/ .0876520930044038111D0/
5951 DATA WGAUSS(36)/ .0833119242269467552D0/
5952 DATA WGAUSS(37)/ .0781938957870703065D0/
5953 DATA WGAUSS(38)/ .0723457941088485062D0/
5954 DATA WGAUSS(39)/ .0658222227763618468D0/
5955 DATA WGAUSS(40)/ .0586840934785355471D0/
5956 DATA WGAUSS(41)/ .0509980592623761762D0/
5957 DATA WGAUSS(42)/ .0428358980222266807D0/
5958 DATA WGAUSS(43)/ .0342738629130214331D0/
5959 DATA WGAUSS(44)/ .0253920653092620595D0/
5960 DATA WGAUSS(45)/ .0162743947309056706D0/
5961 DATA WGAUSS(46)/ .00701861000947009660D0/
5962 DATA WGAUSS(47)/ .0965400885147278006D0/
5963 DATA WGAUSS(48)/ .0956387200792748594D0/
5964 DATA WGAUSS(49)/ .0938443990808045654D0/
5965 DATA WGAUSS(50)/ .0911738786957638847D0/
5966 DATA WGAUSS(51)/ .0876520930044038111D0/
5967 DATA WGAUSS(52)/ .0833119242269467552D0/
5968 DATA WGAUSS(53)/ .0781938957870703065D0/
5969 DATA WGAUSS(54)/ .0723457941088485062D0/
5970 DATA WGAUSS(55)/ .0658222227763618468D0/
5971 DATA WGAUSS(56)/ .0586840934785355471D0/
5972 DATA WGAUSS(57)/ .0509980592623761762D0/
5973 DATA WGAUSS(58)/ .0428358980222266807D0/
5974 DATA WGAUSS(59)/ .0342738629130214331D0/
5975 DATA WGAUSS(60)/ .0253920653092620595D0/
5976 DATA WGAUSS(61)/ .0162743947309056706D0/
5977 DATA WGAUSS(62)/ .00701861000947009660D0/
5979 DATA XGAUSS(63)/ .02435029266342443250D0/
5980 DATA XGAUSS(64)/ .0729931217877990394D0/
5981 DATA XGAUSS(65)/ .121462819296120554D0/
5982 DATA XGAUSS(66)/ .169644420423992818D0/
5983 DATA XGAUSS(67)/ .217423643740007084D0/
5984 DATA XGAUSS(68)/ .264687162208767416D0/
5985 DATA XGAUSS(69)/ .311322871990210956D0/
5986 DATA XGAUSS(70)/ .357220158337668116D0/
5987 DATA XGAUSS(71)/ .402270157963991604D0/
5988 DATA XGAUSS(72)/ .446366017253464088D0/
5989 DATA XGAUSS(73)/ .489403145707052957D0/
5990 DATA XGAUSS(74)/ .531279464019894546D0/
5991 DATA XGAUSS(75)/ .571895646202634034D0/
5992 DATA XGAUSS(76)/ .611155355172393250D0/
5993 DATA XGAUSS(77)/ .648965471254657340D0/
5994 DATA XGAUSS(78)/ .685236313054233243D0/
5995 DATA XGAUSS(79)/ .719881850171610827D0/
5996 DATA XGAUSS(80)/ .752819907260531897D0/
5997 DATA XGAUSS(81)/ .783972358943341408D0/
5998 DATA XGAUSS(82)/ .813265315122797560D0/
5999 DATA XGAUSS(83)/ .840629296252580363D0/
6000 DATA XGAUSS(84)/ .865999398154092820D0/
6001 DATA XGAUSS(85)/ .889315445995114106D0/
6002 DATA XGAUSS(86)/ .910522137078502806D0/
6003 DATA XGAUSS(87)/ .929569172131939576D0/
6004 DATA XGAUSS(88)/ .946411374858402816D0/
6005 DATA XGAUSS(89)/ .961008799652053719D0/
6006 DATA XGAUSS(90)/ .973326827789910964D0/
6007 DATA XGAUSS(91)/ .983336253884625957D0/
6008 DATA XGAUSS(92)/ .991013371476744321D0/
6009 DATA XGAUSS(93)/ .996340116771955279D0/
6010 DATA XGAUSS(94)/ .999305041735772139D0/
6011 DATA XGAUSS(95)/-.02435029266342443250D0/
6012 DATA XGAUSS(96)/-.0729931217877990394D0/
6013 DATA XGAUSS(97)/-.121462819296120554D0/
6014 DATA XGAUSS(98)/-.169644420423992818D0/
6015 DATA XGAUSS(99)/-.217423643740007084D0/
6016 DATA XGAUSS(100)/-.264687162208767416D0/
6017 DATA XGAUSS(101)/-.311322871990210956D0/
6018 DATA XGAUSS(102)/-.357220158337668116D0/
6019 DATA XGAUSS(103)/-.402270157963991604D0/
6020 DATA XGAUSS(104)/-.446366017253464088D0/
6021 DATA XGAUSS(105)/-.489403145707052957D0/
6022 DATA XGAUSS(106)/-.531279464019894546D0/
6023 DATA XGAUSS(107)/-.571895646202634034D0/
6024 DATA XGAUSS(108)/-.611155355172393250D0/
6025 DATA XGAUSS(109)/-.648965471254657340D0/
6026 DATA XGAUSS(110)/-.685236313054233243D0/
6027 DATA XGAUSS(111)/-.719881850171610827D0/
6028 DATA XGAUSS(112)/-.752819907260531897D0/
6029 DATA XGAUSS(113)/-.783972358943341408D0/
6030 DATA XGAUSS(114)/-.813265315122797560D0/
6031 DATA XGAUSS(115)/-.840629296252580363D0/
6032 DATA XGAUSS(116)/-.865999398154092820D0/
6033 DATA XGAUSS(117)/-.889315445995114106D0/
6034 DATA XGAUSS(118)/-.910522137078502806D0/
6035 DATA XGAUSS(119)/-.929569172131939576D0/
6036 DATA XGAUSS(120)/-.946411374858402816D0/
6037 DATA XGAUSS(121)/-.961008799652053719D0/
6038 DATA XGAUSS(122)/-.973326827789910964D0/
6039 DATA XGAUSS(123)/-.983336253884625957D0/
6040 DATA XGAUSS(124)/-.991013371476744321D0/
6041 DATA XGAUSS(125)/-.996340116771955279D0/
6042 DATA XGAUSS(126)/-.999305041735772139D0/
6043 DATA WGAUSS(63)/ .0486909570091397204D0/
6044 DATA WGAUSS(64)/ .0485754674415034269D0/
6045 DATA WGAUSS(65)/ .0483447622348029572D0/
6046 DATA WGAUSS(66)/ .0479993885964583077D0/
6047 DATA WGAUSS(67)/ .0475401657148303087D0/
6048 DATA WGAUSS(68)/ .0469681828162100173D0/
6049 DATA WGAUSS(69)/ .0462847965813144172D0/
6050 DATA WGAUSS(70)/ .0454916279274181445D0/
6051 DATA WGAUSS(71)/ .0445905581637565631D0/
6052 DATA WGAUSS(72)/ .0435837245293234534D0/
6053 DATA WGAUSS(73)/ .0424735151236535890D0/
6054 DATA WGAUSS(74)/ .0412625632426235286D0/
6055 DATA WGAUSS(75)/ .0399537411327203414D0/
6056 DATA WGAUSS(76)/ .0385501531786156291D0/
6057 DATA WGAUSS(77)/ .0370551285402400460D0/
6058 DATA WGAUSS(78)/ .0354722132568823838D0/
6059 DATA WGAUSS(79)/ .0338051618371416094D0/
6060 DATA WGAUSS(80)/ .0320579283548515535D0/
6061 DATA WGAUSS(81)/ .0302346570724024789D0/
6062 DATA WGAUSS(82)/ .0283396726142594832D0/
6063 DATA WGAUSS(83)/ .0263774697150546587D0/
6064 DATA WGAUSS(84)/ .0243527025687108733D0/
6065 DATA WGAUSS(85)/ .0222701738083832542D0/
6066 DATA WGAUSS(86)/ .0201348231535302094D0/
6067 DATA WGAUSS(87)/ .0179517157756973431D0/
6068 DATA WGAUSS(88)/ .0157260304760247193D0/
6069 DATA WGAUSS(89)/ .0134630478967186426D0/
6070 DATA WGAUSS(90)/ .0111681394601311288D0/
6071 DATA WGAUSS(91)/ .00884675982636394772D0/
6072 DATA WGAUSS(92)/ .00650445796897836286D0/
6073 DATA WGAUSS(93)/ .00414703326056246764D0/
6074 DATA WGAUSS(94)/ .00178328072169643295D0/
6075 DATA WGAUSS(95)/ .0486909570091397204D0/
6076 DATA WGAUSS(96)/ .0485754674415034269D0/
6077 DATA WGAUSS(97)/ .0483447622348029572D0/
6078 DATA WGAUSS(98)/ .0479993885964583077D0/
6079 DATA WGAUSS(99)/ .0475401657148303087D0/
6080 DATA WGAUSS(100)/ .0469681828162100173D0/
6081 DATA WGAUSS(101)/ .0462847965813144172D0/
6082 DATA WGAUSS(102)/ .0454916279274181445D0/
6083 DATA WGAUSS(103)/ .0445905581637565631D0/
6084 DATA WGAUSS(104)/ .0435837245293234534D0/
6085 DATA WGAUSS(105)/ .0424735151236535890D0/
6086 DATA WGAUSS(106)/ .0412625632426235286D0/
6087 DATA WGAUSS(107)/ .0399537411327203414D0/
6088 DATA WGAUSS(108)/ .0385501531786156291D0/
6089 DATA WGAUSS(109)/ .0370551285402400460D0/
6090 DATA WGAUSS(110)/ .0354722132568823838D0/
6091 DATA WGAUSS(111)/ .0338051618371416094D0/
6092 DATA WGAUSS(112)/ .0320579283548515535D0/
6093 DATA WGAUSS(113)/ .0302346570724024789D0/
6094 DATA WGAUSS(114)/ .0283396726142594832D0/
6095 DATA WGAUSS(115)/ .0263774697150546587D0/
6096 DATA WGAUSS(116)/ .0243527025687108733D0/
6097 DATA WGAUSS(117)/ .0222701738083832542D0/
6098 DATA WGAUSS(118)/ .0201348231535302094D0/
6099 DATA WGAUSS(119)/ .0179517157756973431D0/
6100 DATA WGAUSS(120)/ .0157260304760247193D0/
6101 DATA WGAUSS(121)/ .0134630478967186426D0/
6102 DATA WGAUSS(122)/ .0111681394601311288D0/
6103 DATA WGAUSS(123)/ .00884675982636394772D0/
6104 DATA WGAUSS(124)/ .00650445796897836286D0/
6105 DATA WGAUSS(125)/ .00414703326056246764D0/
6106 DATA WGAUSS(126)/ .00178328072169643295D0/
6108 C integrate first over b1
6110 C Loop incrementing the boundary
6119 C Loop for the Gauss integration
6125 DO 200 I=2**N-1,2**(N+1)-2
6126 t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6127 b1 = RADSRC(1) * EXP (t)
6128 XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6130 XINT = (tmax-tmin)/2.D0*XINT
6131 IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6133 WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6137 IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6143 PHO_GGFLCR = 4.D0*Pi * Sum
6147 CDECK ID>, PHO_GGFAUX
6148 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6149 C*********************************************************************
6151 C auxiliary function for integration over b2,
6152 C semi-classical photon flux correction due to
6153 C overlap in impact parameter space (geometrical model)
6155 C*********************************************************************
6156 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6159 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6161 C input/output channels
6163 COMMON /POINOU/ LI,LO
6164 C gamma-lepton or gamma-hadron vertex information
6165 INTEGER IGHEL,IDPSRC,IDBSRC
6166 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6167 & RADSRC,AMSRC,GAMSRC
6168 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6169 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6170 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6172 DIMENSION XGAUSS(126),WGAUSS(126)
6174 DATA XGAUSS(1)/ .57735026918962576D0/
6175 DATA XGAUSS(2)/-.57735026918962576D0/
6176 DATA WGAUSS(1)/ 1.00000000000000000D0/
6177 DATA WGAUSS(2)/ 1.00000000000000000D0/
6179 DATA XGAUSS(3)/ .33998104358485627D0/
6180 DATA XGAUSS(4)/ .86113631159405258D0/
6181 DATA XGAUSS(5)/-.33998104358485627D0/
6182 DATA XGAUSS(6)/-.86113631159405258D0/
6183 DATA WGAUSS(3)/ .65214515486254613D0/
6184 DATA WGAUSS(4)/ .34785484513745385D0/
6185 DATA WGAUSS(5)/ .65214515486254613D0/
6186 DATA WGAUSS(6)/ .34785484513745385D0/
6188 DATA XGAUSS(7)/ .18343464249564981D0/
6189 DATA XGAUSS(8)/ .52553240991632899D0/
6190 DATA XGAUSS(9)/ .79666647741362674D0/
6191 DATA XGAUSS(10)/ .96028985649753623D0/
6192 DATA XGAUSS(11)/-.18343464249564981D0/
6193 DATA XGAUSS(12)/-.52553240991632899D0/
6194 DATA XGAUSS(13)/-.79666647741362674D0/
6195 DATA XGAUSS(14)/-.96028985649753623D0/
6196 DATA WGAUSS(7)/ .36268378337836198D0/
6197 DATA WGAUSS(8)/ .31370664587788727D0/
6198 DATA WGAUSS(9)/ .22238103445337448D0/
6199 DATA WGAUSS(10)/ .10122853629037627D0/
6200 DATA WGAUSS(11)/ .36268378337836198D0/
6201 DATA WGAUSS(12)/ .31370664587788727D0/
6202 DATA WGAUSS(13)/ .22238103445337448D0/
6203 DATA WGAUSS(14)/ .10122853629037627D0/
6205 DATA XGAUSS(15)/ .0950125098376374402D0/
6206 DATA XGAUSS(16)/ .281603550779258913D0/
6207 DATA XGAUSS(17)/ .458016777657227386D0/
6208 DATA XGAUSS(18)/ .617876244402643748D0/
6209 DATA XGAUSS(19)/ .755404408355003034D0/
6210 DATA XGAUSS(20)/ .865631202387831744D0/
6211 DATA XGAUSS(21)/ .944575023073232576D0/
6212 DATA XGAUSS(22)/ .989400934991649933D0/
6213 DATA XGAUSS(23)/-.0950125098376374402D0/
6214 DATA XGAUSS(24)/-.281603550779258913D0/
6215 DATA XGAUSS(25)/-.458016777657227386D0/
6216 DATA XGAUSS(26)/-.617876244402643748D0/
6217 DATA XGAUSS(27)/-.755404408355003034D0/
6218 DATA XGAUSS(28)/-.865631202387831744D0/
6219 DATA XGAUSS(29)/-.944575023073232576D0/
6220 DATA XGAUSS(30)/-.989400934991649933D0/
6221 DATA WGAUSS(15)/ .189450610455068496D0/
6222 DATA WGAUSS(16)/ .182603415044923589D0/
6223 DATA WGAUSS(17)/ .169156519395002538D0/
6224 DATA WGAUSS(18)/ .149595988816576732D0/
6225 DATA WGAUSS(19)/ .124628971255533872D0/
6226 DATA WGAUSS(20)/ .0951585116824927848D0/
6227 DATA WGAUSS(21)/ .0622535239386478929D0/
6228 DATA WGAUSS(22)/ .0271524594117540949D0/
6229 DATA WGAUSS(23)/ .189450610455068496D0/
6230 DATA WGAUSS(24)/ .182603415044923589D0/
6231 DATA WGAUSS(25)/ .169156519395002538D0/
6232 DATA WGAUSS(26)/ .149595988816576732D0/
6233 DATA WGAUSS(27)/ .124628971255533872D0/
6234 DATA WGAUSS(28)/ .0951585116824927848D0/
6235 DATA WGAUSS(29)/ .0622535239386478929D0/
6236 DATA WGAUSS(30)/ .0271524594117540949D0/
6238 DATA XGAUSS(31)/ .0483076656877383162D0/
6239 DATA XGAUSS(32)/ .144471961582796493D0/
6240 DATA XGAUSS(33)/ .239287362252137075D0/
6241 DATA XGAUSS(34)/ .331868602282127650D0/
6242 DATA XGAUSS(35)/ .421351276130635345D0/
6243 DATA XGAUSS(36)/ .506899908932229390D0/
6244 DATA XGAUSS(37)/ .587715757240762329D0/
6245 DATA XGAUSS(38)/ .663044266930215201D0/
6246 DATA XGAUSS(39)/ .732182118740289680D0/
6247 DATA XGAUSS(40)/ .794483795967942407D0/
6248 DATA XGAUSS(41)/ .849367613732569970D0/
6249 DATA XGAUSS(42)/ .896321155766052124D0/
6250 DATA XGAUSS(43)/ .934906075937739689D0/
6251 DATA XGAUSS(44)/ .964762255587506430D0/
6252 DATA XGAUSS(45)/ .985611511545268335D0/
6253 DATA XGAUSS(46)/ .997263861849481564D0/
6254 DATA XGAUSS(47)/-.0483076656877383162D0/
6255 DATA XGAUSS(48)/-.144471961582796493D0/
6256 DATA XGAUSS(49)/-.239287362252137075D0/
6257 DATA XGAUSS(50)/-.331868602282127650D0/
6258 DATA XGAUSS(51)/-.421351276130635345D0/
6259 DATA XGAUSS(52)/-.506899908932229390D0/
6260 DATA XGAUSS(53)/-.587715757240762329D0/
6261 DATA XGAUSS(54)/-.663044266930215201D0/
6262 DATA XGAUSS(55)/-.732182118740289680D0/
6263 DATA XGAUSS(56)/-.794483795967942407D0/
6264 DATA XGAUSS(57)/-.849367613732569970D0/
6265 DATA XGAUSS(58)/-.896321155766052124D0/
6266 DATA XGAUSS(59)/-.934906075937739689D0/
6267 DATA XGAUSS(60)/-.964762255587506430D0/
6268 DATA XGAUSS(61)/-.985611511545268335D0/
6269 DATA XGAUSS(62)/-.997263861849481564D0/
6270 DATA WGAUSS(31)/ .0965400885147278006D0/
6271 DATA WGAUSS(32)/ .0956387200792748594D0/
6272 DATA WGAUSS(33)/ .0938443990808045654D0/
6273 DATA WGAUSS(34)/ .0911738786957638847D0/
6274 DATA WGAUSS(35)/ .0876520930044038111D0/
6275 DATA WGAUSS(36)/ .0833119242269467552D0/
6276 DATA WGAUSS(37)/ .0781938957870703065D0/
6277 DATA WGAUSS(38)/ .0723457941088485062D0/
6278 DATA WGAUSS(39)/ .0658222227763618468D0/
6279 DATA WGAUSS(40)/ .0586840934785355471D0/
6280 DATA WGAUSS(41)/ .0509980592623761762D0/
6281 DATA WGAUSS(42)/ .0428358980222266807D0/
6282 DATA WGAUSS(43)/ .0342738629130214331D0/
6283 DATA WGAUSS(44)/ .0253920653092620595D0/
6284 DATA WGAUSS(45)/ .0162743947309056706D0/
6285 DATA WGAUSS(46)/ .00701861000947009660D0/
6286 DATA WGAUSS(47)/ .0965400885147278006D0/
6287 DATA WGAUSS(48)/ .0956387200792748594D0/
6288 DATA WGAUSS(49)/ .0938443990808045654D0/
6289 DATA WGAUSS(50)/ .0911738786957638847D0/
6290 DATA WGAUSS(51)/ .0876520930044038111D0/
6291 DATA WGAUSS(52)/ .0833119242269467552D0/
6292 DATA WGAUSS(53)/ .0781938957870703065D0/
6293 DATA WGAUSS(54)/ .0723457941088485062D0/
6294 DATA WGAUSS(55)/ .0658222227763618468D0/
6295 DATA WGAUSS(56)/ .0586840934785355471D0/
6296 DATA WGAUSS(57)/ .0509980592623761762D0/
6297 DATA WGAUSS(58)/ .0428358980222266807D0/
6298 DATA WGAUSS(59)/ .0342738629130214331D0/
6299 DATA WGAUSS(60)/ .0253920653092620595D0/
6300 DATA WGAUSS(61)/ .0162743947309056706D0/
6301 DATA WGAUSS(62)/ .00701861000947009660D0/
6303 DATA XGAUSS(63)/ .02435029266342443250D0/
6304 DATA XGAUSS(64)/ .0729931217877990394D0/
6305 DATA XGAUSS(65)/ .121462819296120554D0/
6306 DATA XGAUSS(66)/ .169644420423992818D0/
6307 DATA XGAUSS(67)/ .217423643740007084D0/
6308 DATA XGAUSS(68)/ .264687162208767416D0/
6309 DATA XGAUSS(69)/ .311322871990210956D0/
6310 DATA XGAUSS(70)/ .357220158337668116D0/
6311 DATA XGAUSS(71)/ .402270157963991604D0/
6312 DATA XGAUSS(72)/ .446366017253464088D0/
6313 DATA XGAUSS(73)/ .489403145707052957D0/
6314 DATA XGAUSS(74)/ .531279464019894546D0/
6315 DATA XGAUSS(75)/ .571895646202634034D0/
6316 DATA XGAUSS(76)/ .611155355172393250D0/
6317 DATA XGAUSS(77)/ .648965471254657340D0/
6318 DATA XGAUSS(78)/ .685236313054233243D0/
6319 DATA XGAUSS(79)/ .719881850171610827D0/
6320 DATA XGAUSS(80)/ .752819907260531897D0/
6321 DATA XGAUSS(81)/ .783972358943341408D0/
6322 DATA XGAUSS(82)/ .813265315122797560D0/
6323 DATA XGAUSS(83)/ .840629296252580363D0/
6324 DATA XGAUSS(84)/ .865999398154092820D0/
6325 DATA XGAUSS(85)/ .889315445995114106D0/
6326 DATA XGAUSS(86)/ .910522137078502806D0/
6327 DATA XGAUSS(87)/ .929569172131939576D0/
6328 DATA XGAUSS(88)/ .946411374858402816D0/
6329 DATA XGAUSS(89)/ .961008799652053719D0/
6330 DATA XGAUSS(90)/ .973326827789910964D0/
6331 DATA XGAUSS(91)/ .983336253884625957D0/
6332 DATA XGAUSS(92)/ .991013371476744321D0/
6333 DATA XGAUSS(93)/ .996340116771955279D0/
6334 DATA XGAUSS(94)/ .999305041735772139D0/
6335 DATA XGAUSS(95)/-.02435029266342443250D0/
6336 DATA XGAUSS(96)/-.0729931217877990394D0/
6337 DATA XGAUSS(97)/-.121462819296120554D0/
6338 DATA XGAUSS(98)/-.169644420423992818D0/
6339 DATA XGAUSS(99)/-.217423643740007084D0/
6340 DATA XGAUSS(100)/-.264687162208767416D0/
6341 DATA XGAUSS(101)/-.311322871990210956D0/
6342 DATA XGAUSS(102)/-.357220158337668116D0/
6343 DATA XGAUSS(103)/-.402270157963991604D0/
6344 DATA XGAUSS(104)/-.446366017253464088D0/
6345 DATA XGAUSS(105)/-.489403145707052957D0/
6346 DATA XGAUSS(106)/-.531279464019894546D0/
6347 DATA XGAUSS(107)/-.571895646202634034D0/
6348 DATA XGAUSS(108)/-.611155355172393250D0/
6349 DATA XGAUSS(109)/-.648965471254657340D0/
6350 DATA XGAUSS(110)/-.685236313054233243D0/
6351 DATA XGAUSS(111)/-.719881850171610827D0/
6352 DATA XGAUSS(112)/-.752819907260531897D0/
6353 DATA XGAUSS(113)/-.783972358943341408D0/
6354 DATA XGAUSS(114)/-.813265315122797560D0/
6355 DATA XGAUSS(115)/-.840629296252580363D0/
6356 DATA XGAUSS(116)/-.865999398154092820D0/
6357 DATA XGAUSS(117)/-.889315445995114106D0/
6358 DATA XGAUSS(118)/-.910522137078502806D0/
6359 DATA XGAUSS(119)/-.929569172131939576D0/
6360 DATA XGAUSS(120)/-.946411374858402816D0/
6361 DATA XGAUSS(121)/-.961008799652053719D0/
6362 DATA XGAUSS(122)/-.973326827789910964D0/
6363 DATA XGAUSS(123)/-.983336253884625957D0/
6364 DATA XGAUSS(124)/-.991013371476744321D0/
6365 DATA XGAUSS(125)/-.996340116771955279D0/
6366 DATA XGAUSS(126)/-.999305041735772139D0/
6367 DATA WGAUSS(63)/ .0486909570091397204D0/
6368 DATA WGAUSS(64)/ .0485754674415034269D0/
6369 DATA WGAUSS(65)/ .0483447622348029572D0/
6370 DATA WGAUSS(66)/ .0479993885964583077D0/
6371 DATA WGAUSS(67)/ .0475401657148303087D0/
6372 DATA WGAUSS(68)/ .0469681828162100173D0/
6373 DATA WGAUSS(69)/ .0462847965813144172D0/
6374 DATA WGAUSS(70)/ .0454916279274181445D0/
6375 DATA WGAUSS(71)/ .0445905581637565631D0/
6376 DATA WGAUSS(72)/ .0435837245293234534D0/
6377 DATA WGAUSS(73)/ .0424735151236535890D0/
6378 DATA WGAUSS(74)/ .0412625632426235286D0/
6379 DATA WGAUSS(75)/ .0399537411327203414D0/
6380 DATA WGAUSS(76)/ .0385501531786156291D0/
6381 DATA WGAUSS(77)/ .0370551285402400460D0/
6382 DATA WGAUSS(78)/ .0354722132568823838D0/
6383 DATA WGAUSS(79)/ .0338051618371416094D0/
6384 DATA WGAUSS(80)/ .0320579283548515535D0/
6385 DATA WGAUSS(81)/ .0302346570724024789D0/
6386 DATA WGAUSS(82)/ .0283396726142594832D0/
6387 DATA WGAUSS(83)/ .0263774697150546587D0/
6388 DATA WGAUSS(84)/ .0243527025687108733D0/
6389 DATA WGAUSS(85)/ .0222701738083832542D0/
6390 DATA WGAUSS(86)/ .0201348231535302094D0/
6391 DATA WGAUSS(87)/ .0179517157756973431D0/
6392 DATA WGAUSS(88)/ .0157260304760247193D0/
6393 DATA WGAUSS(89)/ .0134630478967186426D0/
6394 DATA WGAUSS(90)/ .0111681394601311288D0/
6395 DATA WGAUSS(91)/ .00884675982636394772D0/
6396 DATA WGAUSS(92)/ .00650445796897836286D0/
6397 DATA WGAUSS(93)/ .00414703326056246764D0/
6398 DATA WGAUSS(94)/ .00178328072169643295D0/
6399 DATA WGAUSS(95)/ .0486909570091397204D0/
6400 DATA WGAUSS(96)/ .0485754674415034269D0/
6401 DATA WGAUSS(97)/ .0483447622348029572D0/
6402 DATA WGAUSS(98)/ .0479993885964583077D0/
6403 DATA WGAUSS(99)/ .0475401657148303087D0/
6404 DATA WGAUSS(100)/ .0469681828162100173D0/
6405 DATA WGAUSS(101)/ .0462847965813144172D0/
6406 DATA WGAUSS(102)/ .0454916279274181445D0/
6407 DATA WGAUSS(103)/ .0445905581637565631D0/
6408 DATA WGAUSS(104)/ .0435837245293234534D0/
6409 DATA WGAUSS(105)/ .0424735151236535890D0/
6410 DATA WGAUSS(106)/ .0412625632426235286D0/
6411 DATA WGAUSS(107)/ .0399537411327203414D0/
6412 DATA WGAUSS(108)/ .0385501531786156291D0/
6413 DATA WGAUSS(109)/ .0370551285402400460D0/
6414 DATA WGAUSS(110)/ .0354722132568823838D0/
6415 DATA WGAUSS(111)/ .0338051618371416094D0/
6416 DATA WGAUSS(112)/ .0320579283548515535D0/
6417 DATA WGAUSS(113)/ .0302346570724024789D0/
6418 DATA WGAUSS(114)/ .0283396726142594832D0/
6419 DATA WGAUSS(115)/ .0263774697150546587D0/
6420 DATA WGAUSS(116)/ .0243527025687108733D0/
6421 DATA WGAUSS(117)/ .0222701738083832542D0/
6422 DATA WGAUSS(118)/ .0201348231535302094D0/
6423 DATA WGAUSS(119)/ .0179517157756973431D0/
6424 DATA WGAUSS(120)/ .0157260304760247193D0/
6425 DATA WGAUSS(121)/ .0134630478967186426D0/
6426 DATA WGAUSS(122)/ .0111681394601311288D0/
6427 DATA WGAUSS(123)/ .00884675982636394772D0/
6428 DATA WGAUSS(124)/ .00650445796897836286D0/
6429 DATA WGAUSS(125)/ .00414703326056246764D0/
6430 DATA WGAUSS(126)/ .00178328072169643295D0/
6434 bmin = b1 - 2.D0*RADSRC(1)
6435 IF (RADSRC(1) .GT. bmin) THEN
6438 bmax = b1 + 2.D0 * RADSRC(1)
6444 DO 200 I=2**N-1,2**(N+1)-2
6445 b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6446 XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6447 & * PHO_GGFNUC(W2,b2,GAMSRC(2))
6448 & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6449 XINT = XINT +WGAUSS(I) * b2 * XINT3
6451 XINT = (bmax-bmin)/2.D0*XINT
6452 IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6454 WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6461 CDECK ID>, PHO_GGFNUC
6462 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6463 C**********************************************************************
6465 C differential photonnumber for a nucleus (geometrical model)
6466 C (without form factor)
6468 C*********************************************************************
6469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6472 PARAMETER (PI = 3.14159265359D0)
6475 Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6477 PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6481 CDECK ID>, PHO_GHHIOF
6482 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6483 C**********************************************************************
6485 C interface to call PHOJET (variable energy run) for
6486 C gamma-hadron collisions in heavy ion collisions
6487 C (form factor approach)
6489 C input: EEN LAB system energy per nucleon
6490 C NA atomic number of ion/hadron
6491 C NZ charge number of ion/hadron
6492 C NEVENT number of events to generate
6494 C YMIN1,2 lower limit of Y
6495 C (energy fraction taken by photon from hadron)
6496 C YMAX1,2 upper cutoff for Y, necessary to avoid
6498 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6499 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6500 C corrected according size of hadron)
6502 C**********************************************************************
6503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6506 PARAMETER ( PI = 3.14159265359D0 )
6508 C input/output channels
6510 COMMON /POINOU/ LI,LO
6511 C model switches and parameters
6513 INTEGER ISWMDL,IPAMDL
6514 DOUBLE PRECISION PARMDL
6515 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6516 C event debugging information
6518 PARAMETER (NMAXD=100)
6519 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6520 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6521 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6522 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6523 C photon flux kinematics and cuts
6524 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6525 & YMIN1,YMAX1,YMIN2,YMAX2,
6526 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6527 & THMIN1,THMAX1,THMIN2,THMAX2
6529 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6530 & YMIN1,YMAX1,YMIN2,YMAX2,
6531 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6532 & THMIN1,THMAX1,THMIN2,THMAX2,
6534 C gamma-lepton or gamma-hadron vertex information
6535 INTEGER IGHEL,IDPSRC,IDBSRC
6536 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6537 & RADSRC,AMSRC,GAMSRC
6538 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6539 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6540 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6541 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
6542 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6543 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6544 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6545 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6547 C standard particle data interface
6550 PARAMETER (NMXHEP=4000)
6552 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6553 DOUBLE PRECISION PHEP,VHEP
6554 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6555 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6557 C extension to standard particle data interface (PHOJET specific)
6558 INTEGER IMPART,IPHIST,ICOLOR
6559 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6561 C event weights and generated cross section
6562 INTEGER IPOWGC,ISWCUT,IVWGHT
6563 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6564 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6565 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6567 DIMENSION P1(4),P2(4)
6568 DIMENSION NITERS(2),ITRW(2)
6570 WRITE(LO,'(2(/1X,A))')
6571 & 'PHO_GHHIOF: gamma-hadron event generation',
6572 & '-----------------------------------------'
6573 C hadron size and mass
6575 HIMASS = DBLE(NA)*0.938D0
6577 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6578 ALPHA = DBLE(NZ**2)/137.D0
6581 C correct Q2MAX1,2 according to hadron size
6582 Q2MAXH = 2.D0/HIRADI**2
6583 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6584 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6585 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6586 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6587 C total hadron / heavy ion energy
6597 C check cuts on photon-hadron mass
6598 IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6600 ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
6601 WRITE(LO,'(/1X,A,2E12.5)')
6602 & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6604 C check kinematic limitations
6605 YMI = ECMIN**2/(4.D0*EE*EEN)
6606 IF(YMIN1.LT.YMI) THEN
6607 WRITE(LO,'(/1X,A,2E12.5)')
6608 & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6610 ELSE IF(YMIN1.GT.YMI) THEN
6611 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6612 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6613 & ' INSTEAD OF',YMIN1
6615 IF(YMIN2.LT.YMI) THEN
6616 WRITE(LO,'(/1X,A,2E12.5)')
6617 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6619 ELSE IF(YMIN2.GT.YMI) THEN
6620 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6621 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6622 & ' INSTEAD OF',YMIN2
6624 C kinematic limitation
6625 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6626 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6628 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
6629 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
6630 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
6631 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6633 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6635 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
6637 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
6639 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
6641 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
6643 WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6645 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
6646 IF(Q2LOW1.GE.Q2MAX1) THEN
6647 WRITE(LO,'(/1X,A,2E12.4)')
6648 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6651 IF(Q2LOW2.GE.Q2MAX2) THEN
6652 WRITE(LO,'(/1X,A,2E12.4)')
6653 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6656 C hadron numbers set to 0
6668 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6670 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6671 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6672 IF(Q2LOW1.GE.Q2MAX1) THEN
6673 WRITE(LO,'(/1X,A,2E12.4)')
6674 & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6675 YMAX1 = MIN(Y1,YMAX1)
6685 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6687 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6688 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6689 IF(Q2LOW2.GE.Q2MAX2) THEN
6690 WRITE(LO,'(/1X,A,2E12.4)')
6691 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6692 YMAX2 = MIN(Y1,YMAX2)
6704 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6706 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6707 & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6709 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6710 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6711 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6712 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6714 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6717 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6718 & 'PHO_GHHIOF: integrated flux (one side):',FLUX
6721 EGAM = MAX(YMAX1,YMAX2)*EE
6729 P2(3) = -SQRT(EEN**2-AMP2)
6731 CALL PHO_SETPAR(1,22,0,0.D0)
6732 CALL PHO_SETPAR(2,2212,0,0.D0)
6733 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6735 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6736 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6739 WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6740 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6741 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6742 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6744 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6745 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6747 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6748 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6750 CALL PHO_PHIST(-1,SIGMAX)
6751 CALL PHO_LHIST(-1,SIGMAX)
6753 C generation of events, flux calculation
6783 C select side of photon emission
6784 IF(DT_RNDM(AY1).LT.FAC12) THEN
6787 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6788 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6789 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6790 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6791 WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6792 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6793 IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6794 & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6795 IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6797 IF(IPAMDL(174).EQ.1) THEN
6798 YEFF = 1.D0+(1.D0-Y1)**2
6800 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6801 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6802 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6807 GAIMP(1) = 1.D0/SQRT(Q2P1)
6808 C form factor (squared)
6810 IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6811 IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6820 PINI(3,1) = SQRT(EE**2-AMP2)
6824 YQ2 = SQRT((1.D0-Y1)*Q2P1)
6825 Q2E = Q2P1/(4.D0*EE)
6827 CALL PHO_SFECFE(SIF,COF)
6833 PFPHI(1) = ATAN2(COF,SIF)
6834 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6838 PINI(3,2) = -SQRT(EE**2-AMP2)
6844 P1(3) = PINI(3,1)-PFIN(3,1)
6845 P1(4) = PINI(4,1)-PFIN(4,1)
6849 P2(3) = -SQRT(EEN**2-AMP2)
6857 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6858 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6859 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6860 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6861 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6862 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6863 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6864 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6865 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6867 IF(IPAMDL(174).EQ.1) THEN
6868 YEFF = 1.D0+(1.D0-Y2)**2
6870 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6871 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6872 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6877 GAIMP(2) = 1.D0/SQRT(Q2P2)
6878 C form factor (squared)
6880 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6881 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6890 PINI(3,1) = SQRT(EE**2-AMP2)
6896 PINI(3,2) = -SQRT(EE**2-AMP2)
6900 YQ2 = SQRT((1.D0-Y2)*Q2P2)
6901 Q2E = Q2P2/(4.D0*EE)
6903 CALL PHO_SFECFE(SIF,COF)
6906 PFIN(3,2) = -E1Y+Q2E
6909 PFPHI(2) = ATAN2(COF,SIF)
6910 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6914 P2(3) = SQRT(EEN**2-AMP2)
6919 P1(3) = PINI(3,2)-PFIN(3,2)
6920 P1(4) = PINI(4,2)-PFIN(4,2)
6924 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6925 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6926 IF(GGECM.LT.0.1D0) GOTO 175
6928 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6934 PGAM(5,1) = -SQRT(Q2P1)
6939 PGAM(5,2) = -SQRT(Q2P2)
6940 CALL PHO_PRESEL(5,IREJ)
6945 IF(IREJ.NE.0) GOTO 175
6947 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6948 IF(IREJ.NE.0) GOTO 150
6949 C cut on diffractive mass
6951 IF(ISTHEP(K).EQ.30) THEN
6953 IF(GHDIFF.GE.PARMDL(175)) THEN
6960 WRITE(LO,'(/,1X,A)')
6961 & 'PHO_GHHIOF: no diffractive entry found'
6965 C remove quasi-elastically scattered hadron
6967 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
6968 XF = ABS(PHEP(3,K)/EEN)
6969 IF(XF.LT.PARMDL(72)) GOTO 150
6978 NITERS(ISIDE) = NITERS(ISIDE)+1
6983 Q21AVE = Q21AVE+Q2P1
6984 Q21AV2 = Q21AV2+Q2P1*Q2P1
6985 Q21MIN = MIN(Q21MIN,Q2P1)
6986 Q21MAX = MAX(Q21MAX,Q2P1)
6987 YY1MIN = MIN(YY1MIN,Y1)
6988 YY1MAX = MAX(YY1MAX,Y1)
6993 Q22AVE = Q22AVE+Q2P2
6994 Q22AV2 = Q22AV2+Q2P2*Q2P2
6995 Q22MIN = MIN(Q22MIN,Q2P2)
6996 Q22MAX = MAX(Q22MAX,Q2P2)
6997 YY2MIN = MIN(YY2MIN,Y2)
6998 YY2MAX = MAX(YY2MAX,Y2)
7001 CALL PHO_PHIST(1,HSWGHT(0))
7002 CALL PHO_LHIST(1,HSWGHT(0))
7005 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
7006 WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
7007 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
7008 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
7009 AY1 = AY1/DBLE(MAX(NITERS(1),1))
7010 AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
7011 DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
7012 AY2 = AY2/DBLE(MAX(NITERS(2),1))
7013 AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
7014 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
7015 Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
7016 Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
7017 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
7018 Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
7019 Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
7020 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
7021 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
7022 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
7023 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7024 C output of statistics, histograms
7025 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7026 &'=========================================================',
7027 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7028 &'========================================================='
7029 WRITE(LO,'(//1X,A,/3X,6I12)')
7030 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
7031 & NITER,NITERS,ITRY,ITRW
7032 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7034 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
7036 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7038 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
7040 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7042 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
7044 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
7046 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7048 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7051 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7053 CALL PHO_PHIST(-2,WEIGHT)
7054 CALL PHO_LHIST(-2,WEIGHT)
7056 WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7061 CDECK ID>, PHO_GHHIAS
7062 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7063 C**********************************************************************
7065 C interface to call PHOJET (variable energy run) for
7066 C gamma-hadron collisions in heavy ion - hadron
7067 C collisions (form factor approach)
7069 C input: EEP LAB system energy of proton (GeV)
7070 C EEN LAB system energy per nucleon (GeV)
7071 C NA atomic number of ion/hadron
7072 C NZ charge number of ion/hadron
7073 C NEVENT number of events to generate
7075 C YMIN2 lower limit of Y
7076 C (energy fraction taken by photon from hadron)
7077 C YMAX2 upper cutoff for Y, necessary to avoid
7079 C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7080 C Q2MAX2 maximum Q**2 of photons (if necessary,
7081 C corrected according size of hadron)
7083 C**********************************************************************
7084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7087 PARAMETER ( PI = 3.14159265359D0 )
7089 C input/output channels
7091 COMMON /POINOU/ LI,LO
7092 C model switches and parameters
7094 INTEGER ISWMDL,IPAMDL
7095 DOUBLE PRECISION PARMDL
7096 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7097 C event debugging information
7099 PARAMETER (NMAXD=100)
7100 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7101 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7102 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7103 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7104 C photon flux kinematics and cuts
7105 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7106 & YMIN1,YMAX1,YMIN2,YMAX2,
7107 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7108 & THMIN1,THMAX1,THMIN2,THMAX2
7110 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7111 & YMIN1,YMAX1,YMIN2,YMAX2,
7112 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7113 & THMIN1,THMAX1,THMIN2,THMAX2,
7115 C gamma-lepton or gamma-hadron vertex information
7116 INTEGER IGHEL,IDPSRC,IDBSRC
7117 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7118 & RADSRC,AMSRC,GAMSRC
7119 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7120 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7121 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7122 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
7123 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7124 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7125 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7126 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7128 C standard particle data interface
7131 PARAMETER (NMXHEP=4000)
7133 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7134 DOUBLE PRECISION PHEP,VHEP
7135 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7136 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7138 C extension to standard particle data interface (PHOJET specific)
7139 INTEGER IMPART,IPHIST,ICOLOR
7140 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7142 C event weights and generated cross section
7143 INTEGER IPOWGC,ISWCUT,IVWGHT
7144 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7145 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7146 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7148 DIMENSION P1(4),P2(4)
7150 WRITE(LO,'(2(/1X,A))')
7151 & 'PHO_GHHIAS: hadron-gamma event generation',
7152 & '-----------------------------------------'
7153 C hadron size and mass
7155 HIMASS = DBLE(NA)*0.938D0
7157 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7158 ALPHA = DBLE(NZ**2)/137.D0
7161 C correct Q2MAX2 according to hadron size
7162 Q2MAXH = 2.D0/HIRADI**2
7163 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7164 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7165 C total hadron / heavy ion energy
7172 C check kinematic limitations
7173 YMI = ECMIN**2/(4.D0*EE*EEP)
7174 IF(YMIN2.LT.YMI) THEN
7175 WRITE(LO,'(/1X,A,2E12.5)')
7176 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7178 ELSE IF(YMIN2.GT.YMI) THEN
7179 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7180 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7181 & ' INSTEAD OF',YMIN2
7183 C kinematic limitation
7184 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7186 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
7187 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
7188 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
7189 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7191 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
7193 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
7194 & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7195 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
7197 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
7198 IF(Q2LOW2.GE.Q2MAX2) THEN
7199 WRITE(LO,'(/1X,A,2E12.4)')
7200 & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7203 C hadron numbers set to 0
7215 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7217 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7218 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7219 IF(Q2LOW2.GE.Q2MAX2) THEN
7220 WRITE(LO,'(/1X,A,2E12.4)')
7221 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7222 YMAX2 = MIN(Y1,YMAX2)
7231 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7233 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7234 & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7236 Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7237 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7238 FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7239 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7241 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7244 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7245 & 'PHO_GHHIAS: integrated flux:',FLUX
7250 P1(3) = -SQRT(EEP**2-AMP2)
7258 CALL PHO_SETPAR(1,2212,0,0.D0)
7259 CALL PHO_SETPAR(2,22,0,0.D0)
7260 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7262 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7264 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7265 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7267 CALL PHO_PHIST(-1,SIGMAX)
7268 CALL PHO_LHIST(-1,SIGMAX)
7270 C generation of events, flux calculation
7287 C sample photon flux
7294 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7295 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7296 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7297 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7298 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7299 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7300 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7301 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7302 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7304 IF(IPAMDL(174).EQ.1) THEN
7305 YEFF = 1.D0+(1.D0-Y2)**2
7307 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7308 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7309 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7314 GAIMP(2) = 1.D0/SQRT(Q2P2)
7315 C form factor (squared)
7317 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7318 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7327 PINI(3,1) = SQRT(EEP**2-AMP2)
7333 PINI(3,2) = -SQRT(EE**2-AMP2)
7337 YQ2 = SQRT((1.D0-Y2)*Q2P2)
7338 Q2E = Q2P2/(4.D0*EE)
7340 CALL PHO_SFECFE(SIF,COF)
7343 PFIN(3,2) = -E1Y+Q2E
7346 PFPHI(2) = ATAN2(COF,SIF)
7347 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7351 P1(3) = SQRT(EEP**2-AMP2)
7357 P2(3) = PINI(3,2)-PFIN(3,2)
7358 P2(4) = PINI(4,2)-PFIN(4,2)
7362 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7363 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7364 IF(GGECM.LT.0.1D0) GOTO 175
7366 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7377 PGAM(5,2) = -SQRT(Q2P2)
7381 CALL PHO_PRESEL(5,IREJ)
7382 IF(IREJ.NE.0) GOTO 175
7384 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7385 IF(IREJ.NE.0) GOTO 150
7386 C cut on diffractive mass
7388 IF(ISTHEP(K).EQ.30) THEN
7390 IF(GHDIFF.GE.PARMDL(175)) THEN
7397 WRITE(LO,'(/,1X,A)')
7398 & 'PHO_GHHIOF: no diffractive entry found'
7402 C remove quasi-elastically scattered hadron
7404 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7405 XF = ABS(PHEP(3,K)/EEN)
7406 IF(XF.LT.PARMDL(72)) GOTO 150
7419 Q22AVE = Q22AVE+Q2P2
7420 Q22AV2 = Q22AV2+Q2P2*Q2P2
7421 Q22MIN = MIN(Q22MIN,Q2P2)
7422 Q22MAX = MAX(Q22MAX,Q2P2)
7423 YY2MIN = MIN(YY2MIN,Y2)
7424 YY2MAX = MAX(YY2MAX,Y2)
7426 CALL PHO_PHIST(1,HSWGHT(0))
7427 CALL PHO_LHIST(1,HSWGHT(0))
7430 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7431 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7432 AY2 = AY2/DBLE(MAX(NITERS,1))
7433 AYS2 = AYS2/DBLE(MAX(NITERS,1))
7434 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7435 Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7436 Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7437 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7438 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7439 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7440 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7441 C output of statistics, histograms
7442 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7443 &'=========================================================',
7444 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7445 &'========================================================='
7446 WRITE(LO,'(//1X,A,/3X,4I12)')
7447 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
7448 & NITER,NITERS,ITRY,ITRW
7449 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7451 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7453 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7455 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7457 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7460 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7462 CALL PHO_PHIST(-2,WEIGHT)
7463 CALL PHO_LHIST(-2,WEIGHT)
7465 WRITE(LO,'(1X,A,I4)')
7466 & 'PHO_GHHIOF: no output of histograms',NITER
7471 CDECK ID>, PHO_FITPAR
7472 SUBROUTINE PHO_FITPAR(IOUTP)
7473 C**********************************************************************
7475 C read input parameters according to PDFs
7477 C**********************************************************************
7478 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7481 PARAMETER ( DEFA=-99999.D0,
7485 C input/output channels
7487 COMMON /POINOU/ LI,LO
7488 C event debugging information
7490 PARAMETER (NMAXD=100)
7491 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7492 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7493 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7494 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7495 C model switches and parameters
7497 INTEGER ISWMDL,IPAMDL
7498 DOUBLE PRECISION PARMDL
7499 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7500 C global event kinematics and particle IDs
7502 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7503 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7504 C currently activated parton density parametrizations
7506 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7507 DOUBLE PRECISION PDFLAM,PDFQ2M
7508 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7509 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7510 C Reggeon phenomenology parameters
7511 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7512 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7513 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7514 & ALREG,ALREGP,GR(2),B0REG(2),
7515 & GPPP,GPPR,B0PPP,B0PPR,
7516 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7517 C parameters of 2x2 channel model
7518 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7519 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7521 DIMENSION INUM(3),IFPAS(2)
7522 CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7525 PARAMETER ( Max_tab = 22 )
7526 DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7530 C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
7531 DATA (IDPtab(k, 1),k=1,8) /
7532 & 2212, 5, 6, 0, 2212, 5, 6, 0 /
7533 DATA (XDPtab(k, 1),k=1,27) /
7534 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7535 &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7536 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7537 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7538 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7540 C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
7541 DATA (IDPtab(k, 2),k=1,8) /
7542 & 2212, 5, 6, 0, -2212, 5, 6, 0 /
7543 DATA (XDPtab(k, 2),k=1,27) /
7544 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7545 &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7546 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7547 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7548 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7550 C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
7551 DATA (IDPtab(k, 3),k=1,8) /
7552 & 22, 5, 3, 0, 2212, 5, 6, 0 /
7553 DATA (XDPtab(k, 3),k=1,27) /
7554 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7555 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7556 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7557 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7558 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7560 C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
7561 DATA (IDPtab(k, 4),k=1,8) /
7562 & 22, 5, 3, 0, 22, 5, 3, 0 /
7563 DATA (XDPtab(k, 4),k=1,27) /
7564 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7565 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7566 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7567 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7568 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7570 C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
7571 DATA (IDPtab(k, 5),k=1,8) /
7572 & 22, 5, 4, 4, 2212, 5, 6, 0 /
7573 DATA (XDPtab(k, 5),k=1,27) /
7574 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7575 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7576 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7577 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7578 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7580 C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
7581 DATA (IDPtab(k, 6),k=1,8) /
7582 & 22, 5, 4, 4, 22, 5, 4, 4 /
7583 DATA (XDPtab(k, 6),k=1,27) /
7584 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7585 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7586 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7587 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7588 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7590 C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
7591 DATA (IDPtab(k, 7),k=1,8) /
7592 & 22, 1, 1, 4, 22, 1, 1, 4 /
7593 DATA (XDPtab(k, 7),k=1,27) /
7594 &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7595 &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7596 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7597 &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7598 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7600 C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
7601 DATA (IDPtab(k, 8),k=1,8) /
7602 & 22, 1, 2, 4, 22, 1, 2, 4 /
7603 DATA (XDPtab(k, 8),k=1,27) /
7604 &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7605 &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7606 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7607 &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7608 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7610 C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
7611 DATA (IDPtab(k, 9),k=1,8) /
7612 & 22, 1, 3, 4, 22, 1, 3, 4 /
7613 DATA (XDPtab(k, 9),k=1,27) /
7614 &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7615 &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7616 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7617 &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7618 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7620 C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
7621 DATA (IDPtab(k, 10),k=1,8) /
7622 & 22, 1, 4, 4, 22, 1, 4, 4 /
7623 DATA (XDPtab(k, 10),k=1,27) /
7624 &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7625 &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7626 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7627 &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7628 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7630 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7631 DATA (IDPtab(k, 11),k=1,8) /
7632 & 22, 3, 1, 3, 2212, 5, 6, 0 /
7633 DATA (XDPtab(k, 11),k=1,27) /
7634 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7635 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7636 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7637 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7638 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7640 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7641 DATA (IDPtab(k, 12),k=1,8) /
7642 & 22, 3, 1, 2, 2212, 5, 6, 0 /
7643 DATA (XDPtab(k, 12),k=1,27) /
7644 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7645 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7646 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7647 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7648 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7650 C parameter set for 22 (LAC ) 22 (LAC )
7651 DATA (IDPtab(k, 13),k=1,8) /
7652 & 22, 3, 1, 3, 22, 3, 1, 3 /
7653 DATA (XDPtab(k, 13),k=1,27) /
7654 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7655 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7656 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7657 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7658 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7660 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7661 DATA (IDPtab(k, 14),k=1,8) /
7662 & 22, 3, 1, 2, 22, 3, 1, 2 /
7663 DATA (XDPtab(k, 14),k=1,27) /
7664 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7665 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7666 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7667 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7668 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7670 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7671 DATA (IDPtab(k, 15),k=1,8) /
7672 & 22, 3, 2, 3, 2212, 5, 6, 0 /
7673 DATA (XDPtab(k, 15),k=1,27) /
7674 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7675 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7676 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7677 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7678 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7680 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7681 DATA (IDPtab(k, 16),k=1,8) /
7682 & 22, 3, 2, 2, 2212, 5, 6, 0 /
7683 DATA (XDPtab(k, 16),k=1,27) /
7684 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7685 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7686 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7687 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7688 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7690 C parameter set for 22 (LAC ) 22 (LAC )
7691 DATA (IDPtab(k, 17),k=1,8) /
7692 & 22, 3, 2, 3, 22, 3, 2, 3 /
7693 DATA (XDPtab(k, 17),k=1,27) /
7694 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7695 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7696 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7697 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7698 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7700 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7701 DATA (IDPtab(k, 18),k=1,8) /
7702 & 22, 3, 2, 2, 22, 3, 2, 2 /
7703 DATA (XDPtab(k, 18),k=1,27) /
7704 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7705 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7706 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7707 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7708 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7710 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7711 DATA (IDPtab(k, 19),k=1,8) /
7712 & 22, 3, 3, 3, 2212, 5, 6, 0 /
7713 DATA (XDPtab(k, 19),k=1,27) /
7714 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7715 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7716 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7717 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7718 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7720 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7721 DATA (IDPtab(k, 20),k=1,8) /
7722 & 22, 3, 3, 2, 2212, 5, 6, 0 /
7723 DATA (XDPtab(k, 20),k=1,27) /
7724 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7725 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7726 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7727 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7728 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7730 C parameter set for 22 (LAC ) 22 (LAC )
7731 DATA (IDPtab(k, 21),k=1,8) /
7732 & 22, 3, 3, 3, 22, 3, 3, 3 /
7733 DATA (XDPtab(k, 21),k=1,27) /
7734 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7735 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7736 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7737 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7738 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7740 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7741 DATA (IDPtab(k, 22),k=1,8) /
7742 & 22, 3, 3, 2, 22, 3, 3, 2 /
7743 DATA (XDPtab(k, 22),k=1,27) /
7744 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7745 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7746 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7747 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7748 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7756 & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7762 C parton distribution functions
7763 CALL PHO_ACTPDF(IFPAP(1),1)
7764 CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7765 CALL PHO_ACTPDF(IFPAP(2),2)
7766 CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7767 C initialize alpha_s calculation
7768 DUMMY = PHO_ALPHAS(0.D0,-4)
7770 IF(IDEB(54).GE.0) THEN
7771 WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7772 & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7773 WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7774 & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7779 C load parameter set from internal tables
7785 IF((IFPAP(I1).EQ.IDPtab(1,I))
7786 & .AND.(IGRP(I1).EQ.IDPtab(2,I))
7787 & .AND.(ISET(I1).EQ.IDPtab(3,I))
7788 & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7789 IF((IFPAP(I2).EQ.IDPtab(5,I))
7790 & .AND.(IGRP(I2).EQ.IDPtab(6,I))
7791 & .AND.(ISET(I2).EQ.IDPtab(7,I))
7792 & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7793 C *** Commented by Chiara
7794 C WRITE(LO,'(/1X,A)')
7795 C & 'PHO_FITPAR: parameter set found in internal table'
7797 ALPOMP = XDPtab(2,I)
7798 GP(I1) = XDPtab(3,I)
7799 GP(I2) = XDPtab(4,I)
7800 B0POM(I1) = XDPtab(5,I)
7801 B0POM(I2) = XDPtab(6,I)
7803 ALREGP = XDPtab(8,I)
7804 GR(I1) = XDPtab(9,I)
7805 GR(I2) = XDPtab(10,I)
7806 B0REG(I1) = XDPtab(11,I)
7807 B0REG(I2) = XDPtab(12,I)
7809 B0PPP = XDPtab(14,I)
7811 B0PPR = XDPtab(16,I)
7812 VDMFAC(2*I1-1) = XDPtab(17,I)
7813 VDMFAC(2*I1) = XDPtab(18,I)
7814 VDMFAC(2*I2-1) = XDPtab(19,I)
7815 VDMFAC(2*I2) = XDPtab(20,I)
7816 B0HAR = XDPtab(21,I)
7817 AKFAC = XDPtab(22,I)
7818 PHISUP(I1) = XDPtab(23,I)
7819 PHISUP(I2) = XDPtab(24,I)
7820 RMASS(I1) = XDPtab(25,I)
7821 RMASS(I2) = XDPtab(26,I)
7834 C *** Commented by Chiara
7835 C WRITE(LO,'(/1X,A)')
7836 C & 'PHO_FITPAR: parameter set not found in internal table'
7841 C get parameters of soft cross sections from fitpar.dat
7842 IF(IPAMDL(99).GT.IFOUND) THEN
7845 & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
7846 OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7849 READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7850 IF(CNAME8.EQ.'STOP') GOTO 1010
7851 IF(CNAME8.EQ.'NEXTDATA') THEN
7852 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7854 IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7855 & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7856 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7858 IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7859 & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7860 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7861 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7862 READ(12,*) ALREG,ALREGP,GR,B0REG
7863 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7864 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7868 READ(12,*) RMASS,VAR
7877 WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7878 WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7881 & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7889 IF(IFOUND.EQ.0) THEN
7890 WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7891 WRITE(LO,'(3(10X,A,/))')
7892 & '(copy fitpar.dat into the working directory and/or',
7893 & ' request the missing parameter set via e-mail from',
7894 & ' eng@lepton.bartol.udel.edu)'
7900 C overwrite parameters with user settings
7901 IF(PARMDL(301).GT.DEFA) THEN
7905 IF(PARMDL(302).GT.DEFA) THEN
7906 ALPOMP = PARMDL(302)
7909 IF(PARMDL(303).GT.DEFA) THEN
7913 IF(PARMDL(304).GT.DEFA) THEN
7917 IF(PARMDL(305).GT.DEFA) THEN
7918 B0POM(1) = PARMDL(305)
7921 IF(PARMDL(306).GT.DEFA) THEN
7922 B0POM(2) = PARMDL(306)
7925 IF(PARMDL(307).GT.DEFA) THEN
7929 IF(PARMDL(308).GT.DEFA) THEN
7930 ALREGP = PARMDL(308)
7933 IF(PARMDL(309).GT.DEFA) THEN
7937 IF(PARMDL(310).GT.DEFA) THEN
7941 IF(PARMDL(311).GT.DEFA) THEN
7942 B0REG(1) = PARMDL(311)
7945 IF(PARMDL(312).GT.DEFA) THEN
7946 B0REG(2) = PARMDL(312)
7949 IF(PARMDL(313).GT.DEFA) THEN
7953 IF(PARMDL(314).GT.DEFA) THEN
7957 IF(PARMDL(315).GT.DEFA) THEN
7958 VDMFAC(1) = PARMDL(315)
7961 IF(PARMDL(316).GT.DEFA) THEN
7962 VDMFAC(2) = PARMDL(316)
7965 IF(PARMDL(317).GT.DEFA) THEN
7966 VDMFAC(3) = PARMDL(317)
7969 IF(PARMDL(318).GT.DEFA) THEN
7970 VDMFAC(4) = PARMDL(318)
7973 IF(PARMDL(319).GT.DEFA) THEN
7977 IF(PARMDL(320).GT.DEFA) THEN
7981 IF(PARMDL(321).GT.DEFA) THEN
7982 PHISUP(1) = PARMDL(321)
7985 IF(PARMDL(322).GT.DEFA) THEN
7986 PHISUP(2) = PARMDL(322)
7989 IF(PARMDL(323).GT.DEFA) THEN
7990 RMASS(1) = PARMDL(323)
7993 IF(PARMDL(324).GT.DEFA) THEN
7994 RMASS(2) = PARMDL(324)
7997 IF(PARMDL(325).GT.DEFA) THEN
8001 IF(PARMDL(327).GT.DEFA) THEN
8005 IF(PARMDL(328).GT.DEFA) THEN
8010 VDMQ2F(1) = VDMFAC(1)
8011 VDMQ2F(2) = VDMFAC(2)
8012 VDMQ2F(3) = VDMFAC(3)
8013 VDMQ2F(4) = VDMFAC(4)
8015 C output of parameter set
8016 C *** Commented by Chiara
8017 C IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8018 C WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8019 C & ' -------------------------'
8020 C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8021 C & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8023 C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8024 C & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8026 C WRITE(LO,'(4(A,F7.3))')
8027 C & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8028 C WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8029 C WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8030 C WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
8031 C WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
8032 C WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8033 C WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
8036 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8040 CDECK ID>, PHO_BORNCS
8041 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8042 C*********************************************************************
8044 C calculation of Born graph cross sections and slopes
8046 C input: IP particle combination
8047 C IFHARD -1 calculate hard Born graph cross section
8048 C 0 take hard Born graph cross section
8049 C from interpolation table if available
8050 C 1 assume that correct hard cross
8051 C sections are already stored in /POSBRN/
8052 C XM1,XM2,XM3,XM4 masses of external lines
8053 C /GLOCMS/ energy and PT cut-off
8054 C /POPREG/ soft and hard parameters
8055 C /POSBRN/ input cross sections
8056 C /POZBRN/ scaled input values
8057 C IFHARD 0 calculate hard input cross sections
8058 C 1 assume hard input cross sections exist
8060 C output: ZPOM scaled pomeron cross section
8061 C ZIGR scaled reggeon cross section
8062 C ZIGHR scaled hard resolved cross section
8063 C ZIGHD scaled hard direct cross section
8064 C ZIGT1 scaled triple-Pomeron cross section
8065 C ZIGT2 scaled triple-Pomeron cross section
8066 C ZIGL scaled loop-Pomeron cross section
8068 C*********************************************************************
8069 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8081 C input/output channels
8083 COMMON /POINOU/ LI,LO
8085 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8086 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8087 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8088 C event debugging information
8090 PARAMETER (NMAXD=100)
8091 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8092 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8093 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8094 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8095 C model switches and parameters
8097 INTEGER ISWMDL,IPAMDL
8098 DOUBLE PRECISION PARMDL
8099 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8100 C names of hard scattering processes
8102 PARAMETER ( Max_pro_1 = 16 )
8104 COMMON /POHPRO/ PROC(0:Max_pro_1)
8105 C hard cross sections and MC selection weights
8107 PARAMETER ( Max_pro_2 = 16 )
8108 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8110 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8111 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8112 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8113 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8114 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8115 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8116 C interpolation tables for hard cross section and MC selection weights
8117 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8118 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8119 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8120 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8121 & HQ2a_tab,HQ2b_tab,HEcm_tab
8123 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8124 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8125 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8126 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8127 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8128 & HEcm_tab(1:Max_tab_E,0:4),
8129 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8130 C Born graph cross sections and slopes
8132 PARAMETER ( Max_pro_3 = 16 )
8133 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8135 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8136 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8137 C scaled cross sections and slopes
8138 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8140 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8141 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8142 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8143 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8145 C Reggeon phenomenology parameters
8146 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8147 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8148 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8149 & ALREG,ALREGP,GR(2),B0REG(2),
8150 & GPPP,GPPR,B0PPP,B0PPR,
8151 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8152 C parameters of 2x2 channel model
8153 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8154 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8155 C data of c.m. system of Pomeron / Reggeon exchange
8156 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8157 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8158 & SIDP,CODP,SIFP,COFP
8159 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8160 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8161 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8162 C obsolete cut-off information
8163 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8164 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8165 C data needed for soft-pt calculation
8166 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8167 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8169 COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8170 & BPOM1,BPOM2,BREG1,BREG2,B0HARD
8171 DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8172 DIMENSION BT14(2),BT24(2),BD4(4)
8173 DIMENSION DSPT(0:Max_pro_2)
8175 DATA XMPOM / 0.766D0 /
8176 DATA CZERO /(0.D0,0.D0)/
8179 DCMPLX(X,Y) = CMPLX(X,Y)
8182 IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8183 & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8185 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8187 C calculate hard input cross sections (output in mb)
8188 IF(IFHARD.NE.1) THEN
8189 IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8190 C double-log interpolation
8191 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8198 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8199 CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8202 C save values to calculate soft pt distribution
8204 VDMQ2F(1) = VDMFAC(1)
8205 VDMQ2F(2) = VDMFAC(2)
8206 VDMQ2F(3) = VDMFAC(3)
8207 VDMQ2F(4) = VDMFAC(4)
8208 ELSE IF(IP.EQ.2) THEN
8209 VDMQ2F(1) = VDMFAC(1)
8210 VDMQ2F(2) = VDMFAC(2)
8213 ELSE IF(IP.EQ.3) THEN
8214 VDMQ2F(1) = VDMFAC(3)
8215 VDMQ2F(2) = VDMFAC(4)
8225 AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8226 AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8227 AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8228 AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8229 ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8230 & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8231 ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8232 ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8233 ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8234 VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8235 & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8236 DSIGHP = DSPT(9)/VFAC
8237 SIGH = DSIGH(9)/VFAC
8239 IF(IPAMDL(1).EQ.0) THEN
8241 DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8245 IF(IDEB(48).GE.15) THEN
8246 WRITE(LO,'(/1X,A,1P,2E11.3)')
8247 & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8248 DO 200 I=0,Max_pro_2
8249 WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8254 C DPMJET interface: subtract anomalous part
8255 IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8256 & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8258 SCALE = CDABS(DSIGH(15))
8259 IF(SCALE.LT.DEPS) THEN
8264 SCALE = CDABS(DSIGH(9))
8265 IF(SCALE.LT.DEPS) THEN
8268 SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8271 C calculate soft input cross sections (output in mb)
8272 SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8273 IF(IPAMDL(1).EQ.1) THEN
8275 SP=SS*DCMPLX(0.D0,-1.D0)
8277 SR=SS*DCMPLX(0.D0,1.D0)
8282 C coupling constants (mb**1/2)
8283 C particle dependent slopes (GeV**-2)
8296 ELSE IF(IP.EQ.2) THEN
8300 GR2 = PARMDL(77)*GPPR/GPPP
8305 B0HARD = B0POM1+B0POM2
8308 ELSE IF(IP.EQ.3) THEN
8312 GR2 = PARMDL(77)*GPPR/GPPP
8317 B0HARD = B0POM1+B0POM2
8320 ELSE IF(IP.EQ.4) THEN
8323 GR1 = PARMDL(77)*GPPR/GPPP
8329 B0HARD = B0POM1+B0POM2
8333 WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8340 C input slope parameters (GeV**-2)
8341 BPOM1 = B0POM1*SCALB1
8342 BPOM2 = B0POM2*SCALB2
8343 BREG1 = B0REG1*SCALB1
8344 BREG2 = B0REG2*SCALB2
8346 XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8347 SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8348 BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8349 BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8350 IF(IPAMDL(9).EQ.0) THEN
8353 ELSE IF(IPAMDL(9).EQ.1) THEN
8354 BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8356 ELSE IF(IPAMDL(9).EQ.2) THEN
8363 C input cross section pomeron
8364 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8365 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8366 C save value to calculate soft pt distribution
8367 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8369 C higher order graphs
8372 C bare/renormalized intercept for enhanced graphs
8373 IF(IPAMDL(8).EQ.0) THEN
8376 DELTAP = PARMDL(48)-1.D0
8381 C input cross section high-mass double diffraction
8382 CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8383 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8384 SIGL = DCMPLX(SIGTR,0.D0)
8385 BLOO = DCMPLX(BTR,0.D0)
8387 C input cross section high mass diffraction particle 1
8389 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8390 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8391 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8392 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8393 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8394 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8395 BP1 = 2.D0*BPOM1*SCALB1
8396 BP2 = 2.D0*BPOM2*SCALB2
8397 C input cross section high mass diffraction
8398 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8399 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8400 SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8401 BTR1(1) = DCMPLX(BTR,0.D0)
8402 C second possibility: high-low mass double diffraction
8403 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8404 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8405 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8406 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8407 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8408 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8409 BP1 = 2.D0*BPOM1*SCALB1
8410 BP2 = 2.D0*BPOM2*SCALB2
8411 C input cross section high mass diffraction
8412 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8413 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8414 SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8415 BTR1(2) = DCMPLX(BTR,0.D0)
8417 C input cross section high mass diffraction particle 2
8419 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8420 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8421 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8422 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8423 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8424 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8425 BP1 = 2.D0*BPOM1*SCALB1
8426 BP2 = 2.D0*BPOM2*SCALB2
8427 C input cross section high mass diffraction
8428 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8429 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8430 SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8431 BTR2(1) = DCMPLX(BTR,0.D0)
8432 C second possibility: high-low mass double diffraction
8433 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8434 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8435 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8436 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8437 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8438 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8439 BP1 = 2.D0*BPOM1*SCALB1
8440 BP2 = 2.D0*BPOM2*SCALB2
8441 C input cross section high mass diffraction
8442 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8443 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8444 SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8445 BTR2(2) = DCMPLX(BTR,0.D0)
8447 C input cross section for loop-pomeron
8449 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8450 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8451 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8452 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8453 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8454 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8455 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8456 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8457 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8458 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8461 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8463 SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8464 BDP(1) = DCMPLX(BTX,0.D0)
8465 C second possibility
8466 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8467 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8468 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8469 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8470 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8471 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8472 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8473 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8474 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8475 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8478 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8480 SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8481 BDP(2) = DCMPLX(BTX,0.D0)
8483 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8484 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8485 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8486 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8487 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8488 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8489 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8490 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8491 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8492 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8495 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8497 SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8498 BDP(3) = DCMPLX(BTX,0.D0)
8499 C fourth possibility
8500 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8501 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8502 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8503 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8504 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8505 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8506 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8507 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8508 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8509 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8512 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8514 SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8515 BDP(4) = DCMPLX(BTX,0.D0)
8517 C input cross section for YY-iterated triple-pomeron
8520 C write out input cross sections
8521 IF(IDEB(48).GE.5) THEN
8522 WRITE(LO,'(2(/1X,A))')
8523 & 'Born graph input cross sections and slopes',
8524 & '------------------------------------------'
8525 WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
8526 WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8528 WRITE(LO,'(A)') ' input cross sections (millibarn):'
8529 WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
8530 WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
8531 WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
8532 WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
8533 WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
8534 WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
8535 WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
8536 WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8537 WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8538 WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8539 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8540 WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
8541 WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
8542 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8543 WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
8544 WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
8545 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8546 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8547 WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
8548 WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
8549 WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
8550 WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
8551 WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
8552 WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
8559 BTR1(1) = BTR1(1)*GEV2MB
8560 BTR1(2) = BTR1(2)*GEV2MB
8561 BTR2(1) = BTR2(1)*GEV2MB
8562 BTR2(2) = BTR2(2)*GEV2MB
8569 BT14(1)=BTR1(1)*4.D0
8570 BT14(2)=BTR1(2)*4.D0
8571 BT24(1)=BTR2(1)*4.D0
8572 BT24(2)=BTR2(2)*4.D0
8575 ZIGP = SIGP/(PI2*BP4)
8576 ZIGR = SIGR/(PI2*BR4)
8577 ZIGHR = SIGHR/(PI2*BHR4)
8578 ZIGHD = SIGHD/(PI2*BHD4)
8579 ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8580 ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8581 ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8582 ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8583 ZIGL = SIGL/(PI2*BL4)
8585 BDP(I) = BDP(I)*GEV2MB
8586 BD4(I) = BDP(I)*4.D0
8587 ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8590 IF(IDEB(48).GE.10) THEN
8591 WRITE(LO,'(A)') ' normalized input values:'
8592 WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
8593 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8594 WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
8595 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8596 WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
8597 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8598 WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
8599 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8600 WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
8601 WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
8602 WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
8603 WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8604 WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8608 CDECK ID>, PHO_SCALES
8609 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8610 C**********************************************************************
8612 C calculation of scale factors
8613 C (mass dependent couplings and slopes)
8615 C input: XM1..XM4 external masses
8617 C output: SCG1,SCG2 scales of coupling constants
8618 C SCB1,SCB2 scales of coupling slope parameter
8620 C*********************************************************************
8621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8624 PARAMETER ( EPS = 1.D-3 )
8626 C input/output channels
8628 COMMON /POINOU/ LI,LO
8629 C event debugging information
8631 PARAMETER (NMAXD=100)
8632 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8633 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8634 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8635 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8636 C Reggeon phenomenology parameters
8637 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8638 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8639 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8640 & ALREG,ALREGP,GR(2),B0REG(2),
8641 & GPPP,GPPR,B0PPP,B0PPR,
8642 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8643 C parameters of 2x2 channel model
8644 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8645 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8646 C data of c.m. system of Pomeron / Reggeon exchange
8647 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8648 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8649 & SIDP,CODP,SIFP,COFP
8650 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8651 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8652 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8653 C model switches and parameters
8655 INTEGER ISWMDL,IPAMDL
8656 DOUBLE PRECISION PARMDL
8657 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8659 C scale factors for couplings
8663 IF(ABS(XM1-XM3).GT.EPS) THEN
8664 IF(ECMP.LT.ECMTP) THEN
8665 SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8672 IF(ABS(XM2-XM4).GT.EPS) THEN
8673 IF(ECMP.LT.ECMTP) THEN
8674 SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8682 C scale factors for slope parameters
8683 IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8686 ELSE IF(ISWMDL(1).EQ.2) THEN
8688 SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8689 SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8690 ELSE IF(ISWMDL(1).GE.3) THEN
8691 C symmetric gaussian
8692 SCB1 = VAR*(XM1-XM3)**2
8693 IF(SCB1.LT.25.D0) THEN
8698 SCB2 = VAR*(XM2-XM4)**2
8699 IF(SCB2.LT.25.D0) THEN
8705 WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8710 IF(IDEB(65).GE.10) THEN
8711 WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8713 WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8714 & SCB1,SCB2,SCG1,SCG2
8718 CDECK ID>, PHO_EIKON
8719 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8720 C*********************************************************************
8722 C calculation of unitarized amplitudes
8724 C input: IP particle combination
8725 C IFHARD -1 ignore previously calculated Born
8727 C 0 calculate hard Born cross sections or
8728 C take them from interpolation table
8730 C 1 take hard cross sections from /POSBRN/
8731 C B impact parameter (mb**(1/2))
8732 C /POSBRN/ input cross sections
8733 C /GLOCMS/ cm energy
8734 C /POPREG/ soft and hard parameters
8737 C AMPEL purely elastic amplitude
8738 C AMPVM quasi-elastically vectormeson prod.
8739 C AMLMSD(2) amplitudes of low mass sing. diffr.
8740 C AMHMSD(2) amplitudes of high mass sing. diffr.
8741 C AMLMDD amplitude of low mass double diffr.
8742 C AMHMDD amplitude of high mass double diffr.
8744 C*********************************************************************
8745 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8758 C input/output channels
8760 COMMON /POINOU/ LI,LO
8761 C event debugging information
8763 PARAMETER (NMAXD=100)
8764 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8765 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8766 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8767 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8768 C complex Born graph amplitudes used for unitarization
8769 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8771 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8772 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8774 INTEGER IPFIL,IFAFIL,IFBFIL
8775 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8776 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8777 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8778 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8779 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8780 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8781 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8782 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8783 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8784 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8785 & IPFIL,IFAFIL,IFBFIL
8786 C Born graph cross sections and slopes
8788 PARAMETER ( Max_pro_3 = 16 )
8789 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8791 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8792 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8793 C scaled cross sections and slopes
8794 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8796 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8797 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8798 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8799 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8801 C Born graph cross sections after applying diffraction model
8802 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8804 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8805 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8807 C global event kinematics and particle IDs
8809 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8810 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8811 C data of c.m. system of Pomeron / Reggeon exchange
8812 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8813 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8814 & SIDP,CODP,SIFP,COFP
8815 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8816 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8817 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8818 C Reggeon phenomenology parameters
8819 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8820 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8821 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8822 & ALREG,ALREGP,GR(2),B0REG(2),
8823 & GPPP,GPPR,B0PPP,B0PPR,
8824 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8825 C parameters of 2x2 channel model
8826 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8827 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8828 C model switches and parameters
8830 INTEGER ISWMDL,IPAMDL
8831 DOUBLE PRECISION PARMDL
8832 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8833 C unitarized amplitudes for different diffraction channels
8834 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8835 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8836 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8838 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8839 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8840 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8841 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8842 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8843 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8846 COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8847 & AUXL,AMPR,AMPO,AMPP,AMPQ
8853 DATA PVOLD / -1.D0, -1.D0 /
8854 DATA XMPOM / 0.766D0 /
8855 DATA XMVDM / 0.766D0 /
8857 DCMPLX(X,Y) = CMPLX(X,Y)
8859 C calculation of scaled cross sections and slopes
8861 C test for redundant calculation
8862 IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8863 & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8864 C effective particle masses, VDM assumption
8869 IF(IFPAP(1).EQ.22) THEN
8871 ELSE IF(IFPAP(1).EQ.990) THEN
8874 IF(IFPAP(2).EQ.22) THEN
8876 ELSE IF(IFPAP(2).EQ.990) THEN
8879 C different particle combinations
8883 ELSE IF(IP.EQ.4) THEN
8891 C update pomeron CM system
8896 CZERO = DCMPLX(0.D0,0.D0)
8897 CONE = DCMPLX(1.D0,0.D0)
8903 C purely elastic scattering
8904 CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8913 ZXT1A(1,1) = ZIGT1(1)
8914 BXT1A(1,1) = BTR1(1)
8915 ZXT1B(1,1) = ZIGT1(2)
8916 BXT1B(1,1) = BTR1(2)
8917 ZXT2A(1,1) = ZIGT2(1)
8918 BXT2A(1,1) = BTR2(1)
8919 ZXT2B(1,1) = ZIGT2(2)
8920 BXT2B(1,1) = BTR2(2)
8923 ZXDPE(1,1) = ZIGDP(1)
8925 ZXDPA(1,1) = ZIGDP(2)
8927 ZXDPB(1,1) = ZIGDP(3)
8929 ZXDPD(1,1) = ZIGDP(4)
8935 SBOTR1(1,1) = SIGT1(1)
8936 SBOTR1(1,2) = SIGT1(2)
8937 SBOTR2(1,1) = SIGT2(1)
8938 SBOTR2(1,2) = SIGT2(2)
8940 SBODPO(1,1) = SIGDP(1)
8941 SBODPO(1,2) = SIGDP(2)
8942 SBODPO(1,3) = SIGDP(3)
8943 SBODPO(1,4) = SIGDP(4)
8945 C low mass single diffractive scattering 1
8946 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8955 ZXT1A(1,2) = ZIGT1(1)
8956 BXT1A(1,2) = BTR1(1)
8957 ZXT1B(1,2) = ZIGT1(2)
8958 BXT1B(1,2) = BTR1(2)
8959 ZXT2A(1,2) = ZIGT2(1)
8960 BXT2A(1,2) = BTR2(1)
8961 ZXT2B(1,2) = ZIGT2(2)
8962 BXT2B(1,2) = BTR2(2)
8965 ZXDPE(1,2) = ZIGDP(1)
8967 ZXDPA(1,2) = ZIGDP(2)
8969 ZXDPB(1,2) = ZIGDP(3)
8971 ZXDPD(1,2) = ZIGDP(4)
8977 SBOTR1(2,1) = SIGT1(1)
8978 SBOTR1(2,2) = SIGT1(2)
8979 SBOTR2(2,1) = SIGT2(1)
8980 SBOTR2(2,2) = SIGT2(2)
8982 SBODPO(2,1) = SIGDP(1)
8983 SBODPO(2,2) = SIGDP(2)
8984 SBODPO(2,3) = SIGDP(3)
8985 SBODPO(2,4) = SIGDP(4)
8987 C low mass single diffractive scattering 2
8988 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
8997 ZXT1A(1,3) = ZIGT1(1)
8998 BXT1A(1,3) = BTR1(1)
8999 ZXT1B(1,3) = ZIGT1(2)
9000 BXT1B(1,3) = BTR1(2)
9001 ZXT2A(1,3) = ZIGT2(1)
9002 BXT2A(1,3) = BTR2(1)
9003 ZXT2B(1,3) = ZIGT2(2)
9004 BXT2B(1,3) = BTR2(2)
9007 ZXDPE(1,3) = ZIGDP(1)
9009 ZXDPA(1,3) = ZIGDP(2)
9011 ZXDPB(1,3) = ZIGDP(3)
9013 ZXDPD(1,3) = ZIGDP(4)
9019 SBOTR1(3,1) = SIGT1(1)
9020 SBOTR1(3,2) = SIGT1(2)
9021 SBOTR2(3,1) = SIGT2(1)
9022 SBOTR2(3,2) = SIGT2(2)
9024 SBODPO(3,1) = SIGDP(1)
9025 SBODPO(3,2) = SIGDP(2)
9026 SBODPO(3,3) = SIGDP(3)
9027 SBODPO(3,4) = SIGDP(4)
9029 C low mass double diffractive scattering
9030 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9039 ZXT1A(1,4) = ZIGT1(1)
9040 BXT1A(1,4) = BTR1(1)
9041 ZXT1B(1,4) = ZIGT1(2)
9042 BXT1B(1,4) = BTR1(2)
9043 ZXT2A(1,4) = ZIGT2(1)
9044 BXT2A(1,4) = BTR2(1)
9045 ZXT2B(1,4) = ZIGT2(2)
9046 BXT2B(1,4) = BTR2(2)
9049 ZXDPE(1,4) = ZIGDP(1)
9051 ZXDPA(1,4) = ZIGDP(2)
9053 ZXDPB(1,4) = ZIGDP(3)
9055 ZXDPD(1,4) = ZIGDP(4)
9061 SBOTR1(4,1) = SIGT1(1)
9062 SBOTR1(4,2) = SIGT1(2)
9063 SBOTR2(4,1) = SIGT2(1)
9064 SBOTR2(4,2) = SIGT2(2)
9066 SBODPO(4,1) = SIGDP(1)
9067 SBODPO(4,2) = SIGDP(2)
9068 SBODPO(4,3) = SIGDP(3)
9069 SBODPO(4,4) = SIGDP(4)
9071 C calculate Born graph cross sections
9086 SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9087 SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9088 SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9089 SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9090 SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9091 SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9092 SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9093 SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9094 SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9095 SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9096 SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9097 SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9098 SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9103 SIGTR1(1) = SBOTR1(0,1)
9104 SIGTR1(2) = SBOTR1(0,2)
9105 SIGTR2(1) = SBOTR2(0,1)
9106 SIGTR2(2) = SBOTR2(0,2)
9108 SIGDPO(1) = SBODPO(0,1)
9109 SIGDPO(2) = SBODPO(0,2)
9110 SIGDPO(3) = SBODPO(0,3)
9111 SIGDPO(4) = SBODPO(0,4)
9116 B24=DCMPLX(B**2,0.D0)/4.D0
9132 IF(ISWMDL(1).LT.3) THEN
9134 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9136 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9137 C hard resolved processes
9138 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9139 C hard direct processes
9140 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9141 C triple-Pomeron: baryon high mass diffraction
9142 AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9143 & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9144 C triple-Pomeron: photon/meson high mass diffraction
9145 AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9146 & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9148 AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
9151 IF(ISWMDL(1).EQ.0) THEN
9152 AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9153 & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9154 & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9156 AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9157 & +AUXT1+AUXT2+AUXL))
9158 AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9159 & +AUXT1+AUXT2+AUXL))
9160 AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9161 & +AUXT1+AUXT2+AUXL))
9162 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9163 & +AUXT1+AUXT2+AUXL))
9165 ELSE IF(ISWMDL(1).EQ.1) THEN
9166 AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9167 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9168 AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9169 & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9170 AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9171 & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9172 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9173 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9174 AMPEL = SQRT(VDMQ2F(1))*AMPR
9175 & + SQRT(VDMQ2F(2))*AMPO
9176 & + SQRT(VDMQ2F(3))*AMPP
9177 & + SQRT(VDMQ2F(4))*AMPQ
9180 C simple analytic two channel model (version A)
9181 ELSE IF(ISWMDL(1).EQ.3) THEN
9185 WRITE(LO,'(1X,A,I2)')
9186 & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9192 CDECK ID>, PHO_DSIGDT
9193 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9194 C*********************************************************************
9196 C calculation of unitarized amplitude
9197 C and differential cross section
9199 C input: EE cm energy (GeV)
9200 C XTA(1,*) t values (GeV**2)
9201 C NFILL entries in t table
9203 C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9204 C XTA(3,*) DSIG/DT g p --> rho0 h/V
9205 C XTA(4,*) DSIG/DT g p --> omega0 h/V
9206 C XTA(5,*) DSIG/DT g p --> phi h/V
9207 C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9209 C*********************************************************************
9210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9218 DIMENSION XTA(6,NFILL)
9220 C input/output channels
9222 COMMON /POINOU/ LI,LO
9224 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9225 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9226 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9227 C integration precision for hard cross sections (obsolete)
9228 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9229 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9230 C event debugging information
9232 PARAMETER (NMAXD=100)
9233 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9234 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9235 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9236 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9237 C global event kinematics and particle IDs
9239 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9240 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9241 C complex Born graph amplitudes used for unitarization
9242 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9244 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9245 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9247 COMPLEX*16 XT,AMP,CZERO
9248 DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
9251 CDABS(AMPEL) = ABS(AMPEL)
9252 DCMPLX(X,Y) = CMPLX(X,Y)
9254 CZERO=DCMPLX(0.D0,0.D0)
9259 IF(NFILL.GT.100) THEN
9260 WRITE(LO,'(1X,A,I4)')
9261 & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9271 C impact parameter integration
9272 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9274 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9276 IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9279 ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9282 ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9299 C calculate amplitudes
9301 CALL PHO_EIKON(1,-1,XPNT(I))
9303 CALL PHO_EIKON(1,1,XPNT(I))
9306 AMP(2) = AMPVM(I1,I2)
9307 AMP(3) = AMPVM(J1,J2)
9308 AMP(4) = AMPVM(K1,K2)
9309 AMP(5) = AMPVM(L1,L2)
9312 XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9313 FAC = PHO_BESSJ0(XX)*WG
9315 XT(1,J)=XT(1,J)+AMP(K)*FAC
9320 C change units to mb/GeV**2
9321 FAC = 4.D0*PI/GEV2MB
9322 FNA = '(mb/GeV**2) '
9325 FNA = '(mub/GeV**2)'
9326 ELSE IF(I1+I2.EQ.2) THEN
9327 FAC = FAC*THOUS*THOUS
9328 FNA = '(nb/GeV**2) '
9330 IF(IDEB(56).GE.5) THEN
9331 WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
9332 & FNA,'------------------------------------------'
9336 XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9338 IF(IDEB(56).GE.5) THEN
9339 WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9346 CDECK ID>, PHO_XSECT
9347 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9348 C*********************************************************************
9350 C calculation of physical cross sections
9352 C input: IP particle combination
9353 C IFHARD -1 reset Born graph cross section tables
9354 C 0 calculate hard cross sections or take them
9355 C from interpolation table (if available)
9356 C 1 assume that hard cross sections are already
9357 C calculated and stored in /POSBRN/
9358 C EE cms energy (GeV)
9360 C output: /POSBRN/ input cross sections
9361 C /POZBRN/ scaled input cross values
9362 C /POCSEC/ physical cross sections and slopes
9364 C slopes in GeV**-2, cross sections in mb
9366 C*********************************************************************
9367 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9370 PARAMETER(ONEM=-1.D0,
9374 C input/output channels
9376 COMMON /POINOU/ LI,LO
9378 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9379 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9380 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9381 C event debugging information
9383 PARAMETER (NMAXD=100)
9384 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9385 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9386 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9387 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9388 C integration precision for hard cross sections (obsolete)
9389 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9390 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9391 C model switches and parameters
9393 INTEGER ISWMDL,IPAMDL
9394 DOUBLE PRECISION PARMDL
9395 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9396 C Born graph cross sections and slopes
9398 PARAMETER ( Max_pro_3 = 16 )
9399 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9401 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9402 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9404 INTEGER IPFIL,IFAFIL,IFBFIL
9405 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9406 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9407 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9408 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9409 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9410 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9411 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9412 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9413 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9414 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9415 & IPFIL,IFAFIL,IFBFIL
9416 C global event kinematics and particle IDs
9418 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9419 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9421 CHARACTER*15 PHO_PNAME
9423 C complex Born graph amplitudes used for unitarization
9424 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9426 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9427 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9429 DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9430 CHARACTER*8 VMESA(0:4),VMESB(0:4)
9431 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
9433 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
9436 CDABS(AMPEL) = ABS(AMPEL)
9439 IF(EE.LT.0.D0) GOTO 500
9442 C impact parameter integration
9443 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9445 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9472 WG = WGHT(I)*XPNT(I)
9475 C calculate impact parameter amplitude, results in /POINT4/
9477 CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9479 CALL PHO_EIKON(IP,1,XPNT(I))
9482 SIGTOT = SIGTOT + DREAL(AMPEL)*WG
9483 SIGELA = SIGELA + CDABS(AMPEL)**2*WG
9484 SLEL1 = SLEL1 + AMPEL*WGB
9485 SLEL2 = SLEL2 + AMPEL*WG
9489 SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9490 SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9491 SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9493 SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
9496 SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9497 SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9498 SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
9499 SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
9500 SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
9501 SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9502 SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9503 SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
9507 SIGDIR = DREAL(SIGHD)
9511 FACSL = 0.5D0/GEV2MB
9512 SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
9514 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9517 SIGVM(I,J) = SIGVM(I,J)*FAC
9518 SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9526 SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9527 SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9529 SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9533 C diffractive cross sections
9535 SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9536 SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9537 SIGLDD = SIGLDD *FAC*PARMDL(42)
9538 SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9539 SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9540 SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9543 C double pomeron scattering
9547 SIGCDF(I) = SIGCDF(I)*FAC
9548 SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9551 SIG1SO = SIG1SO *FAC
9552 SIG1HA = SIG1HA *FAC
9554 SIGINE = SIGTOT - SIGELA
9556 C user-forced change of diffractive cross section
9558 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9560 C use optional explicit parametrization for single-diffraction
9562 SIGSD1 = SIGLSD(1)+SIGHSD(1)
9563 SIGSD2 = SIGLSD(2)+SIGHSD(2)
9566 XI_MAX = PARMDL(45)**2
9567 CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9568 & SIG_SD1,SIG_SD2,SIG_DD)
9569 SIG_SD1 = SIG_SD1*PARMDL(40)
9570 SIG_SD2 = SIG_SD2*PARMDL(41)
9573 C DEL_SD1 = SIG_SD1-SIGSD1
9574 DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9577 FAC = SIGLSD(1)/SIGSD1
9578 SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9579 SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9581 C DEL_SD2 = SIG_SD2-SIGSD2
9582 DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9584 FAC = SIGLSD(2)/SIGSD2
9585 SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9586 SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9588 IF(ISWMDL(30).GE.2) THEN
9590 C use explicit parametrization also for double diffraction diss.
9591 SIGDD = SIGLDD+SIGHDD
9592 SIG_DD = SIG_DD*PARMDL(42)
9593 DEL_DD = SIG_DD-SIGDD
9595 SIGLDD = SIGLDD+FAC*DEL_DD
9596 SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9597 SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9601 C rescale double diffraction cross sections
9602 SIGLDD = SIGLDD *PARMDL(42)
9603 SIGHDD = SIGHDD *PARMDL(42)
9604 SIGCOR = DEL_SD1 + DEL_SD2
9605 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9611 C rescale unitarized cross sections for diffraction dissociation
9613 SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9614 SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9615 SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9616 SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9617 SIGLDD = SIGLDD *PARMDL(42)
9618 SIGHDD = SIGHDD *PARMDL(42)
9619 SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9620 & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9621 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9625 C non-diffractive inelastic cross section
9627 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9628 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9631 C specify elastic scattering channel
9634 IF(IFPAP(1).NE.22) THEN
9635 VMESA(1) = PHO_PNAME(IFPAB(1),0)
9639 IF(IFPAP(2).NE.22) THEN
9640 VMESB(1) = PHO_PNAME(IFPAB(2),0)
9645 C write out physical cross sections
9647 IF(IDEB(57).GE.5) THEN
9648 WRITE(LO,'(/1X,A,I3,/1X,A)')
9649 & 'PHO_XSECT: cross sections (mb) for combination',IP,
9650 & '----------------------------------------------'
9651 WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9652 WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
9653 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
9654 WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
9655 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9656 & SIGLSD(1)+SIGHSD(1)
9657 IF(IDEB(57).GE.7) THEN
9658 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
9659 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
9661 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9662 & SIGLSD(2)+SIGHSD(2)
9663 IF(IDEB(57).GE.7) THEN
9664 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
9665 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
9667 WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
9668 IF(IDEB(57).GE.7) THEN
9669 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
9670 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
9672 WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
9673 IF(IDEB(57).GE.7) THEN
9674 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
9675 WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9676 WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9677 WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
9679 WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
9682 IF(SIGVM(I,J).GT.DEPS) THEN
9683 WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9685 WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9686 IF((I.NE.0).AND.(J.NE.0))
9687 & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9691 IF(IDEB(57).GE.7) THEN
9692 WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9693 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
9694 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
9695 WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
9696 WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
9697 WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9698 WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
9707 CDECK ID>, PHO_IMPAMP
9708 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9709 C*********************************************************************
9711 C calculation of physical impact parameter amplitude
9713 C input: EE cm energy (GeV)
9714 C BMIN lower bound in B
9715 C BMAX upper bound in B
9716 C NSTEP number of values (linear)
9718 C output: values written to output unit
9720 C*********************************************************************
9721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9724 PARAMETER(ONEM=-1.D0,
9728 C input/output channels
9730 COMMON /POINOU/ LI,LO
9731 C event debugging information
9733 PARAMETER (NMAXD=100)
9734 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9735 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9736 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9737 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9738 C model switches and parameters
9740 INTEGER ISWMDL,IPAMDL
9741 DOUBLE PRECISION PARMDL
9742 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9743 C global event kinematics and particle IDs
9745 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9746 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9747 C complex Born graph amplitudes used for unitarization
9748 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9750 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9751 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9754 BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9756 WRITE(LO,'(3(/,1X,A))')
9757 & 'impact parameter amplitudes:',
9758 & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
9759 & '-------------------------------------------------------------'
9763 C calculate impact parameter amplitudes
9765 CALL PHO_EIKON(1,-1,BMIN)
9767 CALL PHO_EIKON(1,1,BB)
9769 WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9770 & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9771 & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9777 CDECK ID>, PHO_PRBDIS
9778 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9779 C*********************************************************************
9781 C calculation of multi interactions probabilities
9783 C input: IP particle combination to scatter
9785 C IE index for weight storing
9787 C IMAX max. number of soft pomeron interactions
9788 C KMAX max. number of hard pomeron interactions
9791 C PROB field of probabilities
9793 C*********************************************************************
9794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9797 PARAMETER ( EPS=1.D-10 )
9799 C input/output channels
9801 COMMON /POINOU/ LI,LO
9802 C event debugging information
9804 PARAMETER (NMAXD=100)
9805 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9806 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9807 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9808 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9809 C Reggeon phenomenology parameters
9810 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9811 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9812 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9813 & ALREG,ALREGP,GR(2),B0REG(2),
9814 & GPPP,GPPR,B0PPP,B0PPR,
9815 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9816 C parameters of 2x2 channel model
9817 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9818 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9819 C Born graph cross sections and slopes
9821 PARAMETER ( Max_pro_3 = 16 )
9822 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9824 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9825 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9826 C obsolete cut-off information
9827 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9828 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9829 C Born graph cross sections after applying diffraction model
9830 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9832 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9833 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9836 INTEGER IPFIL,IFAFIL,IFBFIL
9837 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9838 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9839 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9840 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9841 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9842 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9843 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9844 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9845 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9846 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9847 & IPFIL,IFAFIL,IFBFIL
9848 C cut probability distribution
9849 INTEGER IEETA1,IIMAX,KKMAX
9850 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9851 INTEGER IEEMAX,IMAX,KMAX
9853 DOUBLE PRECISION EPTAB
9854 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9856 C energy-interpolation table
9858 PARAMETER ( IEETA2 = 20 )
9860 DOUBLE PRECISION SIGTAB,SIGECM
9861 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9862 C average number of cut soft and hard ladders (obsolete)
9863 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9864 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9866 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9867 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9868 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9869 C integration precision for hard cross sections (obsolete)
9870 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9871 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9872 C model switches and parameters
9874 INTEGER ISWMDL,IPAMDL
9875 DOUBLE PRECISION PARMDL
9876 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9877 C unitarized amplitudes for different diffraction channels
9878 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9879 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9880 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9882 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9883 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9884 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9885 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9886 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9887 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9891 DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9892 PARAMETER (ICHMAX=40)
9893 DIMENSION CHIFAC(4,4),AMPCOF(4)
9894 DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9895 DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9897 C combinatorical factors
9898 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9899 & 1.D0,-1.D0, 1.D0,-1.D0,
9900 & 1.D0,-1.D0,-1.D0, 1.D0,
9901 & 1.D0, 1.D0, 1.D0, 1.D0 /
9903 DATA FACLOG / .000000000000000D+00,
9904 & .000000000000000D+00, .693147180559945D+00,
9905 & .109861228866811D+01, .138629436111989D+01,
9906 & .160943791243410D+01, .179175946922805D+01,
9907 & .194591014905531D+01, .207944154167984D+01,
9908 & .219722457733622D+01, .230258509299405D+01,
9909 & .239789527279837D+01, .248490664978800D+01,
9910 & .256494935746154D+01, .263905732961526D+01,
9911 & .270805020110221D+01, .277258872223978D+01,
9912 & .283321334405622D+01, .289037175789616D+01,
9913 & .294443897916644D+01, .299573227355399D+01,
9914 & .304452243772342D+01, .309104245335832D+01,
9915 & .313549421592915D+01, .317805383034795D+01,
9916 & .321887582486820D+01, .325809653802148D+01,
9917 & .329583686600433D+01, .333220451017520D+01,
9918 & .336729582998647D+01, .340119738166216D+01 /
9923 C test for redundant calculation: skip cs calculation
9924 IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9927 CALL PHO_XSECT(IP,0,ELAST)
9930 SIGTAB(IP,1,IE) = SIGTOT
9931 SIGTAB(IP,2,IE) = SIGELA
9936 SIGTAB(IP,J,IE) = SIGVM(I,K)
9939 SIGTAB(IP,28,IE) = SIGINE
9940 SIGTAB(IP,29,IE) = SIGDIR
9941 SIGTAB(IP,30,IE) = SIGLSD(1)
9942 SIGTAB(IP,31,IE) = SIGLSD(2)
9943 SIGTAB(IP,32,IE) = SIGHSD(1)
9944 SIGTAB(IP,33,IE) = SIGHSD(2)
9945 SIGTAB(IP,34,IE) = SIGLDD
9946 SIGTAB(IP,35,IE) = SIGHDD
9947 SIGTAB(IP,36,IE) = SIGCDF(0)
9948 SIGTAB(IP,37,IE) = SIG1SO
9949 SIGTAB(IP,38,IE) = SIG1HA
9950 SIGTAB(IP,39,IE) = SLOEL
9955 SIGTAB(IP,J,IE) = SLOVM(I,K)
9958 SIGTAB(IP,56,IE) = SIGPOM
9959 SIGTAB(IP,57,IE) = SIGREG
9960 SIGTAB(IP,58,IE) = SIGHAR
9961 SIGTAB(IP,59,IE) = SIGDIR
9962 SIGTAB(IP,60,IE) = SIGTR1(1)
9963 SIGTAB(IP,61,IE) = SIGTR1(2)
9964 SIGTAB(IP,62,IE) = SIGTR2(1)
9965 SIGTAB(IP,63,IE) = SIGTR2(2)
9966 SIGTAB(IP,64,IE) = SIGLOO
9967 SIGTAB(IP,65,IE) = SIGDPO(1)
9968 SIGTAB(IP,66,IE) = SIGDPO(2)
9969 SIGTAB(IP,67,IE) = SIGDPO(3)
9970 SIGTAB(IP,68,IE) = SIGDPO(4)
9973 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9974 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9977 IF(SIGNDF.LE.0.D0) THEN
9978 WRITE(LO,'(//1X,A,/)')
9979 & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
9980 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
9981 & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
9982 WRITE(LO,'(4X,A,/1P,8E10.3)')
9983 &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
9984 & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
9989 IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
9990 print LO,'------------------------------------------------'
9991 print LO,'IP,ECM:',IP,ECM
9992 print LO,'SIGTOT:',SIGTOT
9993 print LO,'SIGELA:',SIGELA
9994 print LO,'SIGVM :',SIGVM(0,0)
9995 print LO,'SIGCDF:',SIGCDF(0)
9996 print LO,'SIGDIR:',SIGDIR
9997 print LO,'SIGLSD:',SIGLSD
9998 print LO,'SIGHSD:',SIGHSD
9999 print LO,'SIGLDD:',SIGLDD
10000 print LO,'SIGHDD:',SIGHDD
10001 print LO,'SIGNDF:',SIGNDF
10003 print LO,'SIGPOM:',SIGPOM
10004 print LO,'SIGREG:',SIGREG
10005 print LO,'SIGHAR:',SIGHAR
10006 print LO,'SIGDIR:',SIGDIR
10007 print LO,'SIGTR1:',SIGTR1
10008 print LO,'SIGTR2:',SIGTR2
10009 print LO,'SIGLOO:',SIGLOO
10010 print LO,'SIGDPO:',SIGDPO
10011 print LO,'SIG1SO:',SIG1SO
10012 print LO,'SIG1HA:',SIG1HA
10015 SIGTAB(IP,77,IE) = PTCUT(IP)
10016 SIGTAB(IP,78,IE) = SIGNDF
10018 AUXFAC = PI2/SIGNDF
10019 IF(ISWMDL(1).EQ.3) THEN
10023 AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10025 AMPCOF(I) = AMPCOF(I)*AUXFAC
10029 * BMAX=5.D0*SQRT(DBLE(BPOM))
10032 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10038 PROB(IP,IE,I,K) = 0.D0
10046 C main cross section loop
10047 C**********************************************************
10048 DO 5000 IB=1,NGAUSO
10049 B24=XPNT(IB)**2/4.D0
10050 FAC = XPNT(IB)*WGHT(IB)
10052 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10054 C amplitude construction
10056 AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10057 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
10058 AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10059 AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10060 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10061 & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10062 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10063 & -ZXL(1,I)*EXP(-B24/BXL(1,I))
10064 AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10065 & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10066 & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10067 & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10068 AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10079 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10081 ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10087 CHI2(I) = CHI2(I) + ABSUM2(K,I)
10090 C sums instead of products
10093 DTMP = ABS(ABSUM2(I,KD))
10094 IF(DTMP.LT.1.D-30) THEN
10095 ABSUM2(I,KD) = -50.D0
10097 ABSUM2(I,KD) = LOG(DTMP)
10102 IF(MAX(IMAX,KMAX).GT.30) THEN
10103 WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10104 & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10110 ABSTMP(I) = ABSUM2(I,KD)
10113 CHITMP(1) = -ABSUM2(1,KD)
10115 CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10116 CHITMP(2) = -ABSTMP(2)
10118 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10119 C calculation of elastic part
10120 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10121 IF(DTMP.LT.-30.D0) THEN
10124 DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10126 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10130 PROB(IP,IE,0,0) = 0.D0
10132 C**********************************************************
10134 WRITE(LO,'(1X,A,I3)')
10135 & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10141 IF(IDEB(55).GE.15) THEN
10142 WRITE(LO,'(/,1X,A,I3,E11.4)')
10143 & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10145 DO 905 I=0,MIN(IMAX,5)
10146 DO 915 K=0,MIN(KMAX,5)
10147 IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10148 & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10152 C string probability (uncorrected)
10153 IF(IDEB(55).GE.5) THEN
10157 IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10158 PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10162 WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10163 & 'list of selected probabilities (uncorr,ECM)',ECM
10164 WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
10166 IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10167 & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10168 & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10171 C substract high-mass single and double diffraction
10172 PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10173 & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10174 PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10176 C probability check
10196 TMP = PROB(IP,IE,I,K)
10197 IF(TMP.LT.0.D0) THEN
10198 IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10199 WRITE(LO,'(1X,A,4I4,E14.4)')
10200 & 'PHO_PRBDIS: neg.probability:',
10201 & IP,IE,I,K,PROB(IP,IE,I,K)
10203 PRONEG = PRONEG+TMP
10206 CHKSUM = CHKSUM+TMP
10207 AVERI = AVERI+DBLE(I)*TMP
10208 AVERK = AVERK+DBLE(K)*TMP
10209 SIGMI = SIGMI+DBLE(I**2)*TMP
10210 SIGMK = SIGMK+DBLE(K**2)*TMP
10211 PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10212 PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10213 PROB(IP,IE,I,K) = CHKSUM
10217 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10218 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10219 C cut probabilites output
10220 IF(IDEB(55).GE.5) THEN
10221 WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10223 IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10224 & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10227 C rescaling necessary
10228 IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10230 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10231 & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10234 PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10241 SIGMI = SIGMI*FAC**2
10242 SIGMK = SIGMK*FAC**2
10243 SIGML = SIGML*FAC**2
10244 SIGMM = SIGMM*FAC**2
10247 C probability to find Reggeon/Pomeron
10248 PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10249 AVERJ = -PROB(IP,IE,0,0)*AVERI
10250 AVERII = AVERI-AVERJ
10252 SIGTAB(IP,74,IE) = AVERII
10253 SIGTAB(IP,75,IE) = AVERK
10254 SIGTAB(IP,76,IE) = AVERJ
10256 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10257 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10259 IF(IDEB(55).GE.1) THEN
10261 C average interaction probabilities
10262 WRITE(LO,'(/1X,A,/1X,A)')
10263 & 'PHO_PRBDIS: expected interaction statistics',
10264 & '-------------------------------------------'
10265 WRITE(LO,'(1X,A,E12.4,2I3)')
10266 & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10267 WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10269 WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10270 & 'averaged number of cuts per event (eff. cs):',SIGNDF,
10271 & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10272 & AVERII,AVERK,AVERJ,AVERL,AVERM,
10273 & AVERI+AVERK+AVERL+AVERM
10274 WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10275 & 'standard deviation ( sqrt(sigma) ):',
10276 & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10277 & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10278 & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10279 WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
10280 DO I=0,MIN(IMAX,KMAX)
10281 WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10282 & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10285 C cross check of probability distribution and inclusive cross section
10291 PSsum_1 = PSsum_1+PSOFT(i)*FAC
10292 PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10295 PHsum_1 = PHsum_1+PHARD(k)
10296 PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10298 WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10299 & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10305 CDECK ID>, PHO_SAMPRO
10306 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10307 C***********************************************************************
10309 C routine to sample kind of process
10311 C input: IP particle combination
10312 C IFP1/2 PDG number of particle 1/2
10313 C ECM c.m. energy (GeV)
10314 C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10315 C SPROB suppression factor for processes 1-7
10316 C due to rapidity gap survival probability
10318 C -2 output of statistics
10319 C -1 initialization
10320 C 0 sampling of process
10322 C output: IPROC kind of interaction process:
10323 C 1 non-diffractive resolved process
10324 C 2 elastic scattering
10325 C 3 quasi-elastic rho/omega/phi production
10326 C 4 central diffraction
10327 C 5 single diffraction according to IDIFF1
10328 C 6 single diffraction according to IDIFF2
10329 C 7 double diffraction
10330 C 8 single-resolved / direct processes
10332 C***********************************************************************
10338 INTEGER IP,IFP1,IFP2,IPROC
10339 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10341 C input/output channels
10343 COMMON /POINOU/ LI,LO
10344 C event debugging information
10346 PARAMETER (NMAXD=100)
10347 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10348 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10349 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10350 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10352 INTEGER IPFIL,IFAFIL,IFBFIL
10353 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10354 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10355 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10356 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10357 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10358 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10359 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10360 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10361 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10362 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10363 & IPFIL,IFAFIL,IFBFIL
10364 C model switches and parameters
10366 INTEGER ISWMDL,IPAMDL
10367 DOUBLE PRECISION PARMDL
10368 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10369 C general process information
10370 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10371 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10372 C event weights and generated cross section
10373 INTEGER IPOWGC,ISWCUT,IVWGHT
10374 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10375 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10376 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10378 DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10379 DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10380 DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10383 DOUBLE PRECISION DT_RNDM
10384 DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10386 IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10387 & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10388 & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10390 IF(IPROC.GE.0) THEN
10392 C interpolate cross sections
10393 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10396 IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10397 WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10398 & 'PHO_SAMPRO: inconsistent gap survival probability',
10399 & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10400 & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10403 C calculate cumulative probabilities
10404 IF(ISWMDL(1).EQ.3) THEN
10405 IF(ISWMDL(2).GE.1) THEN
10406 SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10407 SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10408 SIGDDI = SIGLDD+SIGHDD
10409 SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10410 & - SIGSDI(1)-SIGSDI(2)-SIGDDI
10411 XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10412 XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10413 XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10414 XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10415 XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10416 XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10417 XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10418 XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10421 IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10423 IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10424 XPROB(1) = SIGHR/(SIGHR+SIGHD)
10425 XPROB(2) = XPROB(1)
10426 XPROB(3) = XPROB(1)
10427 XPROB(4) = XPROB(1)
10428 XPROB(5) = XPROB(1)
10429 XPROB(6) = XPROB(1)
10430 XPROB(7) = XPROB(1)
10431 XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10434 IF(IDEB(11).GE.15) THEN
10435 WRITE(LO,'(1X,A,I3)')
10436 & 'PHO_SAMPRO: partial cross sections for IP',IP
10437 WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10439 WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10444 WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10449 IF(XPROB(8).LT.1.D-20) THEN
10451 & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10452 & 'activated processes have vanishing cross section sum',
10453 & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10459 XI = DT_RNDM(XI)*XPROB(8)
10461 IF(XI.LE.XPROB(I)) GOTO 110
10466 CALLS(IP) = CALLS(IP)+1.D0
10467 PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10468 ECMSUM(IP) = ECMSUM(IP)+ECM
10469 IF(ISWMDL(2).GE.1) THEN
10470 SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10472 SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10476 IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10477 & 'PHO_SAMPRO: IP,CALL,PROC-ID',
10478 & IP,INT(CALLS(IP)+0.1D0),IPROC
10480 C statistics initialization
10481 ELSE IF(IPROC.EQ.-1) THEN
10491 C write out statistics
10492 ELSE IF(IPROC.EQ.-2) THEN
10494 IF(ISWMDL(2).EQ.0) KMAX=1
10496 IF(CALLS(K).GT.0.5D0) THEN
10497 SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10498 ECMSUM(K) = ECMSUM(K)/CALLS(K)
10499 IF(IDEB(11).GE.0) THEN
10500 C *** Commented by Chiara
10501 C WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10502 C & 'PHO_SAMPRO: internal process statistics ',
10503 C & '(IP,<Ecm>)',K,ECMSUM(K),
10504 C & '---------------------------------------'
10505 C WRITE(LO,'(8X,A)')
10506 C & ' process sampled cross section'
10507 C IF(ISWMDL(2).GE.1) THEN
10508 C WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10509 C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10510 C & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10511 C & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10512 C & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10513 C & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10514 C & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10515 C & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10516 C & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10517 C & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10519 C WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10520 C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10521 C & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10522 C & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10531 CDECK ID>, PHO_SAMPRB
10532 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10533 C********************************************************************
10535 C routine to sample number of cut graphs of different kind
10537 C input: IP scattering particle combination
10539 C IP -1 initialization
10540 C -2 output of statistics
10541 C others sampling of cuts
10543 C output: ISAM number of soft Pomerons cut
10544 C JSAM number of soft Reggeons cut
10545 C KSAM number of hard Pomerons cut
10547 C PHO_PRBDIS has to be called before
10549 C********************************************************************
10550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10553 C input/output channels
10555 COMMON /POINOU/ LI,LO
10556 C event debugging information
10558 PARAMETER (NMAXD=100)
10559 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10560 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10561 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10562 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10563 C model switches and parameters
10565 INTEGER ISWMDL,IPAMDL
10566 DOUBLE PRECISION PARMDL
10567 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10568 C general process information
10569 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10570 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10571 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
10572 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10573 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10574 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10575 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10576 C obsolete cut-off information
10577 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10578 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10579 C cut probability distribution
10580 INTEGER IEETA1,IIMAX,KKMAX
10581 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10582 INTEGER IEEMAX,IMAX,KMAX
10584 DOUBLE PRECISION EPTAB
10585 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10587 C global event kinematics and particle IDs
10588 INTEGER IFPAP,IFPAB
10589 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10590 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10592 INTEGER IPFIL,IFAFIL,IFBFIL
10593 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10594 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10595 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10596 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10597 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10598 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10599 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10600 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10601 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10602 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10603 & IPFIL,IFAFIL,IFBFIL
10604 C table of particle indices for recursive PHOJET calls
10606 PARAMETER ( MAXIPX = 100 )
10607 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10608 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10609 & IPOIX1,IPOIX2,IPOIX3
10611 DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10613 C sample number of interactions
10619 IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10620 IF(IPAMDL(16).EQ.0) ECMC = SECM
10624 C sample up to kinematic limits only
10625 IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10626 IF(IMAX1.LT.1) THEN
10627 IF(IPAMDL(2).EQ.1) THEN
10632 AVERB(3,IP) = AVERB(3,IP)+1.D0
10634 C only pomeron even at very low energies
10638 AVERB(1,IP) = AVERB(1,IP)+1.D0
10640 AVERB(0,IP) = AVERB(0,IP)+1.D0
10643 C find interpolation factors
10644 IF(ECMX.LE.EPTAB(IP,1)) THEN
10647 ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10649 IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10655 WRITE(LO,'(/1X,A,2E12.3)')
10656 & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10657 CALL PHO_PREVNT(-1)
10663 & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10665 C reggeon probability
10666 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10667 C calculate soft suppression factor
10668 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10669 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10676 PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10677 & +PROB(IP,I2,ISAM,KSAM)*FAC2
10678 IF(PRO.GT.XI) GOTO 100
10681 ISAM = MIN(IMAX,ISAM)
10682 KSAM = MIN(KMAX,KSAM)
10686 IF(ITER.GT.100) THEN
10691 IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10692 & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10696 C reggeon contribution
10698 IF(IPAMDL(2).EQ.1) THEN
10700 IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10704 C statistics of bare cuts
10706 AVERB(0,IP) = AVERB(0,IP)+1.D0
10707 AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10708 AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10709 AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10711 C limitation given by field dimensions
10712 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10716 C reweight according to virtualities and PDF treatment
10717 IF(IPAMDL(115).GE.1) THEN
10719 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10723 C reduce number of cuts according to photon virtualities
10724 IF(IPAMDL(114).GE.1) THEN
10728 IF(DT_RNDM(WGX).GT.WGX) THEN
10729 IF(ISAM+JSAM+KSAM.GT.1) THEN
10733 ELSE IF(ISAM.GT.0) THEN
10743 C phase space limitation
10745 XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10746 & +DBLE(2*KSAM)*PTCUT(IP)
10747 PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10748 IF(DT_RNDM(XM).GT.PACC) THEN
10749 IF(ISAM+JSAM+KSAM.GT.1) THEN
10753 ELSE IF(ISAM.GT.0) THEN
10756 ELSE IF(KSAM.GT.KLIM) THEN
10767 C collect statistics
10769 ECMS1(IP) = ECMS1(IP)+ECMX
10770 ECMS2(IP) = ECMS2(IP)+ECMC
10772 AVERC(0,IP) = AVERC(0,IP)+1.D0
10773 AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10774 AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10775 AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10777 IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10778 & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10780 C initialize statistics
10781 ELSE IF(IP.EQ.-1) THEN
10793 C write out statistics
10794 ELSE IF(IP.EQ.-2) THEN
10795 C *** Commented by Chiara
10796 C WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10797 C & '----------------------------------'
10799 IF(AVERB(0,I).LT.2.D0) GOTO 75
10800 C WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10801 C & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10802 C & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10803 C WRITE(LO,'(5X,A)')
10804 C & 'average number of s-pom,h-pom,reg cuts (bare)'
10805 C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10806 C & (AVERB(K,I)/AVERB(0,I),K=1,3)
10807 C WRITE(LO,'(5X,A)')
10808 C & 'average (with energy/virtuality corrections)'
10809 C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10810 C & (AVERC(K,I)/AVERC(0,I),K=1,3)
10818 CDECK ID>, PHO_TRIREG
10819 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10821 C**********************************************************************
10823 C calculation of triple-Pomeron total cross section
10824 C according to Gribov's Regge theory
10826 C input: S squared cms energy
10827 C GA coupling constant to diffractive line
10828 C AA slope related to GA (GeV**-2)
10829 C GB coupling constant to elastic line
10830 C BB slope related to GB (GeV**-2)
10831 C DELTA effective pomeron delta (intercept-1)
10832 C ALPHAP slope of pomeron trajectory (GeV**-2)
10833 C GPPP triple-Pomeron coupling
10834 C BPPP slope related to B0PPP (GeV**-2)
10835 C VIR2A virtuality of particle a (GeV**2)
10836 C note: units of all coupling constants are mb**1/2
10838 C output: SIGTR total triple-Pomeron cross section
10839 C BTR effective triple-Pomeron slope
10840 C (differs from diffractive slope!)
10842 C uses E_i (Exponential-Integral function)
10844 C**********************************************************************
10845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10848 PARAMETER (EPS =0.0001D0)
10850 C input/output channels
10852 COMMON /POINOU/ LI,LO
10853 C event debugging information
10855 PARAMETER (NMAXD=100)
10856 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10857 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10858 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10859 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10861 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10862 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10863 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10865 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10867 C integration cut-off Sigma_L (min. squared mass of diff. blob)
10870 IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10871 & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10872 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10879 C change units of ALPHAP to mb
10880 ALSCA = ALPHAP*GEV2MB
10883 PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10884 & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10885 PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10886 PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10888 SIGTR=PART1*(PART2-PART3)
10891 PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10892 & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10894 PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10895 BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10898 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10899 IF(BTR.LT.BB) BTR = BB
10901 IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10902 & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10905 CDECK ID>, PHO_LOOREG
10906 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10907 & VIR2A,VIR2B,SIGLO,BLO)
10908 C**********************************************************************
10910 C calculation of loop-Pomeron total cross section
10911 C according to Gribov's Regge theory
10913 C input: S squared cms energy
10914 C GA coupling constant to diffractive line
10915 C AA slope related to GA (GeV**-2)
10916 C GB coupling constant to elastic line
10917 C BB slope related to GB (GeV**-2)
10918 C DELTA effective pomeron delta (intercept-1)
10919 C ALPHAP slope of pomeron trajectory (GeV**-2)
10920 C GPPP triple-Pomeron coupling
10921 C BPPP slope related to B0PPP (GeV**-2)
10922 C VIR2A virtuality of particle a (GeV**2)
10923 C VIR2B virtuality of particle b (GeV**2)
10924 C note: units of all coupling constants are mb**1/2
10926 C output: SIGLO total loop-Pomeron cross section
10927 C BLO effective loop-Pomeron slope
10928 C (differs from double diffractive slope!)
10930 C uses E_i (Exponential-Integral function)
10932 C**********************************************************************
10933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10936 PARAMETER (EPS =0.0001D0)
10938 C input/output channels
10940 COMMON /POINOU/ LI,LO
10941 C event debugging information
10943 PARAMETER (NMAXD=100)
10944 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10945 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10946 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10947 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10949 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10950 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10951 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10953 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10955 C integration cut-off Sigma_L (min. squared mass of diff. blob)
10956 SIGL = 5.+VIR2A+VIR2B
10958 IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10959 & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10960 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10969 C change units of ALPHAP to mb
10970 ALSCA = ALPHAP*GEV2MB
10973 PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
10974 & EXP(-DELTA*BPPP/ALPHAP)
10975 PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
10976 PARTB=BPPP/ALPHAP+LOG(SIGU)
10977 SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
10978 & -PHO_EXPINT(PARTB*DELTA))
10979 & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
10983 PART1 = LOG(ABS(PARTA/PARTB))
10984 & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
10985 PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
10986 BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
10989 IF(SIGLO.LT.EPS) SIGLO = 0.D0
10990 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10992 IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10993 & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
10996 CDECK ID>, PHO_TRXPOM
10997 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10998 & GPPP,BPPP,SIGDP,BDP)
10999 C**********************************************************************
11001 C calculation of total cross section of two tripe-Pomeron
11002 C graphs in X configuration according to Gribov's Reggeon field
11005 C input: S squared cms energy
11006 C GA coupling constant to elastic line 1
11007 C AA slope related to GA (GeV**-2)
11008 C GB coupling constant to elastic line 2
11009 C BB slope related to GB (GeV**-2)
11010 C DELTA effective pomeron delta (intercept-1)
11011 C ALPHAP slope of pomeron trajectory (GeV**-2)
11012 C BPPP triple-Pomeron coupling
11013 C BTR slope related to B0PPP (GeV**-2)
11014 C note: units of all coupling constants are mb**1/2
11016 C output: SIGDP total cross section for double-Pomeron
11018 C BDP effective double-Pomeron slope
11020 C**********************************************************************
11021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11024 PARAMETER (EPS =0.0001D0)
11026 C input/output channels
11028 COMMON /POINOU/ LI,LO
11029 C event debugging information
11031 PARAMETER (NMAXD=100)
11032 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11033 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11034 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11035 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11036 C model switches and parameters
11038 INTEGER ISWMDL,IPAMDL
11039 DOUBLE PRECISION PARMDL
11040 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11042 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11043 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11044 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11046 DIMENSION XWGH1(96),XPOS1(96)
11048 C lower integration cut-off Sigma_L
11049 SIGL = PARMDL(71)**2
11050 C upper integration cut-off Sigma_U
11051 C = 1.D0-1.D0/PARMDL(70)**2
11052 C = MAX(PARMDL(72),C)
11053 SIGU = (1.D0-C)**2*S
11054 C integration precision
11058 IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11059 & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11060 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11062 IF(SIGU.LE.SIGL) THEN
11073 FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11074 ALPHA2 = 2.D0*ALPHAP
11075 ALOC = LOG(1.D0/(1.D0-C))
11076 CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11079 AMXSQ = EXP(XPOS1(I1))
11080 ALOSMX = LOG(S/AMXSQ)
11081 ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11082 W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11084 WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11085 C supercritical part
11086 WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11087 XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11092 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11094 IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11095 & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11098 CDECK ID>, PHO_CHAN2A
11099 SUBROUTINE PHO_CHAN2A(BB)
11100 C***********************************************************************
11102 C simple two channel model to realize low mass diffraction
11103 C (version A, iteration of triple- and loop-Pomeron)
11105 C input: BB impact parameter (mb**1/2)
11108 C AMPEL elastic amplitude
11109 C AMPVM(4,4) q-elastic VM production
11110 C AMLMSD(2) low mass single diffraction amplitude
11111 C AMHMSD(2) high mass single diffraction amplitude
11112 C AMLMDD low mass double diffraction amplitude
11113 C AMHMDD high mass double diffraction amplitude
11114 C AMPDP(4) central diffraction amplitude
11116 C***********************************************************************
11117 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11120 PARAMETER (DEPS = 1.D-5,
11123 C input/output channels
11125 COMMON /POINOU/ LI,LO
11126 C event debugging information
11128 PARAMETER (NMAXD=100)
11129 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11130 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11131 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11132 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11133 C model switches and parameters
11135 INTEGER ISWMDL,IPAMDL
11136 DOUBLE PRECISION PARMDL
11137 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11139 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11140 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11141 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11142 C complex Born graph amplitudes used for unitarization
11143 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11145 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11146 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11147 C unitarized amplitudes for different diffraction channels
11148 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11149 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11150 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11152 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11153 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11154 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11155 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11156 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11157 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11158 & ZXL(4,4),BXL(4,4)
11159 C Reggeon phenomenology parameters
11160 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11161 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11162 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11163 & ALREG,ALREGP,GR(2),B0REG(2),
11164 & GPPP,GPPR,B0PPP,B0PPR,
11165 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11166 C parameters of 2x2 channel model
11167 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11168 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11169 C global event kinematics and particle IDs
11170 INTEGER IFPAP,IFPAB
11171 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11172 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11175 DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11176 & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11177 & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11178 DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11180 C combinatorical factors
11181 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11182 & 1.D0,-1.D0, 1.D0,-1.D0,
11183 & 1.D0,-1.D0,-1.D0, 1.D0,
11184 & 1.D0, 1.D0, 1.D0, 1.D0 /
11185 DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11186 & 1.D0,-1.D0,-1.D0, 1.D0,
11187 & -1.D0, 1.D0,-1.D0, 1.D0,
11188 & -1.D0,-1.D0, 1.D0, 1.D0 /
11189 DATA IELTAB / 1, 2, 3, 4,
11194 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11195 & 'PHO_CHAN2A: impact parameter B',BB
11199 AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11200 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
11201 AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11202 AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11203 AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11204 AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11205 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11206 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11207 AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11208 AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11209 AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11210 AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11216 ABSUM(I) = ABSUM(I) + AB(II,I)
11219 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11220 & 'PHO_CHAN2A: ABSUM',ABSUM
11237 AMPELA(I,K+4) = 0.D0
11239 CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
11240 CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11241 CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11242 CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11243 CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11244 CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11245 CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11246 CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11247 CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11248 CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11250 IF(CHI(I).LT.-DEPS) THEN
11251 IF(IDEB(86).GE.0) THEN
11252 WRITE(LO,'(1X,A,I3,2E12.3)')
11253 & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11254 WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11257 IF(ABS(CHI(I)).GT.200.D0) THEN
11263 EX2CHI(I) = TMP*TMP
11266 IF(IDEB(86).GE.20) THEN
11267 WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11273 CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11274 AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11275 AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11276 AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11277 AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11278 AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11279 AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11280 AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11281 AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11282 AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11283 AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11287 IF(IDEB(86).GE.25) THEN
11289 WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11290 & (AMPELA(K,1),K=1,4)
11294 C VDM factors --> amplitudes
11295 C low mass excitations
11299 AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11302 AMPVME = AMPCHA(1)/EIGHT
11303 AMLMSD(1) = AMPCHA(2)/EIGHT
11304 AMLMSD(2) = AMPCHA(3)/EIGHT
11305 AMLMDD = AMPCHA(4)/EIGHT
11306 C elastic part, high mass diffraction
11307 AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11318 AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
11319 AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
11320 AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
11321 AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11322 AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11323 AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
11324 AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
11325 AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
11326 AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
11327 AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
11329 AMPSOF = AMPSOF/16.D0
11330 AMPHAR = AMPHAR/16.D0
11331 AMHMSD(1) = AMHMSD(1)/16.D0
11332 AMHMSD(2) = AMHMSD(2)/16.D0
11333 AMHMDD = AMHMDD/16.D0
11334 AMPDP(1) = AMPDP(1)/16.D0
11335 AMPDP(2) = AMPDP(2)/16.D0
11336 AMPDP(3) = AMPDP(3)/16.D0
11337 AMPDP(4) = AMPDP(4)/16.D0
11338 IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11339 IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11340 IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
11341 IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11342 IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11343 IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11344 IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11346 C vector-meson production, weight factors
11347 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11348 IF(IFPAP(1).EQ.22) THEN
11349 IF(IFPAP(2).EQ.22) THEN
11352 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11356 AMPVM(1,1) = PARMDL(10)*AMPVME
11357 AMPVM(2,1) = PARMDL(11)*AMPVME
11358 AMPVM(3,1) = PARMDL(12)*AMPVME
11359 AMPVM(4,1) = PARMDL(13)*AMPVME
11361 ELSE IF(IFPAP(2).EQ.22) THEN
11362 AMPVM(1,1) = PARMDL(10)*AMPVME
11363 AMPVM(1,2) = PARMDL(11)*AMPVME
11364 AMPVM(1,3) = PARMDL(12)*AMPVME
11365 AMPVM(1,4) = PARMDL(13)*AMPVME
11369 IF(IDEB(86).GE.5) THEN
11370 WRITE(LO,'(/,1X,A)')
11371 & 'PHO_CHAN2A: impact parameter amplitudes'
11372 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
11373 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11374 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11375 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11376 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11377 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
11378 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
11379 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
11380 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
11381 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
11382 WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
11387 CDECK ID>, PHO_EVENT
11388 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11389 C********************************************************************
11391 C main subroutine to manage simulation processes
11393 C input: NEV -1 initialization
11394 C 1 generation of events
11395 C 2 generation of events without rejection
11396 C due to energy dependent cross section
11397 C 3 generation of events without rejection
11398 C using initialization energy
11399 C -2 output of event generation statistics
11400 C P1(4) momentum of particle 1 (internal TARGET)
11401 C P2(4) momentum of particle 2 (internal PROJECTILE)
11402 C FAC used for initialization:
11403 C contains cross section the events corresponds to
11404 C during generation: current cross section
11406 C output: IREJ 0: event accepted
11407 C 1: event rejected
11409 C********************************************************************
11410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11413 PARAMETER ( TINY = 1.D-10 )
11415 DIMENSION P1(4),P2(4)
11417 C input/output channels
11419 COMMON /POINOU/ LI,LO
11420 C event debugging information
11422 PARAMETER (NMAXD=100)
11423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11427 C model switches and parameters
11429 INTEGER ISWMDL,IPAMDL
11430 DOUBLE PRECISION PARMDL
11431 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11432 C general process information
11433 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11434 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11435 C internal rejection counters
11437 PARAMETER (NMXJ=60)
11438 CHARACTER*10 REJTIT
11440 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11441 C gamma-lepton or gamma-hadron vertex information
11442 INTEGER IGHEL,IDPSRC,IDBSRC
11443 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11444 & RADSRC,AMSRC,GAMSRC
11445 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11446 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11447 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11448 C global event kinematics and particle IDs
11449 INTEGER IFPAP,IFPAB
11450 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11451 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11453 INTEGER IPFIL,IFAFIL,IFBFIL
11454 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11455 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11456 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11457 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11458 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11459 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11460 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11461 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11462 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11463 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11464 & IPFIL,IFAFIL,IFBFIL
11465 C event weights and generated cross section
11466 INTEGER IPOWGC,ISWCUT,IVWGHT
11467 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11468 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11469 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11470 C names of hard scattering processes
11472 PARAMETER ( Max_pro_1 = 16 )
11474 COMMON /POHPRO/ PROC(0:Max_pro_1)
11475 C hard cross sections and MC selection weights
11477 PARAMETER ( Max_pro_2 = 16 )
11478 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11479 & MH_acc_1,MH_acc_2
11480 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11481 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11482 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11483 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11484 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11485 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11486 C table of particle indices for recursive PHOJET calls
11488 PARAMETER ( MAXIPX = 100 )
11489 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11490 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11491 & IPOIX1,IPOIX2,IPOIX3
11493 DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11499 WRITE(LO,'(/3(/1X,A))')
11500 & '=======================================================',
11501 & ' ------- initialization of event generation --------',
11502 & '======================================================='
11503 CALL PHO_SETMDL(0,0,-2)
11504 C amplitude parameters
11507 CALL PHO_REJSTA(-1)
11508 C initialize MC package
11509 CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11511 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11513 CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11548 ELSE IF(NEV.GT.0) THEN
11550 C -------------- begin event generation ---------------
11553 IF(NEV.EQ.3) IPAMDL(13) = 1
11556 CALL PHO_TRACE(0,0,0)
11557 IF(IDEB(68).GE.2) THEN
11558 IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11559 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11561 CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11562 C cross section calculation
11565 IF(IVWGHT(1).EQ.1) THEN
11566 WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11568 WG = SIGGEN(3)/SIGGEN(4)
11570 IF(DT_RNDM(FAC).GT.WG) THEN
11572 IF(IDEB(68).GE.6) THEN
11573 WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11574 & 'PHO_EVENT: rejection due to cross section',
11575 & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11576 & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11577 CALL PHO_PREVNT(-1)
11583 SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11584 HSWGHT(0) = MAX(1.D0,WG)
11589 IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11593 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11595 IF(IPROCE.EQ.0) THEN
11596 IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11597 & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11601 C sampling statistics
11602 IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11607 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11608 C sample number of cut graphs according to IPROCE and
11609 C generate parton configurations+strings
11610 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11611 C collect statistics
11615 ISTS = ISTS+KSTRG+KHTRG
11616 ISLS = ISLS+KSLOO+KHLOO
11617 IDIS = IDIS+MIN(KHDIR,1)
11618 IDPS = IDPS+KHDPO+KSDPO
11619 IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11620 & IDNS(KHDIR) = IDNS(KHDIR)+1
11623 IF(IDEB(68).GE.4) THEN
11624 WRITE(LO,'(/1X,A,2I5)')
11625 & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11626 CALL PHO_PREVNT(-1)
11628 IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11631 IFAIL(1) = IFAIL(1)+1
11632 IF(ITRY1.GT.5) RETURN
11634 IF(ISWMDL(2).EQ.0) RETURN
11637 IF(ITRY2.LT.5) GOTO 60
11640 C fragmentation of strings
11642 C FSR and string fragmentation is done separately by DPMJET routines
11643 C CALL PHO_STRFRA(IREJ)
11647 IFAIL(23) = IFAIL(23)+1
11648 IF(IDEB(68).GE.4) THEN
11649 WRITE(LO,'(/1X,A,2I5)')
11650 & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11651 CALL PHO_PREVNT(-1)
11655 C check of conservation of quantum numbers
11656 IF(IDEB(68).GE.-5) THEN
11657 CALL PHO_CHECK(-1,IREJ)
11658 IF(IREJ.NE.0) GOTO 50
11660 C event now completely processed and accepted
11661 C acceptance statistics
11662 IPRACC(IPROCE) = IPRACC(IPROCE)+1
11666 ISTA = ISTA+(KSTRG+KHTRG)
11667 ISLA = ISLA+(KSLOO+KHLOO)
11668 IDIA = IDIA+MIN(KHDIR,1)
11669 IDPA = IDPA+KHDPO+KSDPO
11670 IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11671 & IDNA(KHDIR) = IDNA(KHDIR)+1
11673 IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11677 C debug output (partial / full event listing)
11678 if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11679 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11680 IF(IDEB(67).GE.10) THEN
11681 IF(IDEB(67).LE.15) THEN
11682 CALL PHO_PREVNT(-1)
11683 ELSE IF(IDEB(67).LE.20) THEN
11685 ELSE IF(IDEB(67).LE.25) THEN
11694 IF(IPOWGC(I).GT.0) THEN
11695 HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11698 IF(IVWGHT(1).EQ.1) THEN
11700 IF(WG.GT.1.01D0) THEN
11701 IF(EVWGHT(1).LT.1.01D0) THEN
11702 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11703 & 'PHO_EVENT: cross section weight > 1',
11705 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11706 & SIGGEN(3),SIGGEN(4),EVWGHT(1)
11708 EVWGHT(1) = HSWGHT(0)
11715 C effective cross section
11716 SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11717 ECMSUM = ECMSUM+ECM
11718 SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11719 ELSE IF(NEV.EQ.-2) THEN
11721 C ---------------- end of event generation ----------------------
11723 * --- Commented by Chiara
11724 * WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11725 * & '====================================================',
11726 * & ' --------- summary of event generation ----------',
11727 * & '====================================================',
11728 * & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11729 * & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11731 C write out statistics
11732 IF(KACCEP.GT.0) THEN
11734 FAC1 = SIGGEN(4)/DBLE(KEVENT)
11735 FAC2 = FAC/DBLE(KACCEP)
11736 * WRITE(LO,'(/1X,A,/1X,A)')
11737 * & 'PHO_EVENT: generated and accepted events',
11738 * & '----------------------------------------'
11739 * WRITE(LO,'(3X,A)')
11740 * & 'process, sampled, accepted, cross section (internal/external)'
11741 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11742 * & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11743 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11744 * & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11745 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11746 * & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11747 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11748 * & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11749 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11750 * & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11751 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11752 * & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11753 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11754 * & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11755 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
11756 * & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11757 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11758 * & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11759 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11760 * & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11761 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11762 * & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11763 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11764 * & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11765 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11766 * & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11767 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11768 * & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11769 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11770 * & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11771 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11772 * & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11773 * WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11774 * & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11775 C *** commented by Chiara
11776 C IF(ISWMDL(14).GT.0) THEN
11777 C WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11779 C WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11780 C WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11781 C WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11782 C WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11783 C WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11785 * WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11786 * & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11788 CALL PHO_REJSTA(-2)
11789 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11791 CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11792 C statistics of hard scattering processes
11793 * WRITE(LO,'(2(/1X,A))')
11794 * & 'PHO_EVENT: statistics of hard scattering processes',
11795 * & '--------------------------------------------------'
11797 * IF(MH_tried(0,K).GT.0) THEN
11798 * WRITE(LO,'(/5X,A,I3)')
11799 * & 'process (accepted,x-section internal/external) for IP:',K
11800 * DO 47 M=0,Max_pro_2
11801 * WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11802 * & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11803 * & DBLE(MH_acc_2(M,K))*FAC2
11809 WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11811 * WRITE(LO,'(/3(/1X,A)/)')
11812 * & '======================================================',
11813 * & ' ------- end of event generation summary --------',
11814 * & '======================================================'
11816 WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11821 CDECK ID>, PHO_PARTON
11822 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11823 C********************************************************************
11825 C calculation of complete parton configuration
11827 C input: IPROC process ID 1 nondiffractive
11829 C 3 quasi-ela. rho,omega,phi prod.
11833 C 7 double diff diss.
11834 C 8 single-resolved / direct photon
11835 C JM1,2 index of mother particles in /POEVT1/
11838 C output: complete parton configuration in /POEVT1/
11841 C 50 rejection due to user cutoffs
11843 C********************************************************************
11844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11847 DIMENSION P1(4),P2(4)
11849 PARAMETER ( TINY = 1.D-10 )
11851 C input/output channels
11853 COMMON /POINOU/ LI,LO
11854 C event debugging information
11856 PARAMETER (NMAXD=100)
11857 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11858 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11859 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11860 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11861 C model switches and parameters
11863 INTEGER ISWMDL,IPAMDL
11864 DOUBLE PRECISION PARMDL
11865 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11866 C table of particle indices for recursive PHOJET calls
11868 PARAMETER ( MAXIPX = 100 )
11869 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11870 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11871 & IPOIX1,IPOIX2,IPOIX3
11872 C general process information
11873 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11874 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11875 C global event kinematics and particle IDs
11876 INTEGER IFPAP,IFPAB
11877 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11878 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11880 INTEGER IPFIL,IFAFIL,IFBFIL
11881 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11882 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11883 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11884 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11885 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11886 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11887 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11888 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11889 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11890 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11891 & IPFIL,IFAFIL,IFBFIL
11892 C event weights and generated cross section
11893 INTEGER IPOWGC,ISWCUT,IVWGHT
11894 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11895 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11896 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11897 C internal rejection counters
11899 PARAMETER (NMXJ=60)
11900 CHARACTER*10 REJTIT
11902 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11905 C clear event statistics
11919 C-------------------------------------------------------------------
11920 C nondiffractive resolved processes
11922 IF(IPROC.EQ.1) THEN
11923 C sample number of interactions
11927 C generate only hard events
11928 IF(ISWMDL(2).EQ.0) THEN
11935 C minimum bias events
11938 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11939 IPOWGC(1) = IPOWGC(1)+1
11945 C resolved soft processes: pomeron and reggeon
11948 C resolved hard process: hard pomeron
11950 C resolved absorptive corrections
11953 C restrictions given by user
11954 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11955 IF(MSREG.LT.ISWCUT(2)) GOTO 10
11956 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11957 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11958 C ----------------------------
11959 IF(ISWMDL(15).EQ.0) THEN
11961 IF(MSREG.GT.0) THEN
11968 ELSE IF(ISWMDL(15).EQ.1) THEN
11969 IF(MHPOM.GT.0) THEN
11973 ELSE IF(MSPOM.GT.0) THEN
11979 ELSE IF(ISWMDL(15).EQ.2) THEN
11980 MHPOM = MIN(1,MHPOM)
11981 ELSE IF(ISWMDL(15).EQ.3) THEN
11982 MSPOM = MIN(1,MSPOM)
11985 C ----------------------------
11994 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11995 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11996 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
12001 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12009 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12011 IF(IREJ.EQ.50) RETURN
12012 IF(IDEB(3).GE.2) THEN
12013 WRITE(LO,'(/1X,A,I5)')
12014 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
12015 CALL PHO_PREVNT(-1)
12019 IF(MHPOM.GT.0) THEN
12021 ELSE IF(MSPOM.GT.0) THEN
12026 C check of quantum numbers of parton configurations
12027 IF(IDEB(3).GE.0) THEN
12028 CALL PHO_CHECK(1,IREJ)
12029 IF(IREJ.NE.0) GOTO 50
12031 C sample strings to prepare fragmentation
12032 CALL PHO_STRING(1,IREJ)
12034 IF(IREJ.EQ.50) RETURN
12035 IFAIL(30) = IFAIL(30)+1
12036 IF(IDEB(3).GE.2) THEN
12037 WRITE(LO,'(/1X,A,I5)')
12038 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12039 CALL PHO_PREVNT(-1)
12041 IF(ITRY2.LT.20) GOTO 50
12042 IF(IDEB(3).GE.1) THEN
12043 WRITE(LO,'(/1X,A,I5)')
12044 & 'PHO_PARTON: rejection',ITRY2
12045 CALL PHO_PREVNT(-1)
12057 C-------------------------------------------------------------------
12058 C elastic scattering / quasi-elastic rho/omega/phi production
12060 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12061 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12062 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12064 C DPMJET call with special projectile / target: transform into CMS
12065 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12066 & CALL PHO_DFWRAP(1,JM1,JM2)
12068 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12071 C DPMJET call with special projectile / target: clean up
12072 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12073 & CALL PHO_DFWRAP(-2,JM1,JM2)
12074 IF(IDEB(3).GE.2) THEN
12075 WRITE(LO,'(/1X,A,I5)')
12076 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12077 CALL PHO_PREVNT(-1)
12082 C DPMJET call with special projectile / target: transform back
12083 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12084 & CALL PHO_DFWRAP(2,JM1,JM2)
12086 C prepare possible decays
12087 CALL PHO_STRING(1,IREJ)
12089 IF(IREJ.EQ.50) RETURN
12090 IFAIL(30) = IFAIL(30)+1
12094 C---------------------------------------------------------------------
12095 C double Pomeron scattering
12097 ELSE IF(IPROC.EQ.4) THEN
12100 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12101 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12106 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12108 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12110 IF(IDEB(3).GE.2) THEN
12111 WRITE(LO,'(/1X,A,I5)')
12112 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12113 CALL PHO_PREVNT(-1)
12117 C check of quantum numbers of parton configurations
12118 IF(IDEB(3).GE.0) THEN
12119 CALL PHO_CHECK(1,IREJ)
12120 IF(IREJ.NE.0) GOTO 60
12122 C sample strings to prepare fragmentation
12123 CALL PHO_STRING(1,IREJ)
12125 IF(IREJ.EQ.50) RETURN
12126 IFAIL(30) = IFAIL(30)+1
12127 IF(IDEB(3).GE.2) THEN
12128 WRITE(LO,'(/1X,A,I5)')
12129 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12130 CALL PHO_PREVNT(-1)
12132 IF(ITRY2.LT.10) GOTO 60
12133 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12134 CALL PHO_PREVNT(-1)
12139 C-----------------------------------------------------------------------
12140 C single / double diffraction dissociation
12142 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12145 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12146 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12147 IF(IPROC.EQ.5) ID1S = ID1S+1
12148 IF(IPROC.EQ.6) ID2S = ID2S+1
12149 IF(IPROC.EQ.7) ID3S = ID3S+1
12153 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12156 IF(IPROC.EQ.5) IPAR2 = 0
12157 IF(IPROC.EQ.6) IPAR1 = 0
12158 C calculate rapidity gap survival probability
12160 IF(ECM.GT.10.D0) THEN
12161 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12162 IF(SIGTR1(1).LT.1.D-10) THEN
12165 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12167 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12168 IF(SIGTR2(1).LT.1.D-10) THEN
12171 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12173 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12174 IF(SIGLOO.LT.1.D-10) THEN
12177 SPROB = SIGHDD/SIGLOO
12183 * temporary patch, r.e. 8.6.99
12187 C DPMJET call with special projectile / target: transform into CMS
12188 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12189 & CALL PHO_DFWRAP(1,JM1,JM2)
12191 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12194 C DPMJET call with special projectile / target: clean up
12195 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12196 & CALL PHO_DFWRAP(-2,JM1,JM2)
12197 IF(IDEB(3).GE.2) THEN
12198 WRITE(LO,'(/1X,A,I5)')
12199 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12200 CALL PHO_PREVNT(-1)
12205 C DPMJET call with special projectile / target: transform back
12206 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12207 & CALL PHO_DFWRAP(2,JM1,JM2)
12209 C check of quantum numbers of parton configurations
12210 IF(IDEB(3).GE.0) THEN
12211 CALL PHO_CHECK(1,IREJ)
12212 IF(IREJ.NE.0) GOTO 70
12214 C sample strings to prepare fragmentation
12215 CALL PHO_STRING(1,IREJ)
12217 IF(IREJ.EQ.50) RETURN
12218 IFAIL(30) = IFAIL(30)+1
12219 IF(IDEB(3).GE.2) THEN
12220 WRITE(LO,'(/1X,A,I5)')
12221 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12222 CALL PHO_PREVNT(-1)
12224 IF(ITRY2.LT.10) GOTO 70
12225 WRITE(LO,'(/1X,A,I5)')
12226 & 'PHO_PARTON: rejection',ITRY2
12227 CALL PHO_PREVNT(-1)
12230 IF(IPROC.EQ.5) ID1A = ID1A+1
12231 IF(IPROC.EQ.6) ID2A = ID2A+1
12232 IF(IPROC.EQ.7) ID3A = ID3A+1
12234 C-----------------------------------------------------------------------
12235 C single / double direct processes
12237 ELSE IF(IPROC.EQ.8) THEN
12242 IF(IDEB(3).GE.5) THEN
12243 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12249 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12255 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12257 IF(IREJ.EQ.50) RETURN
12258 IF(IDEB(3).GE.2) THEN
12259 WRITE(LO,'(/1X,A,I5)')
12260 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12261 CALL PHO_PREVNT(-1)
12266 C check of quantum numbers of parton configurations
12267 IF(IDEB(3).GE.0) THEN
12268 CALL PHO_CHECK(1,IREJ)
12269 IF(IREJ.NE.0) GOTO 80
12271 C sample strings to prepare fragmentation
12272 CALL PHO_STRING(1,IREJ)
12274 IF(IREJ.EQ.50) RETURN
12275 IFAIL(30) = IFAIL(30)+1
12276 IF(IDEB(3).GE.2) THEN
12277 WRITE(LO,'(/1X,A,I5)')
12278 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12279 CALL PHO_PREVNT(-1)
12281 IF(ITRY2.LT.10) GOTO 80
12282 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12283 CALL PHO_PREVNT(-1)
12286 IF(IPROC.EQ.5) ID1A = ID1A+1
12287 IF(IPROC.EQ.6) ID2A = ID2A+1
12288 IF(IPROC.EQ.7) ID3A = ID3A+1
12291 C-----------------------------------------------------------------------
12292 C initialize control statistics
12294 ELSE IF(IPROC.EQ.-1) THEN
12295 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12296 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12297 CALL PHO_SEAFLA(-1,0,0,DUM)
12298 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12299 & CALL PHO_QELAST(-1,1,2,0)
12320 CALL PHO_STRING(-1,IREJ)
12321 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12324 C-----------------------------------------------------------------------
12325 C produce statistics summary
12327 ELSE IF(IPROC.EQ.-2) THEN
12328 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12329 C IF(IDEB(3).GE.0) THEN
12330 C *** Commented by Chiara
12331 C WRITE(LO,'(/1X,A,/1X,A)')
12332 C & 'PHO_PARTON: internal statistics on parton configurations',
12333 C & '--------------------------------------------------------'
12334 C WRITE(LO,'(5X,A)') 'process sampled accepted'
12335 C WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12336 C WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12337 C WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12338 C WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12339 C WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12340 C WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12341 C WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12342 C WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12343 C WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12344 C WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12346 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12347 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12348 & CALL PHO_QELAST(-2,1,2,0)
12349 CALL PHO_STRING(-2,IREJ)
12350 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12351 CALL PHO_SEAFLA(-2,0,0,DUM)
12354 WRITE(LO,'(1X,A,I2)')
12355 & 'PARTON:ERROR: unknown process ID ',IPROC
12361 CDECK ID>, PHO_MCINI
12362 SUBROUTINE PHO_MCINI
12363 C********************************************************************
12365 C initialization of MC event generation
12367 C********************************************************************
12368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12371 PARAMETER ( PIMASS = 0.13D0,
12374 C input/output channels
12376 COMMON /POINOU/ LI,LO
12377 C event debugging information
12379 PARAMETER (NMAXD=100)
12380 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12381 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12382 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12383 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12384 C model switches and parameters
12386 INTEGER ISWMDL,IPAMDL
12387 DOUBLE PRECISION PARMDL
12388 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12389 C general process information
12390 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12393 INTEGER IPFIL,IFAFIL,IFBFIL
12394 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12395 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12396 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12397 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12398 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12399 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12400 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12401 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12402 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12403 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12404 & IPFIL,IFAFIL,IFBFIL
12405 C hard cross sections and MC selection weights
12407 PARAMETER ( Max_pro_2 = 16 )
12408 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12409 & MH_acc_1,MH_acc_2
12410 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12411 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12412 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12413 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12414 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12415 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12416 C interpolation tables for hard cross section and MC selection weights
12417 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12418 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12419 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12420 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12421 & HQ2a_tab,HQ2b_tab,HEcm_tab
12423 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12424 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12425 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12426 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12427 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12428 & HEcm_tab(1:Max_tab_E,0:4),
12429 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12430 C global event kinematics and particle IDs
12431 INTEGER IFPAP,IFPAB
12432 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12433 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12434 C obsolete cut-off information
12435 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12436 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12437 C event weights and generated cross section
12438 INTEGER IPOWGC,ISWCUT,IVWGHT
12439 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12440 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12441 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12442 C cut probability distribution
12443 INTEGER IEETA1,IIMAX,KKMAX
12444 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12445 INTEGER IEEMAX,IMAX,KMAX
12447 DOUBLE PRECISION EPTAB
12448 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12450 C energy-interpolation table
12452 PARAMETER ( IEETA2 = 20 )
12454 DOUBLE PRECISION SIGTAB,SIGECM
12455 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12457 CHARACTER*15 PHO_PNAME
12460 DATA XMPOM / 0.766D0 /
12462 C initialize fragmentation
12463 CALL PHO_FRAINI(ISWMDL(6))
12465 C reset interpolation tables
12469 SIGTAB(I,K,J) = 0.D0
12475 C max. number of allowed colors (large N expansion)
12478 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12480 C lower energy limit of initialization
12481 ETABLO = PARMDL(19)
12482 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12484 C *** Commented by Chiara
12485 C WRITE(LO,'(/,1X,A,2F12.1)')
12486 C & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12487 C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12488 C & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12489 C & PMASS(1),PVIRT(1)
12490 C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12491 C & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12492 C & PMASS(2),PVIRT(2)
12494 C cuts on probabilities of multiple interactions
12495 IMAX = MIN(IPAMDL(32),IIMAX)
12496 KMAX = MIN(IPAMDL(33),KKMAX)
12497 AH = 2.D0*PTCUT(1)/ECM
12498 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12499 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12501 C hard interpolation table
12503 ECMF(2) = 0.9D0*ECMF(1)
12507 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12508 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12509 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12510 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12513 C initialization of hard scattering for all channels and cutoffs
12514 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12516 IF(ISWMDL(2).EQ.0) I0 = 1
12518 CALL PHO_HARMCI(I,ECMF(I))
12521 C dimension of interpolation table of cut probabilities
12522 IEEMAX = MIN(IPAMDL(31),IEETA1)
12523 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12524 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12525 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12528 C calculate probability distribution
12536 IF(ISWMDL(2).EQ.0) I0 = 1
12538 ECMPRO = ECMF(IP)*1.001D0
12546 ELSE IF(IP.EQ.3) THEN
12553 ELSE IF(IP.EQ.2) THEN
12568 IF(IEEMAX.GT.1) THEN
12570 ELMIN = LOG(ETABLO)
12574 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12576 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12577 CALL PHO_PRBDIS(IP,ECMPRO,I)
12580 CALL PHO_PRBDIS(IP,ECMPRO,1)
12583 C debug output of cross section tables
12584 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12585 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12586 * --- Commented by Chiara
12587 * WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12588 * &'Table of total cross sections (mb) for particle combination',IP,
12589 * &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12590 * &'-------------------------------------------------------------'
12591 * DO 200 I=1,IEEMAX
12592 * WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12593 * & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12594 * & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12595 * & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12596 * & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12599 IF(IDEB(62).GE.2) THEN
12600 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12601 &'Table of partial x-sections (mb) for particle combination',IP,
12602 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12603 &'--------------------------------------------------------------'
12605 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12606 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12607 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12610 IF(IDEB(62).GE.2) THEN
12611 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12612 &'Table of born graph x-sections (mb) for particle combination',IP,
12613 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12614 &'-------------------------------------------------------------'
12616 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12617 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12618 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12619 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12620 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12623 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12624 &'Table of unitarized x-sections (mb) for particle combination',IP,
12625 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12626 &'-------------------------------------------------------------'
12628 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12629 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12630 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12633 IF(IDEB(62).GE.1) THEN
12634 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12635 &'Table of expected average number of cuts in non-diff events:',
12636 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12637 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12638 &'---------------------------------------------'
12640 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12641 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12645 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12646 & 'Table of rapidity gap survival probability (high-mass diff.):',
12647 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12648 & '---------------------------------------------------'
12650 IF(SIGECM(IP,I).GT.10.D0) THEN
12651 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12652 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12653 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12654 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12655 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12656 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12657 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12658 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12659 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12660 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12661 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12669 C simulate only hard scatterings
12670 IF(ISWMDL(2).EQ.0) THEN
12671 WRITE(LO,'(2(/1X,A))')
12672 & 'WARNING: generation of hard scatterings only!',
12673 & '============================================='
12685 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12686 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12687 IF(SIGMAX.GT.SIGGEN(4)) THEN
12693 * --- Commented by Chiara
12694 * WRITE(LO,'(2(/1X,A))')
12695 * & 'activated processes, cross section',
12696 * & '----------------------------------'
12697 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12698 * & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12699 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12700 * & ' elastic scattering',(IPRON(2,K),K=1,4)
12701 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12702 * & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12703 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12704 * & ' double pomeron processes',(IPRON(4,K),K=1,4)
12705 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12706 * & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12707 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12708 * & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12709 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12710 * & ' double diffract. processes',(IPRON(7,K),K=1,4)
12711 * WRITE(LO,'(5X,A,I3,2X,3I3)')
12712 * & ' direct photon processes',(IPRON(8,K),K=1,4)
12714 C calculate effective cross section
12717 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12718 & PVIRT(1),PVIRT(2))
12720 if(iswmdl(2).ge.1) then
12721 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12722 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12723 & -SIGLDD-SIGHDD-SIGDIR
12724 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12725 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12726 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12727 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12728 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12729 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12730 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12732 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12733 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12735 IF(SIGMAX.GT.SIGGEN(4)) THEN
12743 IF(SIGGEN(4).LT.1.D-20) THEN
12744 WRITE(LO,'(//1X,A)')
12745 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12748 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12749 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12750 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12754 CDECK ID>, PHO_REJSTA
12755 SUBROUTINE PHO_REJSTA(IMODE)
12756 C********************************************************************
12758 C MC rejection counting
12760 C input IMODE -1 initialization
12761 C -2 output of statistics
12763 C********************************************************************
12769 C input/output channels
12771 COMMON /POINOU/ LI,LO
12772 C event debugging information
12774 PARAMETER (NMAXD=100)
12775 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12776 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12777 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12778 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12779 C internal rejection counters
12781 PARAMETER (NMXJ=60)
12782 CHARACTER*10 REJTIT
12784 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12791 IF(IMODE.EQ.-1) THEN
12796 REJTIT(1) = 'PARTON ALL'
12797 REJTIT(2) = 'STDPAR ALL'
12798 REJTIT(3) = 'STDPAR DPO'
12799 REJTIT(4) = 'POMSCA ALL'
12800 REJTIT(5) = 'POMSCA INT'
12801 REJTIT(6) = 'POMSCA KIN'
12802 REJTIT(7) = 'DIFDIS ALL'
12803 REJTIT(8) = 'POSPOM ALL'
12804 REJTIT(9) = 'HRES.DIF.1'
12805 REJTIT(10) = 'HDIR.DIF.1'
12806 REJTIT(11) = 'HRES.DIF.2'
12807 REJTIT(12) = 'HDIR.DIF.2'
12808 REJTIT(13) = 'DIFDIS INT'
12809 REJTIT(14) = 'HADRON SP2'
12810 REJTIT(15) = 'HADRON SP3'
12811 REJTIT(16) = 'HARDIR ALL'
12812 REJTIT(17) = 'HARDIR INT'
12813 REJTIT(18) = 'HARDIR KIN'
12814 REJTIT(19) = 'MCHECK BAR'
12815 REJTIT(20) = 'MCHECK MES'
12816 REJTIT(21) = 'DIF.DISS.1'
12817 REJTIT(22) = 'DIF.DISS.2'
12818 REJTIT(23) = 'STRFRA ALL'
12819 REJTIT(24) = 'MSHELL CHA'
12820 REJTIT(25) = 'PARTPT SOF'
12821 REJTIT(26) = 'PARTPT HAR'
12822 REJTIT(27) = 'INTRINS KT'
12823 REJTIT(28) = 'HACHEK DIR'
12824 REJTIT(29) = 'HACHEK RES'
12825 REJTIT(30) = 'STRING ALL'
12826 REJTIT(31) = 'POMSCA INT'
12827 REJTIT(32) = 'DIFF SLOPE'
12828 REJTIT(33) = 'GLU2QU ALL'
12829 REJTIT(34) = 'MASCOR ALL'
12830 REJTIT(35) = 'PARCOR ALL'
12831 REJTIT(36) = 'MSHELL PAR'
12832 REJTIT(37) = 'MSHELL ALL'
12833 REJTIT(38) = 'POMCOR ALL'
12834 REJTIT(39) = 'DB-POM KIN'
12835 REJTIT(40) = 'DB-POM ALL'
12836 REJTIT(41) = 'SOFTXX ALL'
12837 REJTIT(42) = 'SOFTXX PSP'
12840 * --- Commented by Chiara
12841 * ELSE IF(IMODE.EQ.-2) THEN
12842 * WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12843 * & '--------------------------------'
12845 * IF(IFAIL(I).GT.0)
12846 * & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12849 * WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12854 CDECK ID>, PHO_POSPOM
12855 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12856 C***********************************************************************
12858 C registration of one cut pomeron (soft/semihard)
12860 C input: IP particle combination the pomeron belongs to
12861 C IND1,2 position of X values in /POSOFT/
12862 C 1 corresponds to a valence-pomeron
12863 C IGEN production process of mother particles
12864 C IPOM pomeron number
12865 C KCUT total number of cut pomerons and reggeons
12867 C output: ISWAP exchange of x values
12868 C IND1,2 increased by the number of partons belonging
12869 C to the generated pomeron cut
12870 C IREJ success/failure
12872 C**********************************************************************
12873 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12876 PARAMETER ( DEPS = 1.D-8 )
12878 C input/output channels
12880 COMMON /POINOU/ LI,LO
12881 C event debugging information
12883 PARAMETER (NMAXD=100)
12884 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12885 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12886 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12887 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12888 C internal rejection counters
12890 PARAMETER (NMXJ=60)
12891 CHARACTER*10 REJTIT
12893 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12894 C model switches and parameters
12896 INTEGER ISWMDL,IPAMDL
12897 DOUBLE PRECISION PARMDL
12898 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12899 C general process information
12900 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12901 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12902 C global event kinematics and particle IDs
12903 INTEGER IFPAP,IFPAB
12904 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12905 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12906 C data of c.m. system of Pomeron / Reggeon exchange
12907 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12908 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12909 & SIDP,CODP,SIFP,COFP
12910 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12911 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12912 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12913 C obsolete cut-off information
12914 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12915 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12916 C energy-interpolation table
12918 PARAMETER ( IEETA2 = 20 )
12920 DOUBLE PRECISION SIGTAB,SIGECM
12921 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12922 C light-cone x fractions and c.m. momenta of soft cut string ends
12924 PARAMETER ( MAXSOF = 50 )
12925 INTEGER IJSI2,IJSI1
12926 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12927 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12928 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12929 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12931 C standard particle data interface
12934 PARAMETER (NMXHEP=4000)
12936 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12937 DOUBLE PRECISION PHEP,VHEP
12938 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12939 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12941 C extension to standard particle data interface (PHOJET specific)
12942 INTEGER IMPART,IPHIST,ICOLOR
12943 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12945 C table of particle indices for recursive PHOJET calls
12947 PARAMETER ( MAXIPX = 100 )
12948 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12949 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12950 & IPOIX1,IPOIX2,IPOIX3
12952 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12960 EA1 = XS1(IND1)*ECMP/2.D0
12961 EA2 = XS1(IND1+1)*ECMP/2.D0
12962 EB1 = XS2(IND2)*ECMP/2.D0
12963 EB2 = XS2(IND2+1)*ECMP/2.D0
12964 CMASS1 = MIN(EA1,EA2)
12965 CMASS2 = MIN(EB1,EB2)
12968 IF(IDEB(9).GE.20) THEN
12969 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12970 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12971 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12977 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12979 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12982 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12984 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12987 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12988 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12991 C pomeron resolved?
12992 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12993 C find energy for cross section calculation
12994 IF(IPAMDL(16).EQ.2) THEN
12996 ELSE IF(IPAMDL(16).EQ.3) THEN
12997 IF(IPROCE.EQ.1) THEN
13003 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
13004 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13006 C load cross sections from interpolation table
13007 IF(ESUB.LE.SIGECM(IP,1)) THEN
13010 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13012 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13018 WRITE(LO,'(/1X,A,2E12.3)')
13019 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13020 CALL PHO_PREVNT(-1)
13025 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13026 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13028 C calculate weights
13029 * WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13030 * WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13031 * WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13032 * WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13033 * WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13034 * WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13036 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13037 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13038 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13039 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13040 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13041 & +SIGTAB(IP,64,I2))
13042 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13043 & +SIGTAB(IP,64,I1))
13044 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13045 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13046 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13047 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13050 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13051 C central diff. cut
13053 C diff. diss. of particle 1
13055 C diff. diss. of particle 2
13057 C double diff. dissociation
13060 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13062 * IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13063 * WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13064 * & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13065 * WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13066 * WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13067 * WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13070 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13074 XI = DT_RNDM(SUM)*SUM
13080 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13081 C phase space correction
13084 IF(I.EQ.6) ISAM = 8
13085 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13086 * IF(DT_RNDM(SUM).GT.PACC) I=1
13087 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13090 C do not generate diffraction for events with only one cut pomeron
13091 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13093 C do not generate recursive calls for remants with
13094 C diquark-anti-diquark flavour contents
13095 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13096 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13099 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13100 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13103 C second scattering needed
13104 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13105 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13106 IDPD1 = IPHO_ID2PDG(IDHA1)
13107 IDPD2 = IPHO_ID2PDG(IDHA2)
13109 if(INDX1.eq.1) then
13110 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13115 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13116 & IPOM,IGEN_had,0,0,IPOS1,1)
13118 if(INDX2.eq.1) then
13119 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13124 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13125 & IPOM,IGEN_had,0,0,IPOS1,1)
13132 IF(IPOIX2.GT.MAXIPX) THEN
13133 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13134 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13139 IPORES(IPOIX2) = I+2
13140 IPOPOS(1,IPOIX2) = IPOS1-1
13141 IPOPOS(2,IPOIX2) = IPOS1
13147 IF(ISWMDL(12).EQ.0) THEN
13149 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13150 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13152 C purely gluonic pomeron or sea strings formed by gluons
13154 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13155 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13159 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13160 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13166 IF(IFLA1.NE.21) THEN
13167 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13168 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13169 & CALL PHO_SWAPI(ICA1,ICD1)
13171 IF(IFLB1.NE.21) THEN
13172 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13173 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13174 & CALL PHO_SWAPI(ICB1,ICC1)
13177 IF(ICA1*ICB1.GT.0) THEN
13178 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13179 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13180 CALL PHO_SWAPI(IFLA1,IFLA2)
13181 CALL PHO_SWAPI(ICA1,ICD1)
13183 CALL PHO_SWAPI(IFLB1,IFLB2)
13184 CALL PHO_SWAPI(ICB1,ICC1)
13186 ELSE IF(IND1.NE.1) THEN
13187 CALL PHO_SWAPI(IFLA1,IFLA2)
13188 CALL PHO_SWAPI(ICA1,ICD1)
13189 ELSE IF(IND2.NE.1) THEN
13190 CALL PHO_SWAPI(IFLB1,IFLB2)
13191 CALL PHO_SWAPI(ICB1,ICC1)
13192 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13193 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13194 CALL PHO_SWAPI(IFLA1,IFLA2)
13195 CALL PHO_SWAPI(ICA1,ICD1)
13197 CALL PHO_SWAPI(IFLB1,IFLB2)
13198 CALL PHO_SWAPI(ICB1,ICC1)
13200 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13201 CALL PHO_SWAPI(IFLA1,IFLA2)
13202 CALL PHO_SWAPI(ICA1,ICD1)
13203 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13204 CALL PHO_SWAPI(IFLB1,IFLB2)
13205 CALL PHO_SWAPI(ICB1,ICC1)
13208 IF(IDEB(9).GE.5) THEN
13209 WRITE(LO,'(1X,A,I12)')
13210 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13211 WRITE(LO,'(5X,A,4I7)')
13212 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13213 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13220 C purely gluonic pomeron or sea strings formed by gluons
13221 IF(IFLA1.EQ.21) THEN
13222 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13223 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13226 C strings formed by quarks
13228 C valence quark labels
13229 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13230 & .and.(IDHEP(JM1).NE.990)) THEN
13235 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13236 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13239 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13240 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13246 C purely gluonic pomeron or sea strings formed by gluons
13247 IF(IFLB1.EQ.21) THEN
13248 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13249 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13252 C strings formed by quarks
13254 C valence quark labels
13255 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13256 & .and.(IDHEP(JM2).NE.990)) THEN
13261 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13262 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13265 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13266 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13272 C soft pt assignment
13273 IF(ISWMDL(18).EQ.0) THEN
13274 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13276 IFAIL(25) = IFAIL(25)+1
13281 * CALL PHO_BFKL(P1,P2,IPART,IREJ)
13282 * IF(IREJ.NE.0) RETURN
13287 CDECK ID>, PHO_HADSP2
13288 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13289 C***********************************************************************
13291 C split hadron momentum XMAX into two partons using
13292 C lower cut-off: AS
13294 C input: IFLB compressed particle code of particle to split
13295 C XS1 sum of x values already selected
13296 C XMAX maximal x possible
13298 C output: XS1 new sum of x values (without first one)
13299 C XSOFT1 field of selected x values
13301 C**********************************************************************
13302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13305 PARAMETER ( DEPS = 1.D-8 )
13307 DIMENSION XSOFT1(50)
13309 C input/output channels
13311 COMMON /POINOU/ LI,LO
13312 C event debugging information
13314 PARAMETER (NMAXD=100)
13315 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13316 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13317 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13318 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13319 C internal rejection counters
13321 PARAMETER (NMXJ=60)
13322 CHARACTER*10 REJTIT
13324 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13325 C data on most recent hard scattering
13326 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13327 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13328 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13329 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13330 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13331 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13332 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13333 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13334 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13337 DATA PVMES1 /-0.5D0/
13338 DATA PVMES2 /-0.5D0/
13339 DATA PVBAR1 / 1.5D0/
13340 DATA PVBAR2 /-0.5D0/
13346 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13347 XPOT1 = PVMES1+1.D0
13348 XPOT2 = PVMES2+1.D0
13349 C baryonic particle
13351 XPOT1 = PVBAR1+1.D0
13352 XPOT2 = PVBAR2+1.D0
13359 IF(ITER.GE.ITMAX) THEN
13360 IF(IDEB(39).GE.3) THEN
13361 WRITE(LO,'(1X,A,I8)')
13362 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13363 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13365 IFAIL(14) = IFAIL(14)+1
13369 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13370 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13372 IF((1.D0-XSS1).LT.AS) GOTO 100
13375 XSOFT1(1) = 1.D0-XSS1
13378 IF(IDEB(39).GE.10) THEN
13379 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13380 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13381 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13385 CDECK ID>, PHO_HADSP3
13386 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13387 C***********************************************************************
13389 C split hadron momentum XMAX into diquark & quark pair
13390 C using lower cut-off: AS
13392 C input: IFLB compressed particle code of particle to split
13393 C XS1 sum of x values already selected
13394 C XMAX maximal x possible
13396 C output: XS1 new sum of x values
13397 C XSOFT1 field of selected x values
13400 C**********************************************************************
13401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13403 PARAMETER ( DEPS = 1.D-8 )
13405 DIMENSION XSOFT1(50),XSOFT2(50)
13407 C input/output channels
13409 COMMON /POINOU/ LI,LO
13410 C event debugging information
13412 PARAMETER (NMAXD=100)
13413 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13414 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13415 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13416 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13417 C internal rejection counters
13419 PARAMETER (NMXJ=60)
13420 CHARACTER*10 REJTIT
13422 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13423 C data of c.m. system of Pomeron / Reggeon exchange
13424 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13425 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13426 & SIDP,CODP,SIFP,COFP
13427 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13428 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13429 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13431 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13434 DATA PVMES1 /-0.5D0/
13435 DATA PVMES2 /-0.5D0/
13436 DATA PSMES /-0.99D0/
13437 DATA PVBAR1 / 1.5D0/
13438 DATA PVBAR2 /-0.5D0/
13439 DATA PSBAR /-0.99D0/
13443 C determine exponents
13449 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13456 C baryonic particle
13476 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13477 & XSOFT1,XSOFT2,IREJ)
13480 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13481 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13482 IFAIL(15) = IFAIL(15)+1
13487 IF(IDEB(74).GE.10) THEN
13488 WRITE(LO,'(1X,A,I6,2E12.4)')
13489 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13491 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13497 CDECK ID>, PHO_SOFTXX
13498 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13499 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13500 C***********************************************************************
13502 C select soft x values
13504 C input: JM1,JM2 mother particle index in POEVT1
13505 C (0 flavour not known before)
13506 C MSPAR1,2 number of x values to select
13507 C IVAL1,2 number valence quarks involved in hard
13508 C scattering (0,1,2)
13509 C MSM1,2 minimum number of soft x to get sampled
13510 C XSUM1,2 sum of all x values samples up this call
13511 C XMAX1,2 max. x value
13513 C output XSUM1,2 new sum of x-values sampled
13514 C XS1,2 field containing sampled x values
13516 C x values of valence partons are first given
13518 C***********************************************************************
13519 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13522 C input/output channels
13524 COMMON /POINOU/ LI,LO
13525 C event debugging information
13527 PARAMETER (NMAXD=100)
13528 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13529 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13530 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13531 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13532 C internal rejection counters
13534 PARAMETER (NMXJ=60)
13535 CHARACTER*10 REJTIT
13537 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13538 C model switches and parameters
13540 INTEGER ISWMDL,IPAMDL
13541 DOUBLE PRECISION PARMDL
13542 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13543 C data of c.m. system of Pomeron / Reggeon exchange
13544 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13545 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13546 & SIDP,CODP,SIFP,COFP
13547 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13548 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13549 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13551 C standard particle data interface
13554 PARAMETER (NMXHEP=4000)
13556 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13557 DOUBLE PRECISION PHEP,VHEP
13558 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13559 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13561 C extension to standard particle data interface (PHOJET specific)
13562 INTEGER IMPART,IPHIST,ICOLOR
13563 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13565 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13566 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13567 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13568 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13569 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13570 C obsolete cut-off information
13571 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13572 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13573 C data on most recent hard scattering
13574 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13575 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13576 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13577 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13578 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13579 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13580 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13581 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13582 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13584 DIMENSION XS1(*),XS2(*)
13587 PARAMETER ( MAXPOT = 50 )
13588 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13592 MSMAX = MAX(MSPAR1,MSPAR2)
13593 MSMIN = MAX(MSM1,MSM2)
13595 IF(MSMAX.GT.MAXPOT) THEN
13596 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13597 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13602 C determine exponents
13603 IBAR1 = ipho_bar3(JM1,2)
13604 IBAR2 = ipho_bar3(JM2,2)
13606 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13607 C meson-baryon scattering (asymmetric sea)
13608 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13616 C lower limits for x sampling
13617 XMMINA = 2.D0*PARMDL(157)/ECMP
13618 XBMINA = 2.D0*PARMDL(158)/ECMP
13619 XSMINA = 2.D0*PARMDL(159)/ECMP
13620 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13621 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13622 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13623 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13624 XMIN1 = MAX(AS/XMAX2,XMIN1)
13625 XMIN2 = MAX(AS/XMAX1,XMIN2)
13628 XMMIN1 = MAX(XMIN1,XMMINA)
13629 XBMIN1 = MAX(XMIN1,XBMINA)
13630 XSMIN1 = MAX(XMIN1,XSMINA)
13632 IF(IBAR1.EQ.0) THEN
13633 IF(IHFLS(1).EQ.0) THEN
13634 XPOT1(1) = PARMDL(62)
13636 XPOT1(2) = PARMDL(63)
13639 XPOT1(1) = PARMDL(54)
13641 XPOT1(2) = PARMDL(55)
13644 DO 100 I=3-IVAL1,MSMAX
13648 C baryonic particle
13650 IF(IHFLS(1).EQ.0) THEN
13651 XPOT1(1) = PARMDL(62)
13653 XPOT1(2) = PARMDL(63)
13656 XPOT1(1) = PARMDL(50)
13658 XPOT1(2) = PARMDL(51)
13661 DO 200 I=3-IVAL1,MSMAX
13668 XMMIN2 = MAX(XMIN2,XMMINA)
13669 XBMIN2 = MAX(XMIN2,XBMINA)
13670 XSMIN2 = MAX(XMIN2,XSMINA)
13672 IF(IBAR2.EQ.0) THEN
13673 IF(IHFLS(2).EQ.0) THEN
13674 XPOT2(1) = PARMDL(62)
13676 XPOT2(2) = PARMDL(63)
13679 XPOT2(1) = PARMDL(54)
13681 XPOT2(2) = PARMDL(55)
13684 DO 300 I=3-IVAL2,MSMAX
13688 C baryonic particle
13690 IF(IHFLS(2).EQ.0) THEN
13691 XPOT2(1) = PARMDL(62)
13693 XPOT2(2) = PARMDL(63)
13696 XPOT2(1) = PARMDL(50)
13698 XPOT2(2) = PARMDL(51)
13701 DO 400 I=3-IVAL2,MSMAX
13711 C check limits (important for valences)
13712 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13713 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13716 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13718 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13720 XMINS1 = XMINS1+XMIN(1,I)
13721 XMINS2 = XMINS2+XMIN(2,I)
13723 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13725 C try to sample x values
13726 IF(IPAMDL(14).EQ.0) THEN
13727 IF(MSOFT.EQ.2) THEN
13728 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13730 ELSE IF(MSOFT.LT.5) THEN
13731 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13732 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13734 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13735 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13737 ELSE IF(IPAMDL(14).EQ.1) THEN
13738 IF(MSOFT.EQ.2) THEN
13739 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13742 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13743 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13745 ELSE IF(IPAMDL(14).EQ.2) THEN
13746 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13747 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13748 ELSE IF(IPAMDL(14).EQ.3) THEN
13749 IF(MSOFT.EQ.2) THEN
13750 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13752 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13753 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13754 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13756 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13757 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13760 WRITE(LO,'(/,1X,A,I3)')
13761 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13765 IFAIL(41) = IFAIL(41)+1
13766 IF(IDEB(60).GE.2) THEN
13767 WRITE(LO,'(1X,A,I12,4I3)')
13768 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13769 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13770 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13771 & XSUM1,XSUM2,XMAX1,XMAX2
13775 IF(MSOFT.NE.MSMAX) THEN
13776 MSDIFF = MSMAX-MSOFT
13777 MSPAR1 = MSPAR1-MSDIFF
13778 MSPAR2 = MSPAR2-MSDIFF
13781 C correct for different MSPAR numbers
13782 IF(MSOFT.NE.MSPAR1) THEN
13783 IF(MSPAR1.GT.1) THEN
13785 DO 500 I=MSPAR1+1,MSOFT
13788 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13790 XS1(I) = XS1(I)*XFAC
13792 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13797 IF(MSOFT.NE.MSPAR2) THEN
13798 IF(MSPAR2.GT.1) THEN
13800 DO 600 I=MSPAR2+1,MSOFT
13803 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13805 XS2(I) = XS2(I)*XFAC
13807 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13814 XS1(1) = 1.D0 - XSS1
13815 XS2(1) = 1.D0 - XSS2
13820 IF(IDEB(60).GE.10) THEN
13821 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13822 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13823 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13824 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13826 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13827 & XMIN(1,I),XMIN(2,I)
13833 C not enough phase space
13836 IFAIL(42) = IFAIL(42)+1
13840 IF(IDEB(60).GE.1) THEN
13841 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13842 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13843 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13844 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13845 WRITE(LO,'(1X,A,1P,3E11.3)')
13846 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13847 WRITE(LO,'(1X,A,1P,3E11.3)')
13848 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13849 WRITE(LO,'(1X,A,1P,3E11.3)')
13850 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13852 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13854 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13856 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13857 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13858 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13859 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13861 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13862 & XMIN(1,I),XMIN(2,I)
13868 CDECK ID>, PHO_SELSXR
13869 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13870 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13871 C***********************************************************************
13873 C select x values of soft string ends (rejection method)
13875 C***********************************************************************
13876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13879 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13881 C input/output channels
13883 COMMON /POINOU/ LI,LO
13884 C event debugging information
13886 PARAMETER (NMAXD=100)
13887 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13888 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13889 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13890 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13891 C model switches and parameters
13893 INTEGER ISWMDL,IPAMDL
13894 DOUBLE PRECISION PARMDL
13895 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13896 C data on most recent hard scattering
13897 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13898 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13899 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13900 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13901 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13902 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13903 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13904 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13905 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13906 C global event kinematics and particle IDs
13907 INTEGER IFPAP,IFPAB
13908 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13909 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13910 C obsolete cut-off information
13911 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13912 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13914 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13916 IF(IDEB(13).GE.10) THEN
13917 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13918 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13919 & MSOFT,XS1,XS2,XMAX1,XMAX2
13921 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13927 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13928 XMIN1 = MAX(AS/XMAX1,XMINK)
13929 XMIN2 = MAX(AS/XMAX2,XMINK)
13931 IF(MSOFT.EQ.1) THEN
13936 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13937 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13942 POT(1,I) = XPOT1(I)+1.D0
13943 POT(2,I) = XPOT2(I)+1.D0
13944 REVP(1,I) = 1.D0/POT(1,I)
13945 REVP(2,I) = 1.D0/POT(2,I)
13946 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13947 XLMAX = XMAX1**POT(1,I)
13948 XLDIF(1,I) = XLMAX-XLMIN(1,I)
13949 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13950 XLMAX = XMAX2**POT(2,I)
13951 XLDIF(2,I) = XLMAX-XLMIN(2,I)
13957 IF(ITRY0.GE.IPAMDL(181)) THEN
13958 IF(MSOFT-MSMIN.GE.2) THEN
13970 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13971 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13972 XSOFT1(I) = Z1**REVP(1,I)
13973 XSOFT2(I) = Z2**REVP(2,I)
13975 IF(ITRY1.GE.50) GOTO 1000
13976 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13978 XREST1 = XREST1-XSOFT1(I)
13979 IF(XREST1.LT.XMIN1) GOTO 5
13980 IF(XREST1.LT.XMIN(1,1)) GOTO 5
13981 XREST2 = XREST2-XSOFT2(I)
13982 IF(XREST2.LT.XMIN2) GOTO 5
13983 IF(XREST2.LT.XMIN(2,1)) GOTO 5
13984 IF(XREST1*XREST2.LT.AS) GOTO 5
13992 * XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13994 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13995 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
14003 IF(IDEB(13).GE.2) THEN
14004 WRITE(LO,'(1X,A,2I4)')
14005 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
14006 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14011 CDECK ID>, PHO_SELSX2
14012 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14014 C***********************************************************************
14016 C select x values of soft string ends using PHO_RNDBET
14018 C***********************************************************************
14019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14022 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14024 C input/output channels
14026 COMMON /POINOU/ LI,LO
14027 C event debugging information
14029 PARAMETER (NMAXD=100)
14030 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14031 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14032 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14033 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14034 C model switches and parameters
14036 INTEGER ISWMDL,IPAMDL
14037 DOUBLE PRECISION PARMDL
14038 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14039 C data on most recent hard scattering
14040 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14041 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14042 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14043 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14044 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14045 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14046 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14047 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14048 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14049 C obsolete cut-off information
14050 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14051 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14055 IF(IDEB(32).GE.10) THEN
14056 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14057 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14058 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14060 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14067 GAM1 = XPOT1(1)+1.D0
14068 GAM2 = XPOT2(1)+1.D0
14069 BET1 = XPOT1(2)+1.D0
14070 BET2 = XPOT2(2)+1.D0
14073 DO 100 I=1,IPAMDL(182)
14077 X1 = PHO_RNDBET(GAM1,BET1)
14079 IF(ITRY1.GE.50) GOTO 1000
14080 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14084 X2 = PHO_RNDBET(GAM2,BET2)
14086 IF(ITRY2.GE.50) GOTO 1000
14087 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14091 IF(X1*X2*FAC.GT.AS) THEN
14092 IF(X3*X4*FAC.GT.AS) THEN
14097 IF(XS1(1).GT.XMIN(1,1)) THEN
14098 IF(XS2(1).GT.XMIN(2,1)) THEN
14099 IF(XS1(2).GT.XMIN(1,2)) THEN
14100 IF(XS2(2).GT.XMIN(2,2)) THEN
14101 XSUM1 = XSUM1+XS1(2)
14102 XSUM2 = XSUM2+XS2(2)
14116 IF(IDEB(32).GE.2) THEN
14117 WRITE(LO,'(1X,A,3I4)')
14118 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14119 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14126 CDECK ID>, PHO_SELSXS
14127 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14128 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14129 C***********************************************************************
14131 C select x values of soft string ends (rescaling method)
14133 C***********************************************************************
14134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14137 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14139 C input/output channels
14141 COMMON /POINOU/ LI,LO
14142 C event debugging information
14144 PARAMETER (NMAXD=100)
14145 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14146 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14147 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14148 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14149 C model switches and parameters
14151 INTEGER ISWMDL,IPAMDL
14152 DOUBLE PRECISION PARMDL
14153 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14154 C data on most recent hard scattering
14155 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14156 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14157 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14158 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14159 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14160 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14161 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14162 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14163 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14164 C obsolete cut-off information
14165 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14166 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14168 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14174 IF(MSOFT.EQ.1) THEN
14175 XSOFT1(1) = 1.D0-XS1
14177 XSOFT2(1) = 1.D0-XS2
14183 POT(1,I) = XPOT1(I)+1.D0
14184 POT(2,I) = XPOT2(I)+1.D0
14185 REVP(1,I) = 1.D0/POT(1,I)
14186 REVP(2,I) = 1.D0/POT(2,I)
14187 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14188 XLMAX = XMAX1**POT(1,I)
14189 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14190 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14191 XLMAX = XMAX2**POT(2,I)
14192 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14198 IF(ITRY0.GE.IPAMDL(180)) THEN
14199 IF(MSOFT-MSMIN.GE.2) THEN
14210 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14211 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14212 XSOFT1(I) = Z1**REVP(1,I)
14213 XSOFT2(I) = Z2**REVP(2,I)
14215 IF(ITRY1.GE.50) GOTO 1000
14216 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14217 XSUM1 = XSUM1+XSOFT1(I)
14218 XSUM2 = XSUM2+XSOFT2(I)
14220 FAC1 = (1.D0-XS1)/XSUM1
14221 FAC2 = (1.D0-XS2)/XSUM2
14223 XSOFT1(I) = XSOFT1(I)*FAC1
14224 XSOFT2(I) = XSOFT2(I)*FAC2
14225 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14226 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14227 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14230 XS1 = 1.D0-XSOFT1(1)
14231 XS2 = 1.D0-XSOFT2(1)
14236 IF(IDEB(14).GE.2) THEN
14237 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14238 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14240 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14246 CDECK ID>, PHO_SELSXI
14247 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14248 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14249 C***********************************************************************
14251 C select x values of soft string ends (sea independent from valence)
14253 C***********************************************************************
14254 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14257 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14259 C input/output channels
14261 COMMON /POINOU/ LI,LO
14262 C event debugging information
14264 PARAMETER (NMAXD=100)
14265 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14266 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14267 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14268 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14269 C model switches and parameters
14271 INTEGER ISWMDL,IPAMDL
14272 DOUBLE PRECISION PARMDL
14273 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14274 C data on most recent hard scattering
14275 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14276 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14277 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14278 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14279 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14280 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14281 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14282 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14283 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14284 C obsolete cut-off information
14285 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14286 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14288 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14295 POT(1,I) = XPOT1(I)+1.D0
14296 POT(2,I) = XPOT2(I)+1.D0
14297 REVP(1,I) = 1.D0/POT(1,I)
14298 REVP(2,I) = 1.D0/POT(2,I)
14299 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14300 XLMAX = XMAX1**POT(1,I)
14301 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14302 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14303 XLMAX = XMAX2**POT(2,I)
14304 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14312 IF(ITRY0.GE.IPAMDL(183)) THEN
14313 IF(MSOFT-MSMIN.GE.2) THEN
14324 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14325 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14326 XSOFT1(I) = Z1**REVP(1,I)
14327 XSOFT2(I) = Z2**REVP(2,I)
14329 IF(ITRY1.GE.50) GOTO 1000
14330 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14331 XSUM1 = XSUM1+XSOFT1(I)
14332 XSUM2 = XSUM2+XSOFT2(I)
14335 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14336 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14338 C selection of valence
14339 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14340 & XSOFT1,XSOFT2,IREJ)
14342 IF(MSOFT-MSMIN.GE.2) THEN
14346 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14347 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14348 & XSUM1,XSUM2,XMAX1,XMAX2
14352 XS1 = 1.D0-XSOFT1(1)
14353 XS2 = 1.D0-XSOFT2(1)
14358 IF(IDEB(14).GE.2) THEN
14359 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14360 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14362 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14368 CDECK ID>, PHO_SELCOL
14369 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370 C********************************************************************
14372 C color combinatorics
14374 C input: ICO1,2 colors of incoming particle
14375 C IMODE -2 output of initialization status
14376 C -1 initialization
14377 C ICINP(1) selection mode
14379 C 1 large N_c expansion
14380 C ICINP(2) max. allowed color
14381 C 0 clear internal color counter
14382 C 1 hadron into two colored objects
14383 C 2 quark into quark gluon
14384 C 3 gluon into gluon gluon
14385 C 4 gluon into quark antiquark
14387 C output: ICOA1,2 colors of first outgoing particle
14388 C ICOB1,2 colors of second outgoing particle
14390 C********************************************************************
14391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14394 C input/output channels
14396 COMMON /POINOU/ LI,LO
14397 C event debugging information
14399 PARAMETER (NMAXD=100)
14400 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14401 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14402 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14403 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14405 DATA METHOD /0/, II /0/
14409 IF(METHOD.EQ.0) THEN
14411 IF(IMODE.EQ.1) THEN
14414 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14419 ELSE IF(IMODE.EQ.2) THEN
14422 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14433 ELSE IF(IMODE.EQ.3) THEN
14436 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14437 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14448 ELSE IF(IMODE.EQ.4) THEN
14453 ELSE IF(IMODE.EQ.0) THEN
14455 ELSE IF(IMODE.EQ.-1) THEN
14458 ELSE IF(IMODE.EQ.-2) THEN
14459 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14462 WRITE(LO,'(1X,A,I5)')
14463 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14468 WRITE(LO,'(1X,A,I5)')
14469 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14474 IF(IDEB(75).GE.10) THEN
14475 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14477 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14478 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14483 CDECK ID>, ipho_diqu
14484 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14485 C***********************************************************************
14487 C selection of diquark number (PDG convention)
14489 C***********************************************************************
14497 C input/output channels
14499 COMMON /POINOU/ LI,LO
14500 C event debugging information
14502 PARAMETER (NMAXD=100)
14503 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14504 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14505 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14506 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14507 C model switches and parameters
14509 INTEGER ISWMDL,IPAMDL
14510 DOUBLE PRECISION PARMDL
14511 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14513 C external functions
14514 double precision DT_RNDM
14518 double precision dum
14526 i0 = max(i1,i2)*1000+min(i1,i2)*100
14527 if(DT_RNDM(dum).gt.PARMDL(135)) then
14534 ipho_diqu = sign(i0,iq1)
14538 CDECK ID>, PHO_PARREM
14539 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14540 C**********************************************************************
14542 C selection of particle remnant flavour(s) (quark or diquark)
14544 C input: INDX index of particle in /POEVT1/
14545 C IOUT parton which was taken out
14547 C output: IREM remnant according to valence flavours
14548 C IREJ 0 flavour combination possible
14549 C 1 flavour combination impossible
14551 C all particle ID are given according to PDG conventions
14553 C**********************************************************************
14559 integer INDX,IOUT,IREM,IREJ
14561 C input/output channels
14563 COMMON /POINOU/ LI,LO
14564 C event debugging information
14566 PARAMETER (NMAXD=100)
14567 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14568 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14569 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14570 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14572 C standard particle data interface
14575 PARAMETER (NMXHEP=4000)
14577 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14578 DOUBLE PRECISION PHEP,VHEP
14579 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14580 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14582 C extension to standard particle data interface (PHOJET specific)
14583 INTEGER IMPART,IPHIST,ICOLOR
14584 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14586 C general particle data
14587 double precision xm_list,tau_list,gam_list,
14588 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14589 & xm_bb82_list,xm_bb102_list
14590 integer ich3_list,iba3_list,iq_list,
14591 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14592 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14593 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14594 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14595 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14596 & ich3_list(300),iba3_list(300),iq_list(3,300),
14597 & id_psm_list(6,6),id_vem_list(6,6),
14598 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14600 C external functions
14604 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14605 dimension IQUA(3),IDQ(2)
14612 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14616 C particle with flavour mixing
14621 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14622 C pi0, rho0, and omega
14623 IF(ABS(IOUT).LE.2) THEN
14629 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14630 C neutral kaons (K0,K0-bar)
14631 if(abs(IOUT).eq.1) then
14632 IREM = sign(3,-IOUT)
14634 else if(abs(IOUT).eq.3) then
14635 IREM = sign(1,-IOUT)
14640 else if((ID1.eq.990).or.(ID1.eq.110)) then
14641 C pomeron and reggeon
14649 IQUA(1) = iq_list(1,ID)*IS
14650 IQUA(2) = iq_list(2,ID)*IS
14651 IQUA(3) = iq_list(3,ID)*IS
14653 C compare to flavour content
14654 IF(ABS(IOUT).LT.1000) THEN
14655 C single quark requested
14656 IF(IQUA(1).EQ.IOUT) THEN
14659 ELSE IF(IQUA(2).EQ.IOUT) THEN
14662 ELSE IF(IQUA(3).EQ.IOUT) THEN
14668 IF(IQUA(3).EQ.0) THEN
14671 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14673 ELSE IF(IQUA(3).NE.0) THEN
14674 C diquark requested from baryon
14676 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14679 if(IDQ(i).eq.IQUA(k)) then
14687 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14692 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14693 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14694 & INDX,ID1,ID2,IOUT,IREM
14700 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14701 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14705 CDECK ID>, PHO_VALFLA
14706 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14707 C***********************************************************************
14709 C selection of valence flavour decomposition of particle IPAR
14711 C input: IPAR particle index in /POEVT1/
14712 C -1 initialization
14713 C -2 output of statistics
14714 C XMASS mass of particle
14715 C (important for pomeron:
14716 C mass dependent flavour sampling)
14718 C output: IFL1,IFL2
14719 C baryon: IFL1 diquark flavour
14720 C (valence flavours according to PDG conventions)
14722 C***********************************************************************
14723 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14726 PARAMETER ( EPS = 0.1D0,
14729 C input/output channels
14731 COMMON /POINOU/ LI,LO
14732 C event debugging information
14734 PARAMETER (NMAXD=100)
14735 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14736 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14737 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14738 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14739 C model switches and parameters
14741 INTEGER ISWMDL,IPAMDL
14742 DOUBLE PRECISION PARMDL
14743 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14745 C standard particle data interface
14748 PARAMETER (NMXHEP=4000)
14750 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14751 DOUBLE PRECISION PHEP,VHEP
14752 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14753 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14755 C extension to standard particle data interface (PHOJET specific)
14756 INTEGER IMPART,IPHIST,ICOLOR
14757 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14759 C general particle data
14760 double precision xm_list,tau_list,gam_list,
14761 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14762 & xm_bb82_list,xm_bb102_list
14763 integer ich3_list,iba3_list,iq_list,
14764 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14765 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14766 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14767 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14768 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14769 & ich3_list(300),iba3_list(300),iq_list(3,300),
14770 & id_psm_list(6,6),id_vem_list(6,6),
14771 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14777 C select particle code
14779 ID = abs(IMPART(K))
14780 IBAR = IPHO_BAR3(K,2)
14788 if(ITER.GT.ITMX) then
14789 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14790 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14799 C charge dependent flavour sampling
14801 K = INT(DT_RNDM(E1)*6.D0)+1
14805 ELSE IF(K.EQ.5) THEN
14812 C optional strangeness suppression
14813 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14814 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14821 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14822 IF(ISWMDL(19).EQ.0) THEN
14823 C SU(3) symmetric valences
14824 K = INT(DT_RNDM(E1)*3.D0)+1
14825 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14831 ELSE IF(ISWMDL(19).EQ.1) THEN
14832 C mass dependent flavour sampling
14834 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14836 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14837 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14841 C meson with flavour mixing
14842 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14843 K = INT(2.D0*DT_RNDM(E1))+1
14848 K = INT(2.D0*DT_RNDM(E1))+1
14849 IFL1 = iq_list(K,ID)
14851 IFL2 = iq_list(K,ID)
14854 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14860 K = INT(2.999999D0*DT_RNDM(E2))+1
14863 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14864 IFL2 = iq_list(K,ID)
14867 C change sign for antiparticles
14873 ************************************************************************
14874 C check kinematic constraints
14875 * IF((PHO_PMASS(IFL1,3).GT.E1)
14876 * & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14877 ************************************************************************
14880 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14881 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14883 ELSE IF(IPAR.EQ.-1) THEN
14886 ELSE IF(IPAR.EQ.-2) THEN
14887 C output of final statistics
14890 WRITE(LO,'(1X,A,I10)')
14891 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14897 CDECK ID>, PHO_REGFLA
14898 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14899 C**********************************************************************
14901 C selection of reggeon flavours
14903 C input: JM1,JM2 position index of mother hadrons
14905 C output: IFLR1,IFLR2 valence flavours according to
14906 C PDG conventions and JM1,JM2
14907 C IREJ 0 reggeon possible
14908 C 1 reggeon impossible
14910 C**********************************************************************
14911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14914 PARAMETER ( EPS = 0.1D0,
14917 C input/output channels
14919 COMMON /POINOU/ LI,LO
14920 C event debugging information
14922 PARAMETER (NMAXD=100)
14923 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14924 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14925 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14926 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14927 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
14928 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14929 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14930 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14931 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14933 C standard particle data interface
14936 PARAMETER (NMXHEP=4000)
14938 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14939 DOUBLE PRECISION PHEP,VHEP
14940 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14941 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14943 C extension to standard particle data interface (PHOJET specific)
14944 INTEGER IMPART,IPHIST,ICOLOR
14945 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14951 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14952 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
14953 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
14954 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14957 IF(ITER.GT.50) THEN
14960 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14961 & 'PHO_REGFLA: rejection, no reggeon found for',
14962 & IDHEP(JM1),IDHEP(JM2),E1
14966 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14967 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14968 IF(IFLA1.EQ.-IFLB1) THEN
14971 ELSE IF(IFLA1.EQ.-IFLB2) THEN
14974 ELSE IF(IFLA2.EQ.-IFLB1) THEN
14977 ELSE IF(IFLA2.EQ.-IFLB2) THEN
14982 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14983 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14987 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14988 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14989 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14990 ELSE IF(JM1.EQ.-1) THEN
14992 ELSE IF(JM1.EQ.-2) THEN
14993 C output of statistics
14995 WRITE(LO,'(1X,A,I10)')
14996 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
15002 CDECK ID>, PHO_SEAFLA
15003 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15004 C**********************************************************************
15006 C selection of sea flavour content of particle IPAR
15008 C input: IPAR particle index in /POEVT1/
15009 C CHMASS available invariant string mass
15010 C positive mass --> use BAMJET method
15011 C negative mass --> SU(3) symmetric sea according
15012 C to values given in PARMDL(1-6)
15013 C IPAR -1 initialization
15014 C -2 output of statistics
15016 C output: sea flavours according to PDG conventions
15018 C**********************************************************************
15019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15022 PARAMETER ( EPS = 0.1D0,
15025 C input/output channels
15027 COMMON /POINOU/ LI,LO
15028 C event debugging information
15030 PARAMETER (NMAXD=100)
15031 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15032 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15033 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15034 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15035 C model switches and parameters
15037 INTEGER ISWMDL,IPAMDL
15038 DOUBLE PRECISION PARMDL
15039 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15040 C some hadron information, will be deleted in future versions
15042 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15043 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15046 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15047 C constant weights for sea
15051 SUM = SUM + PARMDL(K)
15053 XI = DT_RNDM(SUM)*SUM
15056 SUM = SUM + PARMDL(K)
15057 IF(XI.LE.SUM) GOTO 55
15060 IF(K.GT.NFSEA) GOTO 15
15062 C mass dependent flavour sampling
15064 CALL PHO_FLAUX(CHMASS,K)
15065 IF(K.GT.NFSEA) GOTO 10
15067 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15070 IF(IDEB(46).GE.10) THEN
15071 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15072 & IPAR,IFL1,IFL2,CHMASS
15074 ELSE IF(IPAR.EQ.-1) THEN
15077 ELSE IF(IPAR.EQ.-2) THEN
15078 C output of statistics
15080 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15086 CDECK ID>, PHO_FLAUX
15087 SUBROUTINE PHO_FLAUX(EQUARK,K)
15088 C***********************************************************************
15090 C auxiliary subroutine to select flavours
15092 C********************************************************************
15093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15096 PARAMETER ( DEPS = 1.D-14 )
15098 C input/output channels
15100 COMMON /POINOU/ LI,LO
15101 C event debugging information
15103 PARAMETER (NMAXD=100)
15104 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15105 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15106 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15107 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15108 C some hadron information, will be deleted in future versions
15110 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15111 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15115 C calculate weights for given energy
15116 IF(EQUARK.LT.QMASS(1)) THEN
15118 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15128 IF(EQUARK.GT.QMASS(K)) THEN
15129 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15133 SUM = SUM + WGHT(K)
15137 XI = SUM*(DT_RNDM(SUM)-DEPS)
15142 SUM = SUM + WGHT(K)
15143 IF(XI.GT.SUM) GOTO 400
15145 IF(IDEB(16).GE.20) THEN
15146 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15150 CDECK ID>, PHO_BETAF
15151 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15152 C********************************************************************
15154 C weights of different quark flavours
15156 C********************************************************************
15157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15162 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15163 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15169 CDECK ID>, PHO_MCHECK
15170 SUBROUTINE PHO_MCHECK(J1,IREJ)
15171 C********************************************************************
15173 C check parton momenta for fragmentation
15175 C input: J1 first string number
15181 C IREJ 0 successful
15184 C in case of very small string mass:
15185 C NNCH mass label of string
15187 C -1 octett baryon / pseudo scalar meson
15188 C 1 decuplett baryon / vector meson
15189 C IBHAD hadron number according to CPC,
15190 C string will be treated as resonance
15191 C (sometimes far off mass shell)
15193 C constant WIDTH ( 0.01GeV ) determines range of acceptance
15195 C********************************************************************
15196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15199 PARAMETER ( WIDTH = 0.01D0,
15202 C input/output channels
15204 COMMON /POINOU/ LI,LO
15205 C event debugging information
15207 PARAMETER (NMAXD=100)
15208 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15209 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15210 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15211 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15212 C model switches and parameters
15214 INTEGER ISWMDL,IPAMDL
15215 DOUBLE PRECISION PARMDL
15216 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15218 C standard particle data interface
15221 PARAMETER (NMXHEP=4000)
15223 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15224 DOUBLE PRECISION PHEP,VHEP
15225 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15226 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15228 C extension to standard particle data interface (PHOJET specific)
15229 INTEGER IMPART,IPHIST,ICOLOR
15230 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15232 C color string configurations including collapsed strings and hadrons
15234 PARAMETER (MSTR=500)
15235 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15236 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15237 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15238 & NNCH(MSTR),IBHAD(MSTR),ISTR
15239 C internal rejection counters
15241 PARAMETER (NMXJ=60)
15242 CHARACTER*10 REJTIT
15244 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15247 C quark antiquark jet
15248 STRM = PHEP(5,NPOS(1,J1))
15249 IF(NCODE(J1).EQ.3) THEN
15250 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15251 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15253 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15254 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15255 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15256 IF(STRM.LT.AMPS) THEN
15258 IFAIL(20) = IFAIL(20) + 1
15260 ELSE IF(STRM.LT.AMPS2) THEN
15261 IF(STRM.LT.(AMVE-WIDTH)) THEN
15272 C quark diquark or v.s. jet
15273 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15274 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15275 & AM8,AM82,AM10,AM102,I8,I10)
15277 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15278 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15279 & J1,STRM,AM8,AM82,AM10,AM102
15280 IF(STRM.LT.AM8) THEN
15282 IFAIL(19) = IFAIL(19) + 1
15284 ELSE IF(STRM.LT.AM82) THEN
15285 IF(STRM.LT.(AM10-WIDTH)) THEN
15296 C diquark a-diquark string
15297 ELSE IF(NCODE(J1).EQ.5) THEN
15298 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15301 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15302 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15303 & J1,STRM,AM82,AM102
15304 IF(STRM.LT.AM82) THEN
15306 IFAIL(19) = IFAIL(19) + 1
15312 ELSE IF(NCODE(J1).LT.0) THEN
15315 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15316 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15321 CDECK ID>, PHO_POMCOR
15322 SUBROUTINE PHO_POMCOR(IREJ)
15323 C********************************************************************
15325 C join quarks to gluons in case of too small masses
15329 C IREJ -1 initialization
15330 C -2 output of statistics
15334 C IREJ 0 successful
15338 C********************************************************************
15339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15342 PARAMETER ( EPS = 1.D-10 )
15344 C input/output channels
15346 COMMON /POINOU/ LI,LO
15347 C event debugging information
15349 PARAMETER (NMAXD=100)
15350 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15351 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15352 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15353 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15354 C model switches and parameters
15356 INTEGER ISWMDL,IPAMDL
15357 DOUBLE PRECISION PARMDL
15358 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15360 C standard particle data interface
15363 PARAMETER (NMXHEP=4000)
15365 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15366 DOUBLE PRECISION PHEP,VHEP
15367 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15368 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15370 C extension to standard particle data interface (PHOJET specific)
15371 INTEGER IMPART,IPHIST,ICOLOR
15372 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15374 C color string configurations including collapsed strings and hadrons
15376 PARAMETER (MSTR=500)
15377 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15378 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15379 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15380 & NNCH(MSTR),IBHAD(MSTR),ISTR
15384 IF(IREJ.EQ.-1) THEN
15388 ELSE IF(IREJ.EQ.-2) THEN
15389 C *** Commented by Chiara
15390 C WRITE(LO,'(/1X,A,2I8)')
15391 C & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15400 IF(ISWMDL(25).LE.0) RETURN
15401 C debug string entries
15402 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15406 IF(ITER.GE.NITER) THEN
15408 IF(IDEB(83).GE.2) THEN
15409 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15410 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15415 C check mass limits
15418 IF(NCODE(I).LT.0) GOTO 99
15420 NRPOM = IPHIST(2,J1)
15421 IF(NRPOM.GE.100) GOTO 99
15422 CMASS0 = PHEP(5,J1)
15424 IF(NCODE(I).EQ.3) THEN
15425 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15426 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15427 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15428 & AM1,AM2,AM3,AM4,IP1,IP2)
15429 ELSE IF(NCODE(I).EQ.5) THEN
15430 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15436 ELSE IF(NCODE(I).EQ.7) THEN
15438 ELSE IF(NCODE(I).LT.0) THEN
15441 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15446 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15447 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15448 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15449 C select masses to correct
15450 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15452 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15454 C join quarks to gluon
15455 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15463 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15464 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15465 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15466 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15467 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15468 IFL1 = ABS(IDHEP(KK1))
15470 PROB1 = 0.1D0/MAX(CMASS,EPS)
15472 PROB1 = 0.9D0/MAX(CMASS,EPS)
15475 KK1 = ABS(NPOS(3,I))
15476 KK2 = ABS(NPOS(3,K))
15477 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15478 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15479 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15480 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15481 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15482 IFL2 = ABS(IDHEP(KK1))
15484 PROB2 = 0.1D0/MAX(CMASS,EPS)
15486 PROB2 = 0.9D0/MAX(CMASS,EPS)
15489 IF(IFL1+IFL2.EQ.0) GOTO 99
15492 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15499 KK1 = ABS(NPOS(JJ,I))
15500 KK2 = ABS(NPOS(JJ,K))
15501 I1 = ABS(NPOS(JE,I))
15506 K2 = ABS(NPOS(JE,K))
15510 C copy mother partons of string I
15512 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15513 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15514 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15518 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15520 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15521 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15522 C copy mother partons of string K
15524 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15525 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15526 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15528 C create new string entry
15530 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15533 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15534 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15535 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15536 C delete string K in /POSTRG/
15538 C update string I in /POSTRG/
15542 C calculate new CPC string codes
15543 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15544 & IPAR2(I),IPAR3(I),IPAR4(I))
15552 IF(IDEB(83).GE.20) THEN
15553 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15554 IF(IDEB(83).GE.22) THEN
15562 CDECK ID>, PHO_MASCOR
15563 SUBROUTINE PHO_MASCOR(IREJ)
15564 C********************************************************************
15566 C check and adjust parton momenta for fragmentation
15570 C IREJ -1 initialization
15571 C -2 output of statistics
15575 C IREJ 0 successful
15578 C in case of very small string mass:
15579 C - direct manipulation of /POEVT1/ and /POEVT2/
15580 C - string will be deleted from /POSTRG/ (label -99)
15582 C********************************************************************
15583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15586 PARAMETER ( EPS = 1.D-10,
15590 C input/output channels
15592 COMMON /POINOU/ LI,LO
15593 C event debugging information
15595 PARAMETER (NMAXD=100)
15596 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15597 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15598 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15599 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15600 C internal rejection counters
15602 PARAMETER (NMXJ=60)
15603 CHARACTER*10 REJTIT
15605 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15606 C model switches and parameters
15608 INTEGER ISWMDL,IPAMDL
15609 DOUBLE PRECISION PARMDL
15610 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15612 C standard particle data interface
15615 PARAMETER (NMXHEP=4000)
15617 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15618 DOUBLE PRECISION PHEP,VHEP
15619 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15620 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15622 C extension to standard particle data interface (PHOJET specific)
15623 INTEGER IMPART,IPHIST,ICOLOR
15624 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15626 C color string configurations including collapsed strings and hadrons
15628 PARAMETER (MSTR=500)
15629 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15630 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15631 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15632 & NNCH(MSTR),IBHAD(MSTR),ISTR
15634 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15636 IF(IREJ.EQ.-1) THEN
15640 ELSE IF(IREJ.EQ.-2) THEN
15641 C *** Commented by Chiara
15642 C WRITE(LO,'(/1X,A,2I8/)')
15643 C & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15651 IF(ISWMDL(7).EQ.-1) RETURN
15653 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15658 IF(ITER.GE.NITER) THEN
15660 IF(IDEB(42).GE.2) THEN
15661 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15662 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15667 C check mass limits
15668 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15677 DO 100 I=IM1,IM2,IST
15679 CMASS0 = PHEP(5,J1)
15681 IF(NCODE(I).EQ.3) THEN
15682 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15683 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15684 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15685 & AM1,AM2,AM3,AM4,IP1,IP2)
15686 ELSE IF(NCODE(I).EQ.5) THEN
15687 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15693 ELSE IF(NCODE(I).EQ.7) THEN
15698 *??????????????????????????????????
15701 *??????????????????????????????????
15702 ELSE IF(NCODE(I).LT.0) THEN
15705 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15709 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15710 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15711 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15712 C select masses to correct
15715 C correction needed?
15716 C no resonances for diquark-antidiquark and gluon-gluon strings
15717 IF(NCODE(I).EQ.5) THEN
15718 IF(CMASS0.LT.1.3D0*AM1) THEN
15719 IF(ISWMDL(7).LE.2) THEN
15730 C resonances possible
15731 IF(ISWMDL(7).EQ.0) THEN
15732 IF(CMASS0.LT.AM1*0.99D0) THEN
15737 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15738 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15739 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15740 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15750 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15751 IF(CMASS0.LT.AM1*0.99) THEN
15757 ELSE IF(ISWMDL(7).EQ.3) THEN
15758 IF(CMASS0.LT.AM1) THEN
15763 WRITE(LO,'(/1X,A,I5)')
15764 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15769 C correction necessary?
15770 IF(IBHAD(I).NE.0) THEN
15771 C find largest invar. mass
15774 DO 200 J2=NHEP,3,-1
15776 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15777 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15778 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15779 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15781 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15782 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15783 & -(PHEP(1,J1)+PHEP(1,J2))**2
15784 & -(PHEP(2,J1)+PHEP(2,J2))**2
15785 & -(PHEP(3,J1)+PHEP(3,J2))**2
15786 IF(CMASS2.GT.CMASS1) THEN
15795 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15796 IF(INEED.EQ.1) THEN
15807 CMASS1 = SQRT(CMASS1)
15808 CMASS2 = PHEP(5,J2)
15809 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15811 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15812 & CHMASS,CMASS2,PC1,PC2,IREJ)
15814 IFAIL(24) = IFAIL(24)+1
15815 IF(IDEB(42).GE.2) THEN
15816 WRITE(LO,'(1X,A,2I4)')
15817 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15818 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15823 C momentum transfer
15825 PTR(II) = PHEP(II,J2)-PC2(II)
15827 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15828 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15829 C copy parents of strings
15830 C register partons belonging to first string
15831 IF(IDHEP(J1).EQ.90) THEN
15833 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15836 ESUM = ESUM+PHEP(4,II)
15838 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15840 FAC = PHEP(4,II)/ESUM
15842 P1(K) = PHEP(K,II)+FAC*PTR(K)
15844 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15845 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15846 & ICOLOR(2,II),IPOS,1)
15849 IF(JMOHEP(2,J1).GT.0) THEN
15851 FAC = PHEP(4,II)/ESUM
15853 P1(K) = PHEP(K,II)+FAC*PTR(K)
15855 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15856 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15857 & ICOLOR(2,II),IPOS,1)
15864 C register partons belonging to second string
15865 IF(IDHEP(J2).EQ.90) THEN
15866 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15868 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15871 ESUM = ESUM+PHEP(4,II)
15873 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15875 FAC = PHEP(4,II)/ESUM
15876 IF(IREJL.EQ.0) THEN
15877 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15878 P1(4) = P1(4)+FAC*DELE
15881 P1(K) = PHEP(K,II)-FAC*PTR(K)
15884 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15885 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15886 & ICOLOR(2,II),IPOS,1)
15889 IF(JMOHEP(2,J2).GT.0) THEN
15891 FAC = PHEP(4,II)/ESUM
15892 IF(IREJL.EQ.0) THEN
15893 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15894 P1(4) = P1(4)+FAC*DELE
15897 P1(K) = PHEP(K,II)-FAC*PTR(K)
15900 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15901 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15902 & ICOLOR(2,II),IPOS,1)
15909 C register first string/collapsed to hadron
15910 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15911 IF(NCODE(I).NE.5) THEN
15912 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15913 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15914 C label string as collapsed to hadron/resonance
15918 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15919 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15926 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15927 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15928 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15929 IF(IDHEP(J1).EQ.90) THEN
15930 NPOS(1,IPHIST(1,J1)) = IPOS
15931 NPOS(2,IPHIST(1,J1)) = K1A
15932 NPOS(3,IPHIST(1,J1)) = K2A
15933 C label string as collapsed to resonance-string
15935 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15936 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15939 C register second string/hadron/parton
15940 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15941 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15942 & ICOLOR(2,J2),IPOS,1)
15943 IF(IDHEP(J2).EQ.90) THEN
15944 NPOS(1,IPHIST(1,J2))=IPOS
15945 NPOS(2,IPHIST(1,J2))=K1B
15946 NPOS(3,IPHIST(1,J2))=K2B
15947 C label string touched by momentum transfer
15949 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15950 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15954 C consistency checks
15955 IF(IDEB(42).GE.5) THEN
15956 CALL PHO_CHECK(-1,IDEV)
15957 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15959 C jump to next iteration
15965 IF(IDEB(42).GE.15) THEN
15966 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15967 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15973 CDECK ID>, PHO_PARCOR
15974 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15975 C********************************************************************
15977 C conversion of string partons (using JETSET masses)
15979 C input: MODE >0 position index of corresponding string
15980 C -1 initialization
15981 C -2 output of statistics
15984 C IREJ 1 combination of strings impossible
15985 C 0 successful combination
15987 C********************************************************************
15988 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15991 PARAMETER ( DELM = 0.005D0,
15995 C input/output channels
15997 COMMON /POINOU/ LI,LO
15998 C event debugging information
16000 PARAMETER (NMAXD=100)
16001 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16002 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16003 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16004 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16005 C internal rejection counters
16007 PARAMETER (NMXJ=60)
16008 CHARACTER*10 REJTIT
16010 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16011 C model switches and parameters
16013 INTEGER ISWMDL,IPAMDL
16014 DOUBLE PRECISION PARMDL
16015 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16017 C standard particle data interface
16020 PARAMETER (NMXHEP=4000)
16022 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16023 DOUBLE PRECISION PHEP,VHEP
16024 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16025 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16027 C extension to standard particle data interface (PHOJET specific)
16028 INTEGER IMPART,IPHIST,ICOLOR
16029 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16031 C color string configurations including collapsed strings and hadrons
16033 PARAMETER (MSTR=500)
16034 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16035 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16036 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16037 & NNCH(MSTR),IBHAD(MSTR),ISTR
16039 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16040 & PL(4,100),XMP(100),XML(100)
16042 DOUBLE PRECISION PYMASS
16047 IF(IMODE.GT.0) THEN
16049 I1 = JMOHEP(1,IMODE)
16050 I2 = ABS(JMOHEP(2,IMODE))
16051 C copy to local field
16056 PL(K,L) = PHEP(K,I)
16060 XML(L) = PYMASS(IDHEP(I))
16064 XMC = PHEP(5,IMODE)
16065 IF(IDEB(82).GE.20) THEN
16066 WRITE(LO,'(1X,A,I7,2I4)')
16067 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16070 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16075 C two parton configurations
16076 C -----------------------------------------
16080 IF((XM1+XM2).GE.XMC) THEN
16081 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16082 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16083 & IMODE,XM1,XM2,XMC
16086 C conversion possible
16087 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16089 IFAIL(36) = IFAIL(36)+1
16090 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16091 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16103 C multi parton configurations
16104 C ---------------------------------
16107 C random selection of string side to start with
16108 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16130 IF(ITER.GT.2) GOTO 230
16132 C conversion according to color flow method
16134 DO 210 II=K1,K2-KS,KS
16135 DO 215 IK=II+KS,K2,KS
16138 * IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16139 * & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16140 IF((ABS(XM1-XMP(II)).GT.DELM)
16141 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16142 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16144 IFAIL(36) = IFAIL(36)+1
16145 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16147 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16148 & KEVENT,IMODE,II,IK
16153 PL(KK,II) = PP1(KK)
16154 PL(KK,IK) = PP2(KK)
16167 IF(IFAI.NE.0) GOTO 300
16172 C conversion according to remainder method
16175 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16178 C conversion necessary
16181 PB2(K) = PHEP(K,IMODE)-PB1(K)
16183 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16184 IF(XM2.LT.0.D0) THEN
16185 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16187 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16188 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16192 IF((XM1+XM2).GE.XMC) THEN
16193 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16195 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16196 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16199 C conversion possible
16200 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16202 IFAIL(36) = IFAIL(36)+1
16203 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16204 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16208 C calculate Lorentz transformation
16209 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16211 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16212 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16217 C transform remaining partons
16220 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16235 C register transformed partons
16243 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16244 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16245 & ICOLOR(2,I),IPOS,1)
16249 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16250 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16251 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16253 I = IPHIST(1,IMODE)
16259 IF(IDEB(82).GE.20) THEN
16260 WRITE(LO,'(1X,A,I7,2I4)')
16261 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16264 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16267 WRITE(LO,'(1X,A,2I5)')
16268 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16274 IF(IDEB(82).GE.3) THEN
16275 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16276 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16277 & IFAI,IPAR,IMODE,XMC
16278 IF(IDEB(82).GE.5) THEN
16279 WRITE(LO,'(1X,A,I7,2I4)')
16280 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16281 & KEVENT,IMODE,IPAR
16283 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16290 ELSE IF(IMODE.EQ.-1) THEN
16294 ELSE IF(IMODE.EQ.-2) THEN
16300 CDECK ID>, PHO_STRING
16301 SUBROUTINE PHO_STRING(IMODE,IREJ)
16302 C********************************************************************
16304 C calculation of string combinatorics, Lorentz boosts and
16307 C - splitting of gluons
16308 C - strings will be built up from pairs of partons
16309 C according to their color labels
16310 C with IDHEP(..) = -1
16311 C - there can be other particles between to string partons
16312 C (these will be unchanged by string construction)
16313 C - string mass fine correction
16315 C input: IMODE 1 complete string processing
16316 C -1 initialization
16317 C -2 output of statistics
16320 C IREJ 1 combination of strings impossible
16321 C 0 successful combination
16322 C 50 rejection due to user cutoffs
16324 C********************************************************************
16325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16328 PARAMETER ( DEPS = 1.D-15,
16331 C input/output channels
16333 COMMON /POINOU/ LI,LO
16334 C event debugging information
16336 PARAMETER (NMAXD=100)
16337 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16338 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16339 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16340 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16341 C general process information
16342 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16343 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16344 C internal rejection counters
16346 PARAMETER (NMXJ=60)
16347 CHARACTER*10 REJTIT
16349 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16350 C model switches and parameters
16352 INTEGER ISWMDL,IPAMDL
16353 DOUBLE PRECISION PARMDL
16354 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16355 C hard cross sections and MC selection weights
16357 PARAMETER ( Max_pro_2 = 16 )
16358 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16359 & MH_acc_1,MH_acc_2
16360 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16361 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16362 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16363 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16364 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16365 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16367 C standard particle data interface
16370 PARAMETER (NMXHEP=4000)
16372 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16373 DOUBLE PRECISION PHEP,VHEP
16374 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16375 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16377 C extension to standard particle data interface (PHOJET specific)
16378 INTEGER IMPART,IPHIST,ICOLOR
16379 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16381 C color string configurations including collapsed strings and hadrons
16383 PARAMETER (MSTR=500)
16384 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16385 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16386 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16387 & NNCH(MSTR),IBHAD(MSTR),ISTR
16388 C table of particle indices for recursive PHOJET calls
16390 PARAMETER ( MAXIPX = 100 )
16391 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16392 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16393 & IPOIX1,IPOIX2,IPOIX3
16395 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16396 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16397 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16400 IF(IMODE.EQ.-1) THEN
16401 CALL PHO_POMCOR(-1)
16402 CALL PHO_MASCOR(-1)
16403 CALL PHO_PARCOR(-1,IREJ)
16406 ELSE IF(IMODE.EQ.-2) THEN
16407 CALL PHO_POMCOR(-2)
16408 CALL PHO_MASCOR(-2)
16409 CALL PHO_PARCOR(-2,IREJ)
16414 C generate enhanced graphs
16415 IF(IPOIX2.GT.0) THEN
16419 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16433 IF(IPORES(I).EQ.8) THEN
16439 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16440 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16441 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16443 IF(IDEB(4).GE.2) THEN
16444 WRITE(LO,'(/1X,A,I5)')
16445 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16446 CALL PHO_PREVNT(-1)
16450 KSPOM = KSPOMS+LSPOM
16451 KSREG = KSREGS+LSREG
16452 KHPOM = KHPOMS+LHPOM
16453 KHDIR = KHDIRS+LHDIR
16454 ELSE IF(IPORES(I).EQ.4) THEN
16457 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16460 IF(IDEB(4).GE.2) THEN
16461 WRITE(LO,'(/1X,A,I5)')
16462 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16463 CALL PHO_PREVNT(-1)
16468 KSPOM = KSPOMS+KSPOM
16469 KSREG = KSREGS+KSREG
16470 KHPOM = KHPOMS+KHPOM
16471 KHDIR = KHDIRS+KHDIR
16475 IF(IPORES(I).EQ.5) THEN
16478 ELSE IF(IPORES(I).EQ.6) THEN
16487 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16488 & 0,MSOFT,MHARD,IREJ)
16491 IF(IDEB(4).GE.2) THEN
16492 WRITE(LO,'(/1X,A,I5)')
16493 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16494 CALL PHO_PREVNT(-1)
16498 KSPOM = KSPOMS+KSPOM
16499 KSREG = KSREGS+KSREG
16500 KHPOM = KHPOMS+KHPOM
16501 KHDIR = KHDIRS+KHDIR
16507 IF(IPOIX2.GT.I2) THEN
16513 C optional: split gluons to q-qbar pairs
16514 IF(ISWMDL(9).GT.0) THEN
16517 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16523 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16525 IF(IQ1*IQ2.NE.0) GOTO 45
16526 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16528 IF(IQ1*IQ2.NE.0) GOTO 45
16531 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16532 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16535 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16537 IF(IDEB(19).GE.5) THEN
16538 WRITE(LO,'(/,1X,A)')
16539 & 'PHO_STRING: no gluon splitting possible'
16548 C construct strings and write entries sorted by strings
16554 IF(ISTR.GT.MSTR) THEN
16555 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16556 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16562 IF(ISTHEP(I).EQ.1) THEN
16563 C hadrons / resonances / clusters
16567 NPOS(4,ISTR) = abs(IPHIST(2,I))
16571 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16572 C quark /diquark terminated strings
16573 ICOL1 = -ICOLOR(1,I)
16578 ICH1 = IPHO_CHR3(I,2)
16579 IBA1 = IPHO_BAR3(I,2)
16580 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16581 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16582 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16588 IF(ISTHEP(K).EQ.-1)THEN
16589 IF(IDHEP(K).EQ.21) THEN
16590 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16591 ICOL1 = -ICOLOR(2,K)
16593 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16594 ICOL1 = -ICOLOR(1,K)
16597 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16603 WRITE(LO,'(/1X,A,I5)')
16604 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16611 NRPOM = MAX(NRPOM,IPHIST(1,K))
16612 ICH1 = ICH1+IPHO_CHR3(K,2)
16613 IBA1 = IBA1+IPHO_BAR3(K,2)
16614 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16615 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16616 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16617 C further parton involved?
16618 IF(ICOL1.NE.0) GOTO 65
16622 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16623 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16624 C store additional string information
16625 NPOS(1,ISTR) = IPOS
16627 NPOS(3,ISTR) = -JM2
16628 NPOS(4,ISTR) = abs(IPHIST(2,K))
16629 C calculate CPC string codes
16630 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16631 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16638 IF(ISTR.GT.MSTR) THEN
16639 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16640 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16646 IF(ISTHEP(I).EQ.-1) THEN
16647 C gluon loop-strings
16648 ICOL1 = -ICOLOR(1,I)
16655 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16656 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16657 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16662 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16664 IF(ISTHEP(K).EQ.-1)THEN
16665 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16666 ICOL1 = -ICOLOR(2,K)
16668 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16669 ICOL1 = -ICOLOR(1,K)
16674 WRITE(LO,'(/1X,A,I5)')
16675 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16682 NRPOM = MAX(NRPOM,IPHIST(1,K))
16683 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16684 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16685 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16686 C further parton involved?
16687 IF(ICOL1.NE.0) GOTO 165
16692 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16693 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16694 C store additional string information
16695 NPOS(1,ISTR) = IPOS
16697 NPOS(3,ISTR) = -JM2
16698 NPOS(4,ISTR) = abs(IPHIST(2,K))
16699 C calculate CPC string codes
16700 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16701 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16708 IF(IDEB(19).GE.17) THEN
16709 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16713 C pomeron corrections
16714 CALL PHO_POMCOR(IREJ)
16716 IFAIL(38) = IFAIL(38)+1
16717 IF(IDEB(19).GE.3) THEN
16718 WRITE(LO,'(1X,A,I6)')
16719 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16720 CALL PHO_PREVNT(-1)
16725 C string mass corrections
16726 CALL PHO_MASCOR(IREJ)
16728 IFAIL(34) = IFAIL(34)+1
16729 IF(IDEB(19).GE.3) THEN
16730 WRITE(LO,'(1X,A,I6)')
16731 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16732 CALL PHO_PREVNT(-1)
16737 C parton mass corrections
16739 IF(NCODE(I).GE.0) THEN
16740 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16742 IFAIL(35) = IFAIL(35)+1
16743 IF(IDEB(19).GE.3) THEN
16744 WRITE(LO,'(1X,A,I6)')
16745 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16746 CALL PHO_PREVNT(-1)
16753 C statistics of hard processes
16755 IF(ISTHEP(I).EQ.25) THEN
16758 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16762 C debug: write out strings
16763 IF(IDEB(19).GE.5) THEN
16765 & CALL PHO_CHECK(1,IDEV)
16766 IF(IDEB(19).GE.15) THEN
16775 CDECK ID>, PHO_STRFRA
16776 SUBROUTINE PHO_STRFRA(IREJ)
16777 C********************************************************************
16779 C do all fragmentation of strings
16781 C output: IREJ 0 successful
16783 C 50 rejection due to user cutoffs
16785 C********************************************************************
16791 C input/output channels
16793 COMMON /POINOU/ LI,LO
16795 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16796 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16797 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16798 C event debugging information
16800 PARAMETER (NMAXD=100)
16801 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16802 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16803 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16804 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16805 C general process information
16806 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16807 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16808 C model switches and parameters
16810 INTEGER ISWMDL,IPAMDL
16811 DOUBLE PRECISION PARMDL
16812 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16813 C global event kinematics and particle IDs
16814 INTEGER IFPAP,IFPAB
16815 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16816 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16818 C standard particle data interface
16821 PARAMETER (NMXHEP=4000)
16823 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16824 DOUBLE PRECISION PHEP,VHEP
16825 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16826 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16828 C extension to standard particle data interface (PHOJET specific)
16829 INTEGER IMPART,IPHIST,ICOLOR
16830 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16832 C color string configurations including collapsed strings and hadrons
16834 PARAMETER (MSTR=500)
16835 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16836 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16837 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16838 & NNCH(MSTR),IBHAD(MSTR),ISTR
16842 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16844 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16845 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16847 integer indx(500),indx_max
16849 DOUBLE PRECISION DT_RNDM
16850 INTEGER ipho_pdg2id
16851 EXTERNAL DT_RNDM,ipho_pdg2id
16853 DOUBLE PRECISION PYP,RQLUN
16857 DOUBLE PRECISION PARU,PARJ
16858 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16861 DOUBLE PRECISION P,V
16862 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16864 DIMENSION IJOIN(100)
16867 IF(ABS(ISWMDL(6)).GT.3) THEN
16868 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16869 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16873 C popcorn suppression
16874 IF(PARMDL(134).GT.0.D0) THEN
16875 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16882 C copy partons to fragmentation code JETSET
16888 C select partons with common production process
16890 if(IGEN.lt.0) goto 299
16894 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16896 C write final particles/resonances to JETSET
16897 IF(NCODE(I).EQ.-99) THEN
16900 P(IP,1) = PHEP(1,II)
16901 P(IP,2) = PHEP(2,II)
16902 P(IP,3) = PHEP(3,II)
16903 P(IP,4) = PHEP(4,II)
16904 P(IP,5) = PHEP(5,II)
16906 K(IP,2) = IDHEP(II)
16912 if(indx_max.eq.500) then
16913 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16914 & 'no space left in index vector (indx,Kevent)',
16920 indx_max = indx_max+1
16921 indx(indx_max) = II
16922 C write partons to JETSET
16923 ELSE IF(NCODE(I).GE.0) THEN
16924 K1 = JMOHEP(1,NPOS(1,I))
16925 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16929 P(IP,1) = PHEP(1,II)
16930 P(IP,2) = PHEP(2,II)
16931 P(IP,3) = PHEP(3,II)
16932 P(IP,4) = PHEP(4,II)
16933 P(IP,5) = PHEP(5,II)
16935 K(IP,2) = IDHEP(II)
16942 indx_max = indx_max+1
16943 indx(indx_max) = II
16946 II = JMOHEP(2,NPOS(1,I))
16947 IF((II.GT.0).AND.(II.NE.K1)) THEN
16949 P(IP,1) = PHEP(1,II)
16950 P(IP,2) = PHEP(2,II)
16951 P(IP,3) = PHEP(3,II)
16952 P(IP,4) = PHEP(4,II)
16953 P(IP,5) = PHEP(5,II)
16955 K(IP,2) = IDHEP(II)
16962 indx_max = indx_max+1
16963 indx(indx_max) = II
16967 C connect partons to strings
16969 CALL PYJOIN(IJ,IJOIN)
16973 NPOS(4,I) = -NPOS(4,I)
16979 if(IP.eq.0) goto 299
16981 C hard final state evolution
16982 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16984 do 125 k1=1,indx_max
16986 IF(IPHIST(1,I).LE.-100) THEN
16993 IF(IJOIN(K1).EQ.0) GOTO 130
16995 IF((IPAMDL(102).EQ.1)
16996 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16998 IF(IJOIN(K2).EQ.0) GOTO 135
17000 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
17001 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
17002 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
17003 RQLUN = MIN(PT1,PT2)
17005 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
17006 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
17007 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
17018 C fragment parton / hadron configuration (hadronization & decay)
17020 IF(ISWMDL(6).NE.0) THEN
17028 if(MSTU(28).ne.0) then
17029 IF(IDEB(22).GE.10) THEN
17030 WRITE(LO,'(1X,A,I12,I3)')
17031 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
17037 IF(MSTU(24).NE.0) THEN
17038 IF(IDEB(22).GE.2) THEN
17039 WRITE(LO,'(1X,A,I12,I3)')
17040 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17050 C change particle status in JETSET to avoid internal adjustments
17052 K(k1,1) = K(k1,1)+1000
17059 C restore original JETSET particle status codes
17061 K(i,1) = K(i,1)-1000
17064 * IF(IDEB(22).GE.25) THEN
17065 * WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17066 * & 'particle/string system before fragmentation'
17067 * CALL PHO_PREVNT(2)
17070 C copy hadrons back to POEVT1 / POEVT2
17077 C copy hadrons back with full history information
17078 IF(IPAMDL(178).EQ.1) THEN
17080 IF(NCODE(II).GE.0) THEN
17081 K1 = IPHIST(2,NPOS(2,II))
17082 K2 = IPHIST(2,-NPOS(3,II))
17083 ELSE IF(NCODE(II).EQ.-99) THEN
17084 K1 = IPHIST(2,NPOS(1,II))
17092 IF(PYK(J,7).EQ.1) THEN
17095 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17097 IBAM = ipho_pdg2id(PYK(J,8))
17099 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17100 IF(IDEB(22).GE.2) THEN
17101 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17102 & 'LUND interface (1) rejection'
17116 C register parton/hadron
17119 IF(ISWMDL(6).EQ.0) THEN
17122 IF(IDEB(22).GE.2) THEN
17123 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17124 & 'LUND interface (2) rejection'
17132 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17133 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17139 IF(IFOUND.EQ.0) THEN
17140 IF(IDEB(2).GE.2) THEN
17141 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17142 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17144 ISTHEP(NPOS(1,II)) = 2
17149 C copy hadrons back without history information
17150 JDAHEP(1,1) = NHEP1
17151 JDAHEP(1,2) = NHEP1
17154 IF(PYK(J,7).EQ.1) THEN
17155 IBAM = ipho_pdg2id(PYK(J,8))
17157 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17158 IF(IDEB(22).GE.2) THEN
17159 WRITE(LO,'(/1X,A)')
17160 & 'PHO_STRFRA: LUND interface (3) rejection'
17173 C register parton/hadron
17176 IF(ISWMDL(6).EQ.0) THEN
17179 IF(IDEB(22).GE.2) THEN
17180 WRITE(LO,'(/1X,A)')
17181 & 'PHO_STRFRA: LUND interface (4) rejection'
17189 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17190 & HE,J,0,0,0,IPOS,1)
17196 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17197 & ISTHEP(NPOS(1,II)) = 2
17202 C debug event status
17203 IF(IDEB(22).GE.15) THEN
17204 WRITE(LO,'(//1X,A)')
17205 & 'PHO_STRFRA: particle system after fragmentation'
17211 CDECK ID>, PHO_EVEINI
17212 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17213 C********************************************************************
17215 C prepare /POEVT1/ for new event
17217 C first subroutine called for each event
17219 C input: P1(4) particle 1
17221 C IMODE 0 general initialization
17222 C 1 initialization of particles and kinematics
17223 C 2 initialization after internal rejection
17225 C output: IP1,IP2 index of interacting particles
17227 C********************************************************************
17228 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17231 DIMENSION P1(4),P2(4)
17233 PARAMETER ( EPS = 1.D-5,
17236 C input/output channels
17238 COMMON /POINOU/ LI,LO
17239 C event debugging information
17241 PARAMETER (NMAXD=100)
17242 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17243 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17244 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17245 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17246 C model switches and parameters
17248 INTEGER ISWMDL,IPAMDL
17249 DOUBLE PRECISION PARMDL
17250 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17251 C general process information
17252 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17253 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17254 C gamma-lepton or gamma-hadron vertex information
17255 INTEGER IGHEL,IDPSRC,IDBSRC
17256 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17257 & RADSRC,AMSRC,GAMSRC
17258 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17259 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17260 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17261 C global event kinematics and particle IDs
17262 INTEGER IFPAP,IFPAB
17263 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17264 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17265 C energy-interpolation table
17267 PARAMETER ( IEETA2 = 20 )
17269 DOUBLE PRECISION SIGTAB,SIGECM
17270 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17272 INTEGER IPFIL,IFAFIL,IFBFIL
17273 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17274 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17275 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17276 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17277 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17278 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17279 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17280 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17281 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17282 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17283 & IPFIL,IFAFIL,IFBFIL
17284 C color string configurations including collapsed strings and hadrons
17286 PARAMETER (MSTR=500)
17287 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17288 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17289 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17290 & NNCH(MSTR),IBHAD(MSTR),ISTR
17292 C standard particle data interface
17295 PARAMETER (NMXHEP=4000)
17297 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17298 DOUBLE PRECISION PHEP,VHEP
17299 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17300 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17302 C extension to standard particle data interface (PHOJET specific)
17303 INTEGER IMPART,IPHIST,ICOLOR
17304 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17306 C table of particle indices for recursive PHOJET calls
17308 PARAMETER ( MAXIPX = 100 )
17309 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17310 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17311 & IPOIX1,IPOIX2,IPOIX3
17312 C event weights and generated cross section
17313 INTEGER IPOWGC,ISWCUT,IVWGHT
17314 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17315 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17316 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17320 C reset debug variables
17339 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17342 C reset /POEVT1/ and /POEVT2/
17343 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17345 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17350 C initialization of particle kinematics
17352 C lepton-photon/hadron-photon vertex and initial particles
17355 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17356 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17357 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17359 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17360 & P1(4),0,0,0,0,IP1,1)
17362 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17363 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17364 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17366 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17367 & P2(4),0,0,0,0,IP2,1)
17369 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17370 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17371 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17372 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17373 & P1(4),0,0,0,0,IP1,1)
17375 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17376 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17377 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17378 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17379 & P2(4),0,0,0,0,IP2,1)
17383 IF(IMODE.LE.1) THEN
17385 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17386 & -(P1(3)+P2(3))**2)
17387 * CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17388 PMASS(1) = PHEP(5,IP1)
17390 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17391 PMASS(2) = PHEP(5,IP2)
17393 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17396 C cross section calculations
17398 IF(IMODE.NE.1) THEN
17400 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17401 & ECM,PVIRT(1),PVIRT(2))
17404 IF(IMODE.LE.0) THEN
17405 C effective cross section
17407 IF(ISWMDL(2).ge.1) THEN
17408 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17409 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17411 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17412 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17413 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17414 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17415 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17416 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17417 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17418 C simulate only hard scatterings
17420 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17421 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17426 C reset of mother/daughter relations only (IMODE = 2)
17429 IF(IDEB(63).GE.15) THEN
17430 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17431 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17432 IF(IMODE.LE.0) THEN
17433 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17434 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17438 IDEB(57) = MAX(5,ITMP)
17439 CALL PHO_XSECT(1,0,ONEM)
17447 CDECK ID>, PHO_CSINT
17448 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17449 C********************************************************************
17451 C calculate cross sections by interpolation
17453 C input: IP particle combination
17454 C IFPA/B particle PDG number
17455 C IHLA/B particle helicity (photons only)
17456 C ECM c.m. energy (GeV)
17457 C PVIR2A virtuality of particle A (GeV**2, positive)
17458 C PVIR2B virtuality of particle B (GeV**2, positive)
17460 C output: cross sections stored in /POCSEC/
17462 C********************************************************************
17463 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17466 PARAMETER ( EPS = 1.D-5,
17469 C input/output channels
17471 COMMON /POINOU/ LI,LO
17473 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17474 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17475 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17476 C event debugging information
17478 PARAMETER (NMAXD=100)
17479 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17480 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17481 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17482 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17483 C model switches and parameters
17485 INTEGER ISWMDL,IPAMDL
17486 DOUBLE PRECISION PARMDL
17487 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17488 C energy-interpolation table
17490 PARAMETER ( IEETA2 = 20 )
17492 DOUBLE PRECISION SIGTAB,SIGECM
17493 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17495 INTEGER IPFIL,IFAFIL,IFBFIL
17496 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17497 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17498 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17499 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17500 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17501 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17502 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17503 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17504 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17505 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17506 & IPFIL,IFAFIL,IFBFIL
17507 C hard cross sections and MC selection weights
17509 PARAMETER ( Max_pro_2 = 16 )
17510 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17511 & MH_acc_1,MH_acc_2
17512 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17513 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17514 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17515 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17516 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17517 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17519 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17521 dimension PD(-6:6),FH_T(2),FH_L(2)
17524 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17525 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17526 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17528 C check currently stored cross sections
17529 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17530 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17531 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17532 C nothing to calculate
17534 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17538 C copy to local fields
17546 C load cross sections from interpolation table
17547 IF(ECM.LE.SIGECM(IP,1)) THEN
17550 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17552 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17558 WRITE(LO,'(/1X,A,2E12.3)')
17559 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17560 CALL PHO_PREVNT(-1)
17565 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17566 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17569 C cross section dependence on photon virtualities
17574 IF(IFPAP(K).EQ.22) THEN
17575 IF(ISWMDL(10).GE.1) THEN
17580 C GVDM factors for transverse/longitudinal photons
17582 FSUT(K) = FSUT(K)+PARMDL(26+I)
17583 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17585 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17586 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17588 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17590 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17592 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17593 C diffraction of trans. photons corresponds mainly to leading twist
17596 C longitudinal (scalar) part
17597 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17598 FSUP(K) = FSUP(K)+FSUL(K)
17599 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17600 C diffraction of long. photons corresponds mainly to higher twist
17601 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17602 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17603 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17606 if(ideb(15).ge.10) then
17607 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17608 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17609 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17615 FACP = FSUP(1)*FSUP(2)
17616 FACH = FSUH(1)*FSUH(2)
17617 FACD = FSUD(1)*FSUD(2)
17619 C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17621 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17622 & .and.(IPAMDL(117).gt.0)) then
17623 C check kinematic limit
17624 Q2_max = max(PVIRT(1),PVIRT(2))
17625 Q2_min = min(PVIRT(1),PVIRT(2))
17626 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17628 C calculate F2 from current parton density
17629 if(PVIRT(1).gt.PVIRT(2)) then
17636 X = Q2/(ECM**2+Q2+P2)
17637 call pho_actpdf(IFPAP(K),K)
17638 call pho_pdf(K,X,Q2,P2,PD)
17639 C light quark contribution
17642 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17644 C heavy quark contribution
17645 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17646 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17647 F2 = (F2_light+F2_c)
17649 C calculate model prediction
17650 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17651 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17652 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17654 if(ISWMDL(10).ge.2) then
17656 C calculate all helicity combinations
17657 if(IPAMDL(115).eq.0) then
17659 SIGSRH(1) = HSig(10)+HSig(11)
17660 SIGSRH(2) = HSig(12)+HSig(13)
17661 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17662 C photon helicity factors
17663 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17664 FH_L(1) = 1.D0-FH_T(1)
17665 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17666 FH_L(2) = 1.D0-FH_T(2)
17667 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17668 & + SIGDIH*FH_T(1)*FH_T(2)
17669 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17670 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17671 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17672 & + SIGDIH*FH_T(1)*FH_L(2)
17673 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17674 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17675 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17676 & + SIGDIH*FH_L(1)*FH_T(2)
17677 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17678 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17679 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17680 & + SIGDIH*FH_L(1)*FH_L(2)
17681 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17682 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17684 C use explicit PDF virtuality dependence (pre-tabulated)
17686 SIGSRH(1) = HSig(10)+HSig(11)
17687 SIGSRH(2) = HSig(12)+HSig(13)
17688 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17689 print LO,' PHO_CSINT: invalid option for F2 matching'
17691 * CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17692 * & Max_pro_2,3,4,1)
17693 * SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17694 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17695 * SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17696 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17697 * SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17698 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17699 * SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17700 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17702 Xnu = Ecm*Ecm+Q2+P2
17703 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17706 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17707 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17708 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17710 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17711 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17712 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17717 C assume sig_eff = sigtot
17719 SIGSRH(1) = HSig(10)+HSig(11)
17720 SIGSRH(2) = HSig(12)+HSig(13)
17721 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17722 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17723 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17724 Xnu = Ecm*Ecm+Q2+P2
17725 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17727 F2m = F2_fac*SIGeff
17728 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17730 * print LO,' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17731 * print LO,' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17733 C global factor to re-scale suppression of soft contributions
17734 Fcorr = (F2-F2m+F2s)/F2s
17735 * print LO,' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17741 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17742 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17743 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17748 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17753 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17754 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17755 C suppression of multi-pomeron graphs (diffraction)
17756 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17757 & *FACP*FSUP(2)*FSUD(1)
17758 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17759 & *FACP*FSUP(1)*FSUD(2)
17760 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17761 & *FACP*FSUP(2)*FSUD(1)
17762 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17763 & *FACP*FSUP(1)*FSUD(2)
17764 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17766 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17767 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17769 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17770 & *FACP*FSUP(2)*FSUD(1)
17771 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17772 & *FACP*FSUP(2)*FSUD(1)
17773 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17774 & *FACP*FSUP(1)*FSUD(2)
17775 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17776 & *FACP*FSUP(1)*FSUD(2)
17777 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17778 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17780 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17782 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17784 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17787 C corrections due to photon virtuality dependence of PDFs
17788 if(iswmdl(2).eq.1) then
17789 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17790 C minimum bias event generation
17791 IF(IPAMDL(115).GE.1) THEN
17792 C all the virtuality dependence is given by PDF parametrization
17793 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17794 IF(IPAMDL(116).GE.2) THEN
17795 C direct interaction according to full QPM calculation
17797 SIGSRH(1) = HSig(10)+HSig(11)
17798 SIGSRH(2) = HSig(12)+HSig(13)
17800 C direct interaction suppressed according to helicity factor
17801 SIGDIH = HSig(14)*FACH
17802 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17803 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17805 print LO,' PHO_CSINT: option not supported yet'
17808 C rescale relevant hard processes
17810 SIGSRH(1) = HSig(10)+HSig(11)
17811 SIGSRH(2) = HSig(12)+HSig(13)
17812 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17813 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17814 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17815 SIGINE = SIGtmp+SIGDIR
17816 SIGTOT = SIGINE+SIGELA
17819 C only hard interactions
17820 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17821 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17822 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17823 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17824 SIGHAR = HSig(9)*FACH
17827 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17828 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17829 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17834 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17837 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17838 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17848 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17854 CDECK ID>, PHO_PRIMKT
17855 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17856 C***********************************************************************
17858 C give primordial kt to partons entering hard scatterings and
17859 C remants connected to hard parton-parton interactions by color flow
17861 C input: IMODE -2 output of statistics
17862 C -1 initialization
17863 C 1 sampling of primordial kt
17864 C IF first entry in /POEVT1/ to check
17865 C IL last entry in /POEVT1/ to check
17866 C PTCUT current value of PTCUT to distinguish
17867 C between soft and hard
17869 C output: IREJ 0 success
17872 C***********************************************************************
17878 DOUBLE PRECISION DEPS
17879 PARAMETER ( DEPS = 1.D-15 )
17881 INTEGER IMODE,IF,IL,IREJ
17882 DOUBLE PRECISION PTCUT
17884 C input/output channels
17886 COMMON /POINOU/ LI,LO
17887 C event debugging information
17889 PARAMETER (NMAXD=100)
17890 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17891 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17892 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17893 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17894 C model switches and parameters
17896 INTEGER ISWMDL,IPAMDL
17897 DOUBLE PRECISION PARMDL
17898 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17900 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17901 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17902 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17903 C data of c.m. system of Pomeron / Reggeon exchange
17904 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17905 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17906 & SIDP,CODP,SIFP,COFP
17907 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17908 & SIDP,CODP,SIFP,COFP,NPOSP(2),
17909 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
17910 C hard scattering data
17912 PARAMETER ( MSCAHD = 50 )
17913 INTEGER LSCAHD,LSC1HD,LSIDX,
17914 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17915 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17916 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17917 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17918 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17919 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17920 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17921 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17922 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17924 C standard particle data interface
17927 PARAMETER (NMXHEP=4000)
17929 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17930 DOUBLE PRECISION PHEP,VHEP
17931 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17932 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17934 C extension to standard particle data interface (PHOJET specific)
17935 INTEGER IMPART,IPHIST,ICOLOR
17936 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17938 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17939 DIMENSION PTS(0:2,5),XP(5),
17940 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17942 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17944 PARAMETER (IRMAX=200)
17945 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17947 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17948 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17949 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17952 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17953 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17954 & IMODE,IF,IL,PTCUT
17956 C give primordial kt to partons engaged in a hard scattering
17958 IF(IMODE.EQ.1) THEN
17970 IF(ISTHEP(I).EQ.25) THEN
17971 C hard scattering number
17972 NHD = IPHIST(1,I+1)
17975 C calculate momenta of incoming partons
17976 POLD(1,1) = XHD(K,1)*ECMP/2.D0
17977 POLD(2,1) = POLD(1,1)
17978 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17979 POLD(2,2) = -POLD(1,2)
17988 C search for partons involved in hard interaction
17992 IF(ABS(ISTHEP(I)).EQ.1) THEN
17993 C hard scatterd partons (including ISR)
17994 IF((IPHIST(1,I).EQ.-NHD)
17995 & .OR.(IPHIST(1,I).EQ.NHD+1)
17996 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17999 IF(IROT.GT.IRMAX) THEN
18000 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
18001 & 'no memory left in IROTT, event rejected (max/IROT)',
18010 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
18011 IF(PHEP(3,I).GT.0.D0) THEN
18016 IBAL(J) = IBAL(J)+1
18017 IBALT(IBAL(J),J) = I
18018 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
18019 IF(ISWMDL(24).EQ.0) THEN
18021 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
18022 ELSE IF(ISWMDL(24).EQ.1) THEN
18023 IV2(IBAL(J),J) = -1
18028 C possibly further hard scattering
18029 ELSE IF(ISTHEP(I).EQ.25) THEN
18038 if(IDEB(10).ge.15) then
18039 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
18040 & 'hard scattering number: ',NHD/100
18041 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
18042 & 'number of entries to rotate: ',IROT
18044 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18045 & 'entries to rotate: ',I,IROTT(I)
18047 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18048 & 'number of entries to balance: ',IBAL
18051 WRITE(LO,'(1X,2A,I2,2I5)')
18052 & 'PHO_PRIMKT: entries to balance (side,no,line)',
18058 C incoming partons (comment lines), skip direct interacting particles
18060 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18061 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18066 IBAL(J) = IBAL(J)+1
18067 IBALT(IBAL(J),J) = -ICOM-K
18068 XP2(IBAL(J),J) = POLD(1,J)/ECMP
18069 IV2(IBAL(J),J) = -1
18073 C check consistency
18074 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18075 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18076 & 'inconsistent hard scattering remnant for event: ',KEVENT
18077 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18078 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18079 & IMODE,IF,IL,PTCUT
18080 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18082 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18086 WRITE(LO,'(1X,A,I2,2I5)')
18087 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18090 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18093 C calculate primordial kt
18096 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18098 C add transverse momentum (overwrite /POEVT1/ entries)
18100 IF(IBAL(J).GT.1) THEN
18101 C sample from truncated distribution
18108 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18109 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18110 C transform incoming partons of hard scattering
18111 DEL = ABS(POLD(1,J))+POLD(2,J)
18114 PNEW(1,J) = PTS(1,K)
18115 PNEW(2,J) = PTS(2,K)
18116 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18117 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18118 C spectator partons
18120 DO 220 I=1,IBAL(J)-1
18122 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18123 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18124 ESUM = ESUM+PHEP(4,K)
18126 C long. momentum transfer
18127 PP(3) = PNEW(3,J) - POLD(1,J)
18128 PP(4) = PNEW(4,J) - POLD(2,J)
18129 DO 230 I=1,IBAL(J)-1
18131 FAC = PHEP(4,K)/ESUM
18132 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18133 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18137 IF(IDEB(10).GE.15) THEN
18138 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18139 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18140 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18141 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18147 PNEW(3,J) = POLD(1,J)
18148 PNEW(4,J) = POLD(2,J)
18152 C transformation of hard scattering final states (including ISR)
18154 C old parton c.m. energy
18155 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18157 C new parton c.m. energy
18158 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18159 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18163 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18164 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18166 C calculate Lorentz transformation
18167 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18168 GAE = (POLD(2,1)+POLD(2,2))/EI
18170 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18172 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18173 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18174 PTOT = MAX(DEPS,PTOT)
18176 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18179 IF(PTOT*SID.GT.1.D-5) THEN
18180 COF=PP(1)/(SID*PTOT)
18181 SIF=PP(2)/(SID*PTOT)
18182 ANORF=SQRT(COF*COF+SIF*SIF)
18188 C check consistency initial/final configuration before rotation
18189 IF(IDEB(10).GE.25) THEN
18190 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18191 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18198 PP(J) = PP(J)+PHEP(J,K)
18201 WRITE(LO,'(1X,A,1P,4E11.3)')
18202 & 'PHO_PRIMKT: fin. momentum (1):',PP
18205 C apply rotation/boost to scattered particles
18209 PP(J) = FAC*PHEP(J,K)
18211 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18212 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18213 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18214 & COD,SID,COF,SIF,XX,YY,ZZ)
18216 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18217 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18221 C check consistency initial/final configuration after rotation
18222 IF(IDEB(10).GE.25) THEN
18224 PP(I) = PNEW(I,1)+PNEW(I,2)
18226 WRITE(LO,'(1X,A,1P,4E11.3)')
18227 & 'PHO_PRIMKT: ini. momentum (2):',PP
18234 PP(J) = PP(J)+PHEP(J,K)
18237 WRITE(LO,'(1X,A,1P,4E11.3)')
18238 & 'PHO_PRIMKT: fin. momentum (2):',PP
18243 IF(INEXT.EQ.1) GOTO 100
18247 ELSE IF(IMODE.EQ.-1) THEN
18249 C output of statistics etc.
18251 ELSE IF(IMODE.EQ.-2) THEN
18256 WRITE(LO,'(/1X,A,I4)')
18257 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18263 CDECK ID>, PHO_PARTPT
18264 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18265 C********************************************************************
18267 C assign to soft partons
18269 C input: IMODE -2 output of statistics
18270 C -1 initialization
18271 C 0 sampling of pt for soft partons belonging to
18273 C 1 sampling of pt for soft partons belonging to
18275 C IF first entry in /POEVT1/ to check
18276 C IL last entry in /POEVT1/ to check
18277 C PTCUT current value of PTCUT to distinguish
18278 C between soft and hard
18280 C output: IREJ 0 success
18283 C (soft pt is sampled by call to PHO_SOFTPT)
18285 C********************************************************************
18286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18289 PARAMETER ( DEPS = 1.D-15 )
18291 INTEGER IMODE,IF,IL,IREJ
18292 DOUBLE PRECISION PTCUT
18294 C input/output channels
18296 COMMON /POINOU/ LI,LO
18297 C event debugging information
18299 PARAMETER (NMAXD=100)
18300 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18301 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18302 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18303 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18304 C model switches and parameters
18306 INTEGER ISWMDL,IPAMDL
18307 DOUBLE PRECISION PARMDL
18308 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18310 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18311 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18312 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18313 C data of c.m. system of Pomeron / Reggeon exchange
18314 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18315 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18316 & SIDP,CODP,SIFP,COFP
18317 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18318 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18319 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18321 C standard particle data interface
18324 PARAMETER (NMXHEP=4000)
18326 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18327 DOUBLE PRECISION PHEP,VHEP
18328 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18329 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18331 C extension to standard particle data interface (PHOJET specific)
18332 INTEGER IMPART,IPHIST,ICOLOR
18333 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18335 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18336 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18338 INTEGER MODIFY,IV,IVB
18339 DIMENSION MODIFY(50),IV(50),IVB(2)
18342 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18343 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18344 & IMODE,IF,IL,PTCUT
18346 IF(IMODE.LT.0) GOTO 1000
18349 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18351 C count entries to modify
18360 IF(IMODE.EQ.0) THEN
18362 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18365 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18367 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18368 IF(PHEP(4,I).LT.EMIN) THEN
18375 C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18377 ELSE IF(IMODE.EQ.1) THEN
18380 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18381 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18384 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18385 IF(ISWMDL(24).EQ.0) THEN
18387 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18388 ELSE IF(ISWMDL(24).EQ.1) THEN
18393 IF(PHEP(4,I).LT.EMIN) THEN
18404 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18409 IF(IDEB(6).GE.5) THEN
18410 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18411 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18412 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18416 IF(IENTRY.LE.1) RETURN
18418 C sample pt of soft partons
18420 IF(ISWMDL(5).LE.1) THEN
18422 IPEAK = DT_RNDM(DUM)*IENTRY+1
18423 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18424 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18425 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18427 C energy limited sampling
18431 IF(ITER.GE.1000) THEN
18432 IF(IDEB(6).GE.3) THEN
18433 WRITE(LO,'(1X,A,3I5)')
18434 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18435 & IMODE,IENTRY,ITER
18436 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18440 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18441 & I,II,IV(I),XP(I),PHEP(4,II)
18443 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18450 PTMX = MIN(PHEP(4,II),PTCUT)
18453 IF(ISWMDL(5).EQ.0) THEN
18454 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18456 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18461 PSUMX = PSUMX+PB(1,1)
18462 PSUMY = PSUMY+PB(2,1)
18464 PTREM = SQRT(PSUMX**2+PSUMY**2)
18465 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18468 ELSE IF((ISWMDL(5).EQ.2)
18469 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18470 C unlimited sampling
18471 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18472 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18473 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18474 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18475 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18476 ELSE IF(ISWMDL(5).EQ.3) THEN
18477 C each string has balanced pt
18479 IF(IV(K).LE.-90) GOTO 499
18481 IC1 = -ICOLOR(1,I1)
18482 DO 510 L=K+1,IENTRY
18483 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18485 WRITE(LO,'(//1X,A,I5)')
18486 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18490 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18491 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18494 IVB(1) = MAX(IV(K),IV(L))
18496 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18499 PTS(1,L) = -PB(1,1)
18500 PTS(2,L) = -PB(2,1)
18501 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18502 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18505 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18506 PC(3) = SIGN(PLONG,PHEP(3,I1))
18508 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18509 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18513 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18514 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18520 WRITE(LO,'(/1X,A,I4)')
18521 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18525 C change partons in /POEVT1/
18527 IF(IV(II).GT.-90) THEN
18529 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18530 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18531 AMSQR = PHEP(4,I)**2
18532 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18533 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18538 IF(IDEB(6).GE.15) THEN
18539 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18540 & 'I II IV XP EP PTS PTX PTY',IPEAK
18543 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18544 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18550 C initialization / output of statistics
18552 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18556 CDECK ID>, PHO_SOFTPT
18557 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18558 C***********************************************************************
18560 C select pt of soft string ends
18562 C input: ISOFT number of soft partons
18563 C -1 initialization
18564 C >=0 sampling of p_t
18565 C -2 output of statistics
18566 C PTCUT cutoff for soft strings
18567 C PTMAX maximal allowed PT
18568 C XV field of x values
18572 C output: /POINT3/ containing parameters AAS,BETAS
18573 C PTSOF filed with soft pt values
18575 C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18576 C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18577 C ISWMDL(3/4) = 2 photon wave function
18578 C ISWMDL(3/4) = 10 no soft P_t assignment
18580 C***********************************************************************
18581 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18584 PARAMETER ( DEPS = 1.D-15)
18586 DIMENSION PTSOF(0:2,*),XV(*)
18589 C input/output channels
18591 COMMON /POINOU/ LI,LO
18592 C event debugging information
18594 PARAMETER (NMAXD=100)
18595 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18596 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18597 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18598 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18599 C model switches and parameters
18601 INTEGER ISWMDL,IPAMDL
18602 DOUBLE PRECISION PARMDL
18603 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18604 C data of c.m. system of Pomeron / Reggeon exchange
18605 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18606 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18607 & SIDP,CODP,SIFP,COFP
18608 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18609 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18610 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18611 C data on most recent hard scattering
18612 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18613 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18614 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18615 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18616 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18617 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18618 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18619 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18620 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18621 C data needed for soft-pt calculation
18622 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18623 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18625 DIMENSION BETAB(100)
18628 IF(ISOFT.GE.0) THEN
18629 CALLS = CALLS + 1.D0
18630 C sample according to model ISWMDL(3-6)
18631 IF(ISOFT.GT.1) THEN
18638 IF(IV(I).EQ.1) THEN
18640 C photon/pomeron valence part
18641 IF(IPAMDL(5).EQ.1) THEN
18642 IF(XV(I).GE.0.D0) THEN
18643 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18648 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18653 ELSE IF(IPAMDL(5).EQ.2) THEN
18655 ELSE IF(IPAMDL(5).EQ.3) THEN
18659 ELSE IF(IV(I).EQ.0) THEN
18661 C hard scattering remnant
18663 IF(IPAMDL(6).EQ.0) THEN
18665 ELSE IF(IPAMDL(6).EQ.1) THEN
18671 BETA = MAX(BETA,0.01D0)
18672 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18673 PTS = MIN(PTMAX,PTS)
18674 CALL PHO_SFECFE(SIG,COG)
18676 PTSOF(1,I) = COG*PTS
18677 PTSOF(2,I) = SIG*PTS
18678 PTXS = PTXS+PTSOF(1,I)
18679 PTYS = PTYS+PTSOF(2,I)
18682 C balancing of momenta
18683 PTS = SQRT(PTXS**2+PTYS**2)
18684 IF(PTS.GE.PTMAX) GOTO 210
18692 C single parton only
18696 IF(IV(1).EQ.1) THEN
18698 C photon/Pomeron valence part
18699 IF(IPAMDL(5).EQ.1) THEN
18700 IF(XV(1).GE.0.D0) THEN
18701 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18706 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18711 ELSE IF(IPAMDL(5).EQ.2) THEN
18713 ELSE IF(IPAMDL(5).EQ.3) THEN
18717 ELSE IF(IV(1).EQ.0) THEN
18719 C hard scattering remnant
18721 IF(IPAMDL(6).EQ.1) THEN
18727 BETA = MAX(BETA,0.01D0)
18728 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18729 PTS = MIN(PTMAX,PTS)
18730 CALL PHO_SFECFE(SIG,COG)
18732 PTSOF(1,1) = COG*PTS
18733 PTSOF(2,1) = SIG*PTS
18738 IF(IDEB(29).GE.10) THEN
18739 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18740 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18742 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18743 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18747 C initialization of statistics and parameters
18749 ELSE IF(ISOFT.EQ.-1) THEN
18753 IMODE = -100+ISWMDL(3)
18754 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18756 C output of statistics
18758 ELSE IF(ISOFT.EQ.-2) THEN
18761 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18762 & 'unsupported ISOFT ',ISOFT
18767 CDECK ID>, PHO_SELPT
18768 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18769 C***********************************************************************
18771 C select pt from different distributions
18773 C input: EE energy (for initialization only)
18774 C otherwise x value of corresponding parton
18775 C PTLOW lower pt limit
18776 C PTHIGH upper pt limit
18777 C (PTHIGH > 20 will cause DEXP underflows)
18779 C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18780 C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18781 C IMODE = 2 dNs/dP_t according photon wave function
18782 C IMODE = 10 no sampling
18784 C IMODE = -100+IMODE initialization according to
18785 C given limitations
18787 C output: PTS sampled pt value
18789 C BETA soft pt slope in central region
18791 C***********************************************************************
18792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18795 PARAMETER ( PI2 = 6.28318530718D0,
18800 C input/output channels
18802 COMMON /POINOU/ LI,LO
18803 C event debugging information
18805 PARAMETER (NMAXD=100)
18806 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18807 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18808 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18809 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18810 C model switches and parameters
18812 INTEGER ISWMDL,IPAMDL
18813 DOUBLE PRECISION PARMDL
18814 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18815 C data of c.m. system of Pomeron / Reggeon exchange
18816 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18817 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18818 & SIDP,CODP,SIFP,COFP
18819 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18820 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18821 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18822 C average number of cut soft and hard ladders (obsolete)
18823 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18824 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18825 C data needed for soft-pt calculation
18826 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18827 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18829 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18830 EXTERNAL PHO_CONN0,PHO_CONN1
18834 IF(IMODE.LT.0) GOTO 100
18841 IF(PX.LT.AMIN) RETURN
18843 IF((PX-PTLOW).LT.0.01) THEN
18844 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18845 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18849 C sampling of pt values according to IMODE
18851 IF(IMODE.EQ.0) THEN
18853 FAC1 = EXP(-BETA*PX**2)
18856 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18857 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18858 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18860 ELSE IF(IMODE.EQ.1) THEN
18862 XIMIN = EXP(-BETA*PTHIGH)
18865 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18866 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18867 IF(PTS.LT.XMT) GOTO 50
18868 PTS = SQRT(PTS**2-XMT2)
18869 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18871 ELSE IF(IMODE.EQ.2) THEN
18873 IF(EE.GE.0.D0) THEN
18879 AA = (1.D0-XV)*XV*P2+PARMDL(25)
18881 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18882 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18886 ELSE IF(IMODE.NE.10) THEN
18887 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18892 IF(IDEB(5).GE.20) THEN
18893 WRITE(LO,'(1X,A,I3,4E10.3)')
18894 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18895 & IMODE,BETA,PTLOW,PTHIGH,PTS
18904 C calculation of parameters
18908 C initialization for model 0 (gaussian pt distribution)
18911 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18914 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18915 IF(XTOL.LT.0.D0) THEN
18920 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18921 * IF(BETA.LT.-1.D+10) THEN
18922 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18923 * & '(model 0: Ecm,PTcut)',EE,PTCON
18924 * WRITE(LO,'(1X,A,1P,3E10.3)')
18925 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18926 * CALL PHO_PREVNT(-1)
18929 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18936 C initialization for model 1 (exponential pt distribution)
18938 ELSE IF(INIT.EQ.1) THEN
18941 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18944 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18945 IF(XTOL.LT.0.D0) THEN
18950 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18951 * IF(BETA.LT.-1.D+10) THEN
18952 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18953 * & '(model 1: Ecm,PTcut)',EE,PTCON
18954 * WRITE(LO,'(1X,A,1P,3E10.3)')
18955 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18956 * CALL PHO_PREVNT(-1)
18959 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18965 ELSE IF(INIT.EQ.10) THEN
18967 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18970 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18974 BETA = MIN(BETA,BETAS(1))
18976 C hard cross section is too big: neg. beta parameter
18977 IF(BETA.LE.0.D0) THEN
18978 WRITE(LO,'(1X,A,1P,2E12.3)')
18979 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18980 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18981 & SIGS,DSIGHP,SIGH,PTCON
18982 CALL PHO_PREVNT(-1)
18985 C output of initialization parameters
18986 IF(IDEB(5).GE.10) THEN
18987 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18989 WRITE(LO,'(5X,A,1P,2E13.3)')
18990 & 'BETA,AAS ',BETA,AAS
18991 WRITE(LO,'(5X,A,1P,3E13.3)')
18992 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18993 WRITE(LO,'(5X,A,1P,3E13.3)')
18994 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18999 CDECK ID>, PHO_CONN0
19000 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19001 C***********************************************************************
19003 C auxiliary function to determine parameters of soft
19004 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19006 C internal factors: FS number of soft partons in soft Pomeron
19007 C FH number of soft partons in hard Pomeron
19009 C***********************************************************************
19015 C input/output channels
19017 COMMON /POINOU/ LI,LO
19018 C average number of cut soft and hard ladders (obsolete)
19019 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19020 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19021 C data needed for soft-pt calculation
19022 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19023 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19025 DOUBLE PRECISION BETA,XX,FF
19028 IF(ABS(XX).LT.1.D-3) THEN
19029 FF = FS*SIGS+FH*SIGH
19030 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
19032 FF = FS*SIGS+FH*SIGH
19033 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
19037 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
19038 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19042 CDECK ID>, PHO_CONN1
19043 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19044 C***********************************************************************
19046 C auxiliary function to determine parameters of soft
19047 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19049 C internal factors: FS number of soft partons in soft Pomeron
19050 C FH number of soft partons in hard Pomeron
19052 C***********************************************************************
19058 C input/output channels
19060 COMMON /POINOU/ LI,LO
19061 C average number of cut soft and hard ladders (obsolete)
19062 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19063 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19064 C data needed for soft-pt calculation
19065 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19066 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19068 DOUBLE PRECISION BETA,XX,FF
19071 IF(ABS(XX).LT.1.D-3) THEN
19072 FF = FS*SIGS+FH*SIGH
19073 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19075 FF = FS*SIGS+FH*SIGH
19076 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19080 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19081 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19085 CDECK ID>, PHO_MSHELL
19086 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19087 C********************************************************************
19089 C rescaling of momenta of two partons to put both
19092 C input: PA1,PA2 input momentum vectors
19093 C XM1,2 desired masses of particles afterwards
19094 C P1,P2 changed momentum vectors
19096 C********************************************************************
19097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19100 PARAMETER ( DEPS = 1.D-20 )
19102 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19104 C input/output channels
19106 COMMON /POINOU/ LI,LO
19107 C event debugging information
19109 PARAMETER (NMAXD=100)
19110 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19111 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19112 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19113 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19114 C internal rejection counters
19116 PARAMETER (NMXJ=60)
19117 CHARACTER*10 REJTIT
19119 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19124 IF(IDEB(40).GE.10) THEN
19125 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19126 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19127 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19128 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19131 C Lorentz transformation into system CMS
19136 XMS = EE**2-PX**2-PY**2-PZ**2
19137 IF(XMS.LT.(XM1+XM2)**2) THEN
19139 IFAIL(37) = IFAIL(37)+1
19141 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19143 IF(IDEB(40).GE.3) THEN
19144 WRITE(LO,'(/1X,A,I12)')
19145 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19146 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19147 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19148 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19150 IF(IDEB(40).GE.3) GOTO 55
19159 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19160 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19162 PTOT1 = MAX(DEPS,PTOT1)
19164 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19167 IF(PTOT1*SID.GT.1.D-5) THEN
19168 COF = P1(1)/(SID*PTOT1)
19169 SIF = P1(2)/(SID*PTOT1)
19170 ANORF = SQRT(COF*COF+SIF*SIF)
19175 C new CM momentum and energies (for masses XM1,XM2)
19179 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19180 EE1 = SQRT(XM12+PCMP**2)
19183 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19184 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19185 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19186 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19187 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19189 C check consistency
19191 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19193 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19195 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19197 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19203 WRITE(LO,'(1X,A,I3)')
19204 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19205 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19206 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19207 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19208 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19209 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19210 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19211 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19212 ELSE IF(IDEB(40).GE.10) THEN
19213 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19214 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19215 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19219 CDECK ID>, PHO_GLU2QU
19220 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19221 C********************************************************************
19223 C split gluon with index I in POEVT1
19224 C (massless gluon assumed)
19228 C IQ1 first quark index
19229 C IQ2 second quark index
19231 C output: new quarks in /POEVT1/
19232 C IREJ 1 splitting impossible
19233 C 0 splitting successful
19235 C********************************************************************
19236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19239 PARAMETER ( DEPS = 1.D-15,
19242 C input/output channels
19244 COMMON /POINOU/ LI,LO
19245 C event debugging information
19247 PARAMETER (NMAXD=100)
19248 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19249 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19250 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19251 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19252 C model switches and parameters
19254 INTEGER ISWMDL,IPAMDL
19255 DOUBLE PRECISION PARMDL
19256 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19258 C standard particle data interface
19261 PARAMETER (NMXHEP=4000)
19263 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19264 DOUBLE PRECISION PHEP,VHEP
19265 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19266 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19268 C extension to standard particle data interface (PHOJET specific)
19269 INTEGER IMPART,IPHIST,ICOLOR
19270 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19272 C internal rejection counters
19274 PARAMETER (NMXJ=60)
19275 CHARACTER*10 REJTIT
19277 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19279 DIMENSION P1(4),P2(4)
19284 C calculate string masses max possible
19285 IF(ISWMDL(9).EQ.1) THEN
19286 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19287 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19288 IF(CMASS1.LT.CUTM) THEN
19289 IF(IDEB(73).GE.5) THEN
19290 WRITE(LO,'(1X,A,3I4,4E10.3)')
19291 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19293 IFAIL(33) = IFAIL(33) + 1
19297 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19298 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19299 IF(CMASS2.LT.CUTM) THEN
19300 IF(IDEB(73).GE.5) THEN
19301 WRITE(LO,'(1X,A,3I4,4E10.3)')
19302 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19304 IFAIL(33) = IFAIL(33) + 1
19309 C calculate minimal z
19310 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19311 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19312 ZMIN = MIN(ZMIN1,ZMIN2)
19313 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19314 IF(IDEB(73).GE.5) THEN
19315 WRITE(LO,'(1X,A,3I3,4E10.3)')
19316 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19317 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19319 IFAIL(33) = IFAIL(33) + 1
19324 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19327 ZFRAC = PHO_GLUSPL(ZMIN)
19328 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19332 P1(I) = PHEP(I,IG)*ZFRAC
19333 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19336 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19337 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19338 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19339 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19341 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19342 K = SIGN(ABS(K),IDHEP(IQ1))
19344 K = -SIGN(ABS(K),IDHEP(IQ1))
19348 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19349 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19351 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19352 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19354 C register new partons
19355 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19356 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19357 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19358 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19360 IF(IDEB(73).GE.20) THEN
19361 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19362 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19363 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19364 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19369 CDECK ID>, PHO_GLUSPL
19370 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19371 C*********************************************************************
19373 C calculate quark - antiquark light cone momentum fractions
19374 C according to Altarelli-Parisi g->q aq splitting function
19375 C (symmetric z interval assumed)
19377 C input: ZMIN minimal Z value allowed,
19378 C 1-ZMIN maximal Z value allowed
19380 C********************************************************************
19381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19384 PARAMETER ( ALEXP= 0.3333333333D0,
19387 C input/output channels
19389 COMMON /POINOU/ LI,LO
19390 C event debugging information
19392 PARAMETER (NMAXD=100)
19393 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19394 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19395 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19396 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19398 IF(ZMIN.GE.0.5D0) THEN
19399 IF(IDEB(69).GT.2) THEN
19400 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19404 ELSE IF(ZMIN.LE.0.D0) THEN
19405 IF(IDEB(69).GT.2) THEN
19406 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19415 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19416 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19419 IF(IDEB(69).GE.10) THEN
19420 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19425 CDECK ID>, PHO_STDPAR
19426 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19427 C***********************************************************************
19429 C select the initial parton x-fractions and flavors and
19430 C the final parton momenta and flavours
19431 C for standard Pomeron/Reggeon cuts
19433 C input: IJM1 index of mother particle 1 in /POEVT1/
19434 C IJM2 index of mother particle 2 in /POEVT1/
19435 C IGEN production process of mother particles
19436 C MSPOM soft cut Pomerons
19437 C MHPOM hard or semihard cut Pomerons
19438 C MSREG soft cut Reggeons
19439 C MHDIR direct hard processes
19441 C IJM1 -1 initialization of statistics
19442 C -2 output of statistics
19444 C output: partons are directly written to /POEVT1/,/POEVT2/
19446 C structure of /POSOFT/
19447 C XS1(I),XS2(I): x-values of initial partons
19448 C IJSI1(I),IJSI2(I): flavor of initial parton
19451 C negative antiquarks
19452 C IJSF1(I),IJSF2(I): flavor of final state partons
19453 C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19459 C***********************************************************************
19460 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19463 PARAMETER (RHOMAS = 0.766D0,
19467 C input/output channels
19469 COMMON /POINOU/ LI,LO
19470 C event debugging information
19472 PARAMETER (NMAXD=100)
19473 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19474 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19475 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19476 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19477 C model switches and parameters
19479 INTEGER ISWMDL,IPAMDL
19480 DOUBLE PRECISION PARMDL
19481 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19483 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19484 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19485 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19486 C general process information
19487 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19488 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19489 C global event kinematics and particle IDs
19490 INTEGER IFPAP,IFPAB
19491 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19492 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19493 C data of c.m. system of Pomeron / Reggeon exchange
19494 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19495 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19496 & SIDP,CODP,SIFP,COFP
19497 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19498 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19499 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19500 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19501 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19502 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19503 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19504 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19505 C obsolete cut-off information
19506 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19507 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19508 C currently activated parton density parametrizations
19510 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19511 DOUBLE PRECISION PDFLAM,PDFQ2M
19512 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19513 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19514 C hard scattering parameters used for most recent hard interaction
19516 DOUBLE PRECISION ALQCD2,BQCD
19517 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19518 C particles created by initial state evolution
19519 INTEGER MXISR1,MXISR2
19520 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19521 INTEGER IFLISR,IPOISR,IMXISR
19522 DOUBLE PRECISION PHISR
19523 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19524 & IPOISR(2,2,MXISR2),IMXISR(2)
19525 C light-cone x fractions and c.m. momenta of soft cut string ends
19527 PARAMETER ( MAXSOF = 50 )
19528 INTEGER IJSI2,IJSI1
19529 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19530 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19531 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19532 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19533 C table of particle indices for recursive PHOJET calls
19535 PARAMETER ( MAXIPX = 100 )
19536 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19537 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19538 & IPOIX1,IPOIX2,IPOIX3
19539 C hard scattering data
19541 PARAMETER ( MSCAHD = 50 )
19542 INTEGER LSCAHD,LSC1HD,LSIDX,
19543 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19544 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19545 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19546 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19547 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19548 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19549 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19550 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19551 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19553 C standard particle data interface
19556 PARAMETER (NMXHEP=4000)
19558 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19559 DOUBLE PRECISION PHEP,VHEP
19560 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19561 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19563 C extension to standard particle data interface (PHOJET specific)
19564 INTEGER IMPART,IPHIST,ICOLOR
19565 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19567 C internal rejection counters
19569 PARAMETER (NMXJ=60)
19570 CHARACTER*10 REJTIT
19572 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19573 C internal cross check information on hard scattering limits
19574 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19575 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19576 C hard cross sections and MC selection weights
19578 PARAMETER ( Max_pro_2 = 16 )
19579 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19580 & MH_acc_1,MH_acc_2
19581 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19582 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19583 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19584 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19585 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19586 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19588 double precision pho_alphas
19590 DIMENSION PC(4),IFLA(2),ICI(2,2)
19592 IF(IJM1.EQ.-1) THEN
19595 ETAMA(1,I) = -1.D10
19597 ETAMA(2,I) = -1.D10
19603 CALL PHO_HARSCA(IJM1,1)
19604 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19608 ELSE IF(IJM1.EQ.-2) THEN
19610 C output internal statistics
19611 IF(IDEB(23).GE.1) THEN
19612 WRITE(LO,'(/1X,A)')
19613 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19615 WRITE(LO,'(5X,I3,4E13.5)')
19616 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19619 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19621 WRITE(LO,'(5X,I3,4E13.5)')
19622 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19625 CALL PHO_HARSCA(IJM1,1)
19626 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19633 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19634 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19636 C get mother data (exchange if first particle is a pomeron)
19637 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19647 IDPDG1 = IDHEP(JM1)
19648 IDBAM1 = IMPART(JM1)
19649 IDPDG2 = IDHEP(JM2)
19650 IDBAM2 = IMPART(JM2)
19652 C store current status of /POEVT1/
19661 C get nominal masses (photons: VDM assumption)
19663 IF(IDHEP(JM1).EQ.22) THEN
19664 PMASSP(1) = RHOMAS+DELMAS
19665 PVIRTP(1) = PHEP(5,JM1)**2
19667 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19670 IF(IDHEP(JM2).EQ.22) THEN
19671 PMASSP(2) = RHOMAS+DELMAS
19672 PVIRTP(2) = PHEP(5,JM2)**2
19674 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19678 C calculate c.m. energy and check kinematics
19679 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19680 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19681 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19682 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19683 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19685 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19686 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19687 & 'energy smaller than two-particle threshold (event rejected)'
19694 IF(IDEB(23).GE.5) THEN
19695 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19696 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19697 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19700 C Lorentz transformation into c.m. system
19702 GAMBEP(I) = PC(I)/ECMP
19704 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19705 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19706 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19707 C rotation angle: particle 1 moves along +z
19709 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19712 IF(PTOT1*SIDP.GT.1.D-5) THEN
19713 COFP = PC(1)/(SIDP*PTOT1)
19714 SIFP = PC(2)/(SIDP*PTOT1)
19715 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19720 XM12 = PMASSP(1)**2
19721 XM22 = PMASSP(2)**2
19722 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19724 C find particle combination
19726 IF(IDPDG2.EQ.IFPAP(2)) THEN
19727 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19728 ELSE IF(IDPDG2.EQ.990) THEN
19729 IF(IDPDG1.EQ.IFPAP(1)) THEN
19731 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19733 ELSE IF(IDPDG1.EQ.990) THEN
19738 IF(ISWMDL(14).GT.0) THEN
19741 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19742 & 'invalid particle combination:',IDPDG1,IDPDG2
19747 C select parton distribution functions from tables
19748 IF((MHPOM+MHDIR).GT.0) THEN
19749 CALL PHO_ACTPDF(IDPDG1,1)
19750 CALL PHO_ACTPDF(IDPDG2,2)
19751 C initialize alpha_s calculation
19752 DUMMY = PHO_ALPHAS(0.D0,-4)
19755 C interpolate hard cross sections and rejection weights
19756 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19757 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19761 C position of first particle added to /POEVT2/
19764 C ---------------- direct processes -----------------
19766 IF(MHDIR.EQ.1) THEN
19767 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19768 IF(IREJ.EQ.50) RETURN
19769 IF(IREJ.NE.0) GOTO 150
19770 C write comments to /POEVT1/
19771 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19772 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19773 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19774 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19775 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19776 & ICA1,ICA2,IPOS,1)
19777 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19778 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19779 & ICA1,ICA2,IPOS,1)
19780 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19781 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19783 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19784 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19787 C soft spectator partons
19795 C single resolved: QCD compton scattering
19796 C ------------------------------
19797 IF(NPROHD(1).EQ.10) THEN
19798 C register hadron remnant
19799 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19800 IPDF2 = 1000*IGRP(2)+ISET(2)
19801 ELSE IF(NPROHD(1).EQ.12) THEN
19802 C register hadron remnant
19803 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19804 IPDF1 = 1000*IGRP(1)+ISET(1)
19806 C single resolved: photon gluon fusion
19807 C ---------------------------
19808 ELSE IF(NPROHD(1).EQ.11) THEN
19809 C register hadron remnant
19810 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19811 IPDF2 = 1000*IGRP(2)+ISET(2)
19812 ELSE IF(NPROHD(1).EQ.13) THEN
19813 C register hadron remnant
19814 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19815 IPDF1 = 1000*IGRP(1)+ISET(1)
19817 C direct process (no remnant)
19818 C ----------------------------
19819 ELSE IF(NPROHD(1).EQ.14) THEN
19823 C write final high-pt partons to POEVT1
19824 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19830 IFLA(1) = NINHD(I,1)
19831 IFLA(2) = NINHD(I,2)
19832 C initial state radiation
19834 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19837 IFLB = IFLISR(K,IPA)
19838 IF(ABS(IFLB).LE.6) THEN
19840 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19842 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19843 & ICI(K,1),ICI(K,2),3)
19844 ELSE IF(IFLB.GT.0) THEN
19845 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19846 & ICI(K,1),ICI(K,2),4)
19848 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19852 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19853 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19854 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19860 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19863 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19864 & ICI(K,1),ICI(K,2),2)
19867 IIFL = IPHO_CNV1(IFLB)
19869 IFLA(K) = IFLA(K)-IFLB
19878 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19879 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19880 & IGEN,IC1,IC2,IPOS,1)
19883 ICOLOR(1,IPOS1-2) = ICI(1,1)
19884 ICOLOR(2,IPOS1-2) = ICI(1,2)
19885 ICOLOR(1,IPOS1-1) = ICI(2,1)
19886 ICOLOR(2,IPOS1-1) = ICI(2,2)
19887 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19888 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19889 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
19890 ICOLOR(1,IPOS1) = ICI(1,1)
19891 ICOLOR(2,IPOS1) = ICI(1,2)
19892 ICOLOR(1,IPOS2) = ICI(2,1)
19893 ICOLOR(2,IPOS2) = ICI(2,2)
19895 IPA = IPOISR(K,1,I)
19896 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19897 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19898 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19901 ICOLOR(1,IPOS1-2) = ICA1
19902 ICOLOR(2,IPOS1-2) = ICA2
19903 ICOLOR(1,IPOS1-1) = ICB1
19904 ICOLOR(2,IPOS1-1) = ICB2
19905 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19906 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19907 & NOUTHD(1,2),ICB1,ICB2)
19908 ICOLOR(1,IPOS1) = ICA1
19909 ICOLOR(2,IPOS1) = ICA2
19910 ICOLOR(1,IPOS2) = ICB1
19911 ICOLOR(2,IPOS2) = ICB2
19913 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19914 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19915 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19916 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19917 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19920 C assign soft pt to spectators
19921 IF(ISWMDL(18).EQ.0) THEN
19923 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19925 IFAIL(26) = IFAIL(26) + 1
19931 C ----------------- resolved processes -------------------
19933 C single Reggeon exchange
19934 C ----------------------------
19935 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19937 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19939 IFAIL(24) = IFAIL(24)+1
19944 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19945 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19946 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19947 CALL PHO_SWAPI(ICA1,ICB1)
19953 C DPMJET call with special projectile / target
19954 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19955 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19956 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19957 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19958 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19959 C default treatment
19961 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19962 & -1,IGEN,ICA1,0,IPOS1,1)
19963 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19964 & -1,IGEN,ICB1,0,IPOS2,1)
19967 C soft pt assignment
19968 IF(ISWMDL(18).EQ.0) THEN
19969 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19971 IFAIL(25) = IFAIL(25) + 1
19976 C multi Reggeon / Pomeron exchange
19977 C----------------------------------------
19979 C parton configuration
19981 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19982 & MHPAR1,MHPAR2,IREJ)
19984 IF(IREJ.EQ.50) RETURN
19985 IF(IREJ.NE.0) GOTO 150
19987 C register particles
19988 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19989 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19990 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19992 C register soft partons
19993 IF(IVAL1.NE.0) THEN
19994 IF(IVAL1.LT.0) THEN
20000 ELSE IF(MSPOM.EQ.0) THEN
20005 IF(IVAL2.NE.0) THEN
20006 IF(IVAL2.LT.0) THEN
20012 ELSE IF(MSPOM.EQ.0) THEN
20018 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
20019 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
20021 C soft Pomeron final states
20022 C -----------------------------------
20023 K = MSPOM+MHPOM+MSREG
20026 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
20028 IFAIL(8) = IFAIL(8) + 1
20034 C soft Reggeon final states
20035 C -----------------------------------------
20038 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
20039 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
20040 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
20042 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
20046 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20047 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
20048 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
20049 & CALL PHO_SWAPI(ICA1,ICB1)
20051 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
20052 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
20053 & I,IGEN,ICA1,ICA2,IPOS1,1)
20055 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
20056 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20057 & I,IGEN,ICB1,ICB2,IPOS2,1)
20060 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20061 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20062 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20064 C soft pt assignment
20065 IF(ISWMDL(18).EQ.0) THEN
20066 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20068 IFAIL(25) = IFAIL(25) + 1
20075 C hard Pomeron final states
20076 C ------------------------------------
20083 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20084 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20085 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20086 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20088 C write comments to /POEVT1/
20089 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20090 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20091 & IFLO1,IFLO2,IPOS,1)
20093 IPDF = 1000*IGRP(1)+ISET(1)
20094 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20095 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20096 & ICA1,ICA2,IPOS,1)
20097 IPDF = 1000*IGRP(2)+ISET(2)
20098 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20099 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20100 & ICB1,ICB2,IPOS,1)
20102 IPDF = 1000*IGRP(1)+ISET(1)
20103 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20104 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20105 & ICA1,ICA2,IPOS1,1)
20106 IPDF = 1000*IGRP(2)+ISET(2)
20107 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20108 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20109 & ICB1,ICB2,IPOS2,1)
20111 C spectator partons belonging to hard interaction
20112 IF(IVAL1.EQ.I) THEN
20115 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20122 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20123 IF(IVQ.LT.0) IND1 = IND1-IUSED
20124 IF(IVAL2.EQ.I) THEN
20127 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20134 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20135 IF(IVQ.LT.0) IND2 = IND2-IUSED
20137 C register hard scattered partons
20138 IF((ISWMDL(8).GE.2)
20139 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20144 IFLA(1) = NINHD(I,1)
20145 IFLA(2) = NINHD(I,2)
20146 C initial state radiation
20148 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20151 IFLB = IFLISR(K,IPA)
20152 IF(ABS(IFLB).LE.6) THEN
20154 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20156 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20157 & ICI(K,1),ICI(K,2),3)
20158 ELSE IF(IFLB.GT.0) THEN
20159 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20160 & ICI(K,1),ICI(K,2),4)
20162 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20163 & ICI(K,2),IC1,IC2,4)
20166 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20167 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20168 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20174 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20175 & ICI(K,2),IC1,IC2,2)
20177 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20178 & ICI(K,1),ICI(K,2),2)
20181 IIFL = IPHO_CNV1(IFLB)
20183 IFLA(K) = IFLA(K)-IFLB
20192 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20193 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20194 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20197 ICOLOR(1,IPOS1-2) = ICI(1,1)
20198 ICOLOR(2,IPOS1-2) = ICI(1,2)
20199 ICOLOR(1,IPOS1-1) = ICI(2,1)
20200 ICOLOR(2,IPOS1-1) = ICI(2,2)
20201 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20202 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20203 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20204 ICOLOR(1,IPOS1) = ICI(1,1)
20205 ICOLOR(2,IPOS1) = ICI(1,2)
20206 ICOLOR(1,IPOS2) = ICI(2,1)
20207 ICOLOR(2,IPOS2) = ICI(2,2)
20209 IPA = IPOISR(K,1,I)
20210 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20211 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20212 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20215 ICOLOR(1,IPOS1-2) = ICA1
20216 ICOLOR(2,IPOS1-2) = ICA2
20217 ICOLOR(1,IPOS1-1) = ICB1
20218 ICOLOR(2,IPOS1-1) = ICB2
20219 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20220 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20221 & NOUTHD(I,2),ICB1,ICB2)
20222 ICOLOR(1,IPOS1) = ICA1
20223 ICOLOR(2,IPOS1) = ICA2
20224 ICOLOR(1,IPOS2) = ICB1
20225 ICOLOR(2,IPOS2) = ICB2
20227 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20228 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20229 & ICA1,ICA2,IPOS,1)
20230 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20231 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20232 & ICB1,ICB2,IPOS,1)
20235 C end of resolved parton registration
20238 IF(MHDIR+MHPOM.GT.0) THEN
20240 IF(ISWMDL(29).GE.1) THEN
20241 C primordial kt of hard scattering
20242 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20244 IFAIL(27) = IFAIL(27)+1
20247 ELSE IF(ISWMDL(24).GE.0) THEN
20248 C give "soft" pt only to soft (spectator) partons in hard processes
20249 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20251 IFAIL(26) = IFAIL(26)+1
20258 C give "soft" pt to partons in soft Pomerons
20259 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20260 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20262 IFAIL(25) = IFAIL(25) + 1
20267 C boost back to lab frame
20268 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20269 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20272 C rejection treatment
20274 IFAIL(2) = IFAIL(2)+1
20280 C reset mother-daugther relations
20291 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20292 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20293 & MSPOM,MHPOM,MSREG,MHDIR
20298 CDECK ID>, PHO_HARCOL
20299 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20300 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20301 C*********************************************************************
20303 C calculate color flow for hard resolved process
20305 C input: IP1..4 flavour of partons (PDG convention)
20306 C V parton subprocess Mandelstam variable V = t/s
20307 C (lightcone momenta assumed)
20308 C ICA,ICB color labels
20309 C MSPR process number
20310 C -1 initialization of statistics
20311 C -2 output of statistics
20313 C output: ICC,ICD color label of final partons
20315 C (it is possible to use the same variables for in and output)
20317 C**********************************************************************
20318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20321 C input/output channels
20323 COMMON /POINOU/ LI,LO
20324 C event debugging information
20326 PARAMETER (NMAXD=100)
20327 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20328 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20329 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20330 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20331 C model switches and parameters
20333 INTEGER ISWMDL,IPAMDL
20334 DOUBLE PRECISION PARMDL
20335 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20336 C names of hard scattering processes
20338 PARAMETER ( Max_pro_1 = 16 )
20340 COMMON /POHPRO/ PROC(0:Max_pro_1)
20342 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20345 IF(MSPR.EQ.-1) THEN
20354 C output of statistics
20355 ELSE IF(MSPR.EQ.-2) THEN
20356 IF(IDEB(26).LT.1) RETURN
20357 WRITE(LO,'(/1X,A,/1X,A)')
20358 & 'PHO_HARCOL: sampled color configurations',
20359 & '----------------------------------------'
20360 WRITE(LO,'(6X,A,15X,A)')
20361 & 'diagram color configurations (1-4)','sum'
20364 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20366 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20368 IF(ISWMDL(11).GE.2) THEN
20369 WRITE(LO,'(/6X,A)')
20370 & 'diagram with / without color re-connection'
20372 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20378 C gluons: first color positive, quarks second color zero
20401 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20402 & 'PHO_HARCOL: process',MSPR,
20403 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20406 IF(IPAMDL(21).EQ.1) THEN
20408 C soft color re-connection option
20411 C hard g g final state, only g g --> g g
20412 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20413 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20418 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20423 ELSE IF(MSPR.EQ.3) THEN
20424 C hard q g final state
20425 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20426 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20431 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20436 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20437 C hard q q final state
20438 IF(ICA1.NE.-ICB1) THEN
20439 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20444 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20450 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20453 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20455 C large Nc limit of all graphs
20459 IF(DT_RNDM(V).GT.0.5D0) THEN
20464 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20470 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20472 ELSE IF(MSPR.EQ.2) THEN
20474 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20480 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20486 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20488 ELSE IF(MSPR.EQ.3) THEN
20490 IF(DT_RNDM(V).LT.0.5D0) THEN
20491 IF(IP1+IP2.GT.0) THEN
20496 ELSE IF(IP1.LT.0) THEN
20505 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20508 CALL PHO_HARCOR(-ICA1,ICB2)
20512 ELSE IF(IP2.GT.0) THEN
20513 CALL PHO_HARCOR(-ICB1,ICA2)
20517 ELSE IF(IP1.LT.0) THEN
20518 CALL PHO_HARCOR(-ICA1,ICB1)
20522 ELSE IF(IP2.LT.0) THEN
20523 CALL PHO_HARCOR(-ICB1,ICA1)
20528 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20530 ELSE IF(MSPR.EQ.4) THEN
20534 CALL PHO_HARCOR(-ICB1,ICA2)
20535 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20536 IF(IP3*IC1.LT.0) THEN
20541 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20542 ELSE IF(MSPR.EQ.5) THEN
20544 IF(DT_RNDM(V).LT.0.5D0) THEN
20545 IF(ICA1*IP3.LT.0) THEN
20552 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20554 IF(ICA1*IP3.LT.0) THEN
20561 CALL PHO_HARCOR(-ICA1,ICB1)
20562 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20564 ELSE IF(MSPR.EQ.6) THEN
20566 IF(ICA1*IP3.LT.0) THEN
20569 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20573 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20575 ELSE IF(MSPR.EQ.7) THEN
20577 IF(DT_RNDM(V).LT.0.5D0) THEN
20580 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20584 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20586 ELSE IF(MSPR.EQ.8) THEN
20588 IF(IP1*IP2.GT.0) THEN
20589 IF(IP3.EQ.IP1) THEN
20596 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20598 IF(ICA1*IP3.LT.0) THEN
20605 CALL PHO_HARCOR(-ICA1,ICB1)
20606 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20610 WRITE(LO,'(/1X,A,I3)')
20611 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20617 C color flow according to QCD leading order matrix element
20622 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20623 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20624 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20625 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20629 IF(XI.LT.PCS) GOTO 120
20633 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20634 IF(DT_RNDM(V).GT.0.5D0) THEN
20639 CALL PHO_HARCOR(-ICB2,ICA1)
20640 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20646 CALL PHO_HARCOR(-ICB1,ICA2)
20647 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20649 ELSE IF(I.EQ.2) THEN
20650 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20651 IF(DT_RNDM(U).GT.0.5D0) THEN
20656 CALL PHO_HARCOR(-ICB2,ICA1)
20657 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20663 CALL PHO_HARCOR(-ICB1,ICA2)
20664 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20667 IF(DT_RNDM(V).GT.0.5D0) THEN
20679 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20680 ELSE IF(MSPR.EQ.2) THEN
20682 PC(1) = U/V-2.D0*U**2
20683 PC(2) = V/U-2.D0*V**2
20684 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20685 XI = (PC(1)+PC(2))*DT_RNDM(U)
20686 IF(XI.LT.PC(1)) THEN
20692 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20698 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20706 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20712 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20715 ELSE IF(MSPR.EQ.3) THEN
20717 PC(1) = 2.D0*(U/V)**2-U
20718 PC(2) = 2.D0/V**2-1.D0/U
20719 XI = (PC(1)+PC(2))*DT_RNDM(V)
20720 IF(XI.LT.PC(1)) THEN
20721 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20726 CALL PHO_HARCOR(-ICA1,ICB2)
20727 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20728 ELSE IF(IP1.LT.0) THEN
20732 CALL PHO_HARCOR(-ICA1,ICB1)
20733 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20734 ELSE IF(IP2.GT.0) THEN
20738 CALL PHO_HARCOR(-ICB1,ICA2)
20739 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20744 CALL PHO_HARCOR(-ICB1,ICA1)
20745 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20752 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20753 ELSE IF(IP1.LT.0) THEN
20757 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20758 ELSE IF(IP2.GT.0) THEN
20762 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20767 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20770 ELSE IF(MSPR.EQ.4) THEN
20772 PC(1) = U/V-2.D0*U**2
20773 PC(2) = V/U-2.D0*V**2
20774 XI = (PC(1)+PC(2))*DT_RNDM(U)
20775 IF(XI.LT.PC(1)) THEN
20779 CALL PHO_HARCOR(-ICB1,ICA2)
20780 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20781 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20785 CALL PHO_HARCOR(-ICB2,ICA1)
20786 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20787 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20793 CALL PHO_HARCOR(-ICB2,ICA1)
20794 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20795 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20799 CALL PHO_HARCOR(-ICB1,ICA2)
20800 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20801 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20804 ELSE IF(MSPR.EQ.5) THEN
20806 PC(1) = (1.D0+U**2)/V**2
20807 PC(2) = (V**2+U**2)
20808 XI = (PC(1)+PC(2))*DT_RNDM(V)
20809 IF(XI.LT.PC(1)) THEN
20810 CALL PHO_HARCOR(-ICB1,ICA1)
20811 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20815 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20819 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20823 IC1 = MAX(ICA1,ICB1)
20824 IC3 = MIN(ICA1,ICB1)
20825 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20827 IC1 = MIN(ICA1,ICB1)
20828 IC3 = MAX(ICA1,ICB1)
20829 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20832 ELSE IF(MSPR.EQ.6) THEN
20835 IC1 = MAX(ICA1,ICB1)
20836 IC3 = MIN(ICA1,ICB1)
20837 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20839 IC1 = MIN(ICA1,ICB1)
20840 IC3 = MAX(ICA1,ICB1)
20841 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20843 ELSE IF(MSPR.EQ.7) THEN
20845 PC(1) = (1.D0+U**2)/V**2
20846 PC(2) = (1.D0+V**2)/U**2
20847 XI = (PC(1)+PC(2))*DT_RNDM(U)
20848 IF(XI.LT.PC(1)) THEN
20851 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20855 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20857 ELSE IF(MSPR.EQ.8) THEN
20859 IF(IP1*IP2.LT.0) THEN
20860 CALL PHO_HARCOR(-ICB1,ICA1)
20861 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20865 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20869 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20874 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20877 ELSE IF(MSPR.EQ.10) THEN
20879 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20881 CALL PHO_SWAPI(IC1,IC3)
20882 CALL PHO_SWAPI(IC2,IC4)
20884 ELSE IF(MSPR.EQ.11) THEN
20888 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20889 ELSE IF(MSPR.EQ.12) THEN
20891 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20893 CALL PHO_SWAPI(IC1,IC3)
20894 CALL PHO_SWAPI(IC2,IC4)
20896 ELSE IF(MSPR.EQ.13) THEN
20900 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20901 ELSE IF(MSPR.EQ.14) THEN
20902 IF(ABS(IP3).GT.12) THEN
20906 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20907 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20911 WRITE(LO,'(/1X,A,I3)')
20912 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20919 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20920 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20921 C color connection?
20922 * IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20923 * & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20924 * & .OR.(IC2.EQ.0))) THEN
20926 * IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20927 * & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20928 * IF(IRC.NE.1) THEN
20929 * WRITE(LO,'(1X,A,I10,I3)')
20930 * & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20931 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20932 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20933 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20934 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20939 * IF(IRC.EQ.1) THEN
20940 * WRITE(LO,'(1X,A,I10,I3)')
20941 * & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20942 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20943 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20944 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20945 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20955 CDECK ID>, PHO_HARCOR
20956 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20957 C***********************************************************************
20959 C substituite color in /POEVT2/
20961 C input: ICOLD old color
20964 C***********************************************************************
20965 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20968 C input/output channels
20970 COMMON /POINOU/ LI,LO
20972 C standard particle data interface
20975 PARAMETER (NMXHEP=4000)
20977 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20978 DOUBLE PRECISION PHEP,VHEP
20979 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20980 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20982 C extension to standard particle data interface (PHOJET specific)
20983 INTEGER IMPART,IPHIST,ICOLOR
20984 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20987 IF(ISTHEP(I).EQ.-1) THEN
20988 IF(ICOLOR(1,I).EQ.ICOLD) THEN
20989 ICOLOR(1,I) = ICNEW
20991 ELSE IF(IDHEP(I).EQ.21) THEN
20992 IF(ICOLOR(2,I).EQ.ICOLD) THEN
20993 ICOLOR(2,I) = ICNEW
20997 * ELSE IF(ISTHEP(I).EQ.20) THEN
20998 * IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20999 * print LO,' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
21000 * ICOLOR(1,I) = -ICNEW
21002 * ELSE IF(IDHEP(I).EQ.21) THEN
21003 * IF(ICOLOR(2,I).EQ.-ICOLD) THEN
21004 * print LO,' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
21005 * ICOLOR(2,I) = -ICNEW
21013 CDECK ID>, PHO_HARREM
21014 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21016 C***********************************************************************
21018 C sample color structure for initial quark/gluon of hard scattering
21019 C and write hadron remnant to /POEVT1/
21021 C input: JM1,2 index of mother particle in POEVT1
21022 C IGEN mother particle production process
21023 C IHPOS hard pomeron number
21024 C INDXH index of hard parton
21025 C positive for labels 1
21026 C negative for labels 2
21027 C IVAL 1 hard valence parton
21028 C 0 hard sea parton connected by color flow with
21030 C -1 hard sea parton independent off valence
21032 C INDXS index of soft partons needed
21034 C output: IC1,IC2 color label of initial parton
21035 C IUSED number of soft X values used
21036 C IREJ rejection flag
21038 C**********************************************************************
21039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21042 PARAMETER ( TINY = 1.D-10 )
21044 C input/output channels
21046 COMMON /POINOU/ LI,LO
21047 C event debugging information
21049 PARAMETER (NMAXD=100)
21050 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21051 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21052 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21053 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21054 C model switches and parameters
21056 INTEGER ISWMDL,IPAMDL
21057 DOUBLE PRECISION PARMDL
21058 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21059 C data of c.m. system of Pomeron / Reggeon exchange
21060 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21061 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21062 & SIDP,CODP,SIFP,COFP
21063 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21064 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21065 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21066 C obsolete cut-off information
21067 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21068 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21069 C light-cone x fractions and c.m. momenta of soft cut string ends
21071 PARAMETER ( MAXSOF = 50 )
21072 INTEGER IJSI2,IJSI1
21073 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21074 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21075 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21076 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21077 C hard scattering data
21079 PARAMETER ( MSCAHD = 50 )
21080 INTEGER LSCAHD,LSC1HD,LSIDX,
21081 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21082 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21083 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21084 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21085 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21086 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21087 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21088 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21089 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21091 C standard particle data interface
21094 PARAMETER (NMXHEP=4000)
21096 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21097 DOUBLE PRECISION PHEP,VHEP
21098 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21099 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21101 C extension to standard particle data interface (PHOJET specific)
21102 INTEGER IMPART,IPHIST,ICOLOR
21103 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21105 C internal rejection counters
21107 PARAMETER (NMXJ=60)
21108 CHARACTER*10 REJTIT
21110 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21114 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21116 IF(INDXH.GT.0) THEN
21117 IJH = IPHO_CNV1(NINHD(INDXH,1))
21119 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21121 C direct process (photon or pomeron)
21125 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21127 IHP = 100*ABS(IHPOS)
21129 ***************************************
21130 * IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21131 ***************************************
21133 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21134 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21135 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21138 C****************************************************************
21142 C valence quark engaged in hard scattering
21144 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21146 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21147 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21150 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21151 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21152 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21157 C remnant of hadron
21158 IF(INDXH.GT.0) THEN
21159 P1 = PSOFT1(1,INDXS)
21160 P2 = PSOFT1(2,INDXS)
21161 P3 = PSOFT1(3,INDXS)
21162 P4 = PSOFT1(4,INDXS)
21163 IJSI1(INDXS) = IREM
21165 P1 = PSOFT2(1,INDXS)
21166 P2 = PSOFT2(2,INDXS)
21167 P3 = PSOFT2(3,INDXS)
21168 P4 = PSOFT2(4,INDXS)
21169 IJSI2(INDXS) = IREM
21172 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21173 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21174 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21175 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21176 & IREM,IPOS,SIGN(INDXS,INDXH)
21180 C sea quark engaged in hard scattering, valence quarks treated
21181 ELSE IF(IVAL.EQ.0) THEN
21182 IF(INDXH.GT.0) THEN
21183 E1 = PSOFT1(4,INDXS)
21184 E2 = PSOFT1(4,INDXS+1)
21186 E1 = PSOFT2(4,INDXS)
21187 E2 = PSOFT2(4,INDXS+1)
21189 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21190 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21191 IF(DT_RNDM(P1).LT.0.5D0) THEN
21192 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21194 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21196 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21197 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21202 IF(INDXH.GT.0) THEN
21203 P1 = PSOFT1(1,INDXS)
21204 P2 = PSOFT1(2,INDXS)
21205 P3 = PSOFT1(3,INDXS)
21206 P4 = PSOFT1(4,INDXS)
21207 IJSI1(INDXS) = IVFL1
21209 P1 = PSOFT2(1,INDXS)
21210 P2 = PSOFT2(2,INDXS)
21211 P3 = PSOFT2(3,INDXS)
21212 P4 = PSOFT2(4,INDXS)
21213 IJSI2(INDXS) = IVFL1
21216 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21217 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21218 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21219 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21220 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21223 IF(INDXH.GT.0) THEN
21224 P1 = PSOFT1(1,INDXS+1)
21225 P2 = PSOFT1(2,INDXS+1)
21226 P3 = PSOFT1(3,INDXS+1)
21227 P4 = PSOFT1(4,INDXS+1)
21228 IJSI1(INDXS+1) = IVFL2
21230 P1 = PSOFT2(1,INDXS+1)
21231 P2 = PSOFT2(2,INDXS+1)
21232 P3 = PSOFT2(3,INDXS+1)
21233 P4 = PSOFT2(4,INDXS+1)
21234 IJSI2(INDXS+1) = IVFL2
21237 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21238 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21239 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21240 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21241 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21251 IF(INDXH.GT.0) THEN
21252 P1 = PSOFT1(1,INDXS+2)
21253 P2 = PSOFT1(2,INDXS+2)
21254 P3 = PSOFT1(3,INDXS+2)
21255 P4 = PSOFT1(4,INDXS+2)
21256 IJSI1(INDXS+2) = -IJH
21258 P1 = PSOFT2(1,INDXS+2)
21259 P2 = PSOFT2(2,INDXS+2)
21260 P3 = PSOFT2(3,INDXS+2)
21261 P4 = PSOFT2(4,INDXS+2)
21262 IJSI2(INDXS+2) = -IJH
21265 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21266 & IHP,IGEN,ICA1,0,IPOS,1)
21267 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21268 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21269 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21272 C sea quark engaged in hard scattering, valences treated separately
21273 ELSE IF(IVAL.EQ.-1) THEN
21274 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21280 IF(INDXH.GT.0) THEN
21281 P1 = PSOFT1(1,INDXS)
21282 P2 = PSOFT1(2,INDXS)
21283 P3 = PSOFT1(3,INDXS)
21284 P4 = PSOFT1(4,INDXS)
21285 IJSI1(INDXS) = -IJH
21287 P1 = PSOFT2(1,INDXS)
21288 P2 = PSOFT2(2,INDXS)
21289 P3 = PSOFT2(3,INDXS)
21290 P4 = PSOFT2(4,INDXS)
21291 IJSI2(INDXS) = -IJH
21294 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21295 & IHP,IGEN,ICA1,0,IPOS,1)
21296 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21297 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21298 & -IJH,IPOS,SIGN(INDXS,INDXH)
21302 WRITE(LO,'(1X,A,2I5)')
21303 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21312 C****************************************************************
21314 C gluon from valence quarks
21317 C purely gluonic pomeron remnant
21318 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21319 IF(INDXH.GT.0) THEN
21320 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21321 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21322 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21323 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21326 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21327 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21328 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21329 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21333 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21334 IF(DT_RNDM(P2).LT.0.5D0) THEN
21335 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21337 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21340 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21341 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21342 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21343 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21344 & IFL1,IPOS,SIGN(INDXS,INDXH)
21347 C valence quark remnant
21349 IF(INDXH.GT.0) THEN
21350 E1 = PSOFT1(4,INDXS)
21351 E2 = PSOFT1(4,INDXS+1)
21353 E1 = PSOFT2(4,INDXS)
21354 E2 = PSOFT2(4,INDXS+1)
21356 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21357 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21358 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21359 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21364 IF(DT_RNDM(P2).LT.0.5D0) THEN
21365 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21367 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21369 C remnant of hadron
21370 IF(INDXH.GT.0) THEN
21371 P1 = PSOFT1(1,INDXS)
21372 P2 = PSOFT1(2,INDXS)
21373 P3 = PSOFT1(3,INDXS)
21374 P4 = PSOFT1(4,INDXS)
21375 IJSI1(INDXS) = IFL1
21377 P1 = PSOFT2(1,INDXS)
21378 P2 = PSOFT2(2,INDXS)
21379 P3 = PSOFT2(3,INDXS)
21380 P4 = PSOFT2(4,INDXS)
21381 IJSI2(INDXS) = IFL1
21384 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21385 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21386 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21387 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21388 & IFL1,IPOS,SIGN(INDXS,INDXH)
21391 IF(INDXH.GT.0) THEN
21392 P1 = PSOFT1(1,INDXS+1)
21393 P2 = PSOFT1(2,INDXS+1)
21394 P3 = PSOFT1(3,INDXS+1)
21395 P4 = PSOFT1(4,INDXS+1)
21396 IJSI1(INDXS+1) = IFL2
21398 P1 = PSOFT2(1,INDXS+1)
21399 P2 = PSOFT2(2,INDXS+1)
21400 P3 = PSOFT2(3,INDXS+1)
21401 P4 = PSOFT2(4,INDXS+1)
21402 IJSI2(INDXS+1) = IFL2
21405 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21406 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21407 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21408 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21409 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21414 C gluon from sea quarks connected with valence quarks
21415 ELSE IF(IVAL.EQ.0) THEN
21416 IF(INDXH.GT.0) THEN
21417 E1 = PSOFT1(4,INDXS)
21418 E2 = PSOFT1(4,INDXS+1)
21420 E1 = PSOFT2(4,INDXS)
21421 E2 = PSOFT2(4,INDXS+1)
21423 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21424 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21425 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21426 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21431 IF(DT_RNDM(P3).LT.0.5D0) THEN
21432 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21434 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21436 C remnant of hadron
21437 IF(INDXH.GT.0) THEN
21438 P1 = PSOFT1(1,INDXS)
21439 P2 = PSOFT1(2,INDXS)
21440 P3 = PSOFT1(3,INDXS)
21441 P4 = PSOFT1(4,INDXS)
21442 IJSI1(INDXS) = IFL1
21444 P1 = PSOFT2(1,INDXS)
21445 P2 = PSOFT2(2,INDXS)
21446 P3 = PSOFT2(3,INDXS)
21447 P4 = PSOFT2(4,INDXS)
21448 IJSI2(INDXS) = IFL1
21451 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21452 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21453 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21454 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21455 & IFL1,IPOS,SIGN(INDXS,INDXH)
21458 IF(INDXH.GT.0) THEN
21459 P1 = PSOFT1(1,INDXS+1)
21460 P2 = PSOFT1(2,INDXS+1)
21461 P3 = PSOFT1(3,INDXS+1)
21462 P4 = PSOFT1(4,INDXS+1)
21463 IJSI1(INDXS+1) = IFL2
21465 P1 = PSOFT2(1,INDXS+1)
21466 P2 = PSOFT2(2,INDXS+1)
21467 P3 = PSOFT2(3,INDXS+1)
21468 P4 = PSOFT2(4,INDXS+1)
21469 IJSI2(INDXS+1) = IFL2
21472 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21473 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21474 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21475 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21476 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21478 IF(IPAMDL(18).EQ.0) THEN
21480 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21488 IF(DT_RNDM(P4).LT.0.5D0) THEN
21490 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21493 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21495 IF(INDXH.GT.0) THEN
21496 P1 = PSOFT1(1,INDXS+2)
21497 P2 = PSOFT1(2,INDXS+2)
21498 P3 = PSOFT1(3,INDXS+2)
21499 P4 = PSOFT1(4,INDXS+2)
21500 IJSI1(INDXS+2) = IFL1
21502 P1 = PSOFT2(1,INDXS+2)
21503 P2 = PSOFT2(2,INDXS+2)
21504 P3 = PSOFT2(3,INDXS+2)
21505 P4 = PSOFT2(4,INDXS+2)
21506 IJSI2(INDXS+2) = IFL1
21509 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21510 & IHP,IGEN,ICA1,0,IPOS,1)
21511 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21512 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21513 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21516 IF(INDXH.GT.0) THEN
21517 P1 = PSOFT1(1,INDXS+3)
21518 P2 = PSOFT1(2,INDXS+3)
21519 P3 = PSOFT1(3,INDXS+3)
21520 P4 = PSOFT1(4,INDXS+3)
21521 IJSI1(INDXS+3) = IFL2
21523 P1 = PSOFT2(1,INDXS+3)
21524 P2 = PSOFT2(2,INDXS+3)
21525 P3 = PSOFT2(3,INDXS+3)
21526 P4 = PSOFT2(4,INDXS+3)
21527 IJSI2(INDXS+3) = IFL2
21530 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21531 & IHP,IGEN,ICB1,0,IPOS,1)
21532 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21533 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21534 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21541 C gluon from independent sea quarks
21542 ELSE IF(IVAL.EQ.-1) THEN
21543 IF(IPAMDL(18).EQ.0) THEN
21544 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21545 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21546 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21547 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21552 IF(DT_RNDM(P1).LT.0.5D0) THEN
21553 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21555 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21557 C remainder of hadron
21558 IF(INDXH.GT.0) THEN
21559 P1 = PSOFT1(1,INDXS)
21560 P2 = PSOFT1(2,INDXS)
21561 P3 = PSOFT1(3,INDXS)
21562 P4 = PSOFT1(4,INDXS)
21563 IJSI1(INDXS) = IFL1
21565 P1 = PSOFT2(1,INDXS)
21566 P2 = PSOFT2(2,INDXS)
21567 P3 = PSOFT2(3,INDXS)
21568 P4 = PSOFT2(4,INDXS)
21569 IJSI2(INDXS) = IFL1
21572 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21573 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21574 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21575 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21576 & IFL1,IPOS,SIGN(INDXS,INDXH)
21579 IF(INDXH.GT.0) THEN
21580 P1 = PSOFT1(1,INDXS-1)
21581 P2 = PSOFT1(2,INDXS-1)
21582 P3 = PSOFT1(3,INDXS-1)
21583 P4 = PSOFT1(4,INDXS-1)
21584 IJSI1(INDXS-1) = IFL2
21586 P1 = PSOFT2(1,INDXS-1)
21587 P2 = PSOFT2(2,INDXS-1)
21588 P3 = PSOFT2(3,INDXS-1)
21589 P4 = PSOFT2(4,INDXS-1)
21590 IJSI2(INDXS-1) = IFL2
21593 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21594 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21595 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21596 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21597 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21601 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21602 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21603 & 'PHO_HARREM: no spectator added:(INDXS)',
21604 & SIGN(INDXS,INDXH)
21609 WRITE(LO,'(1X,A,2I5)')
21610 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21619 CDECK ID>, PHO_HARDIR
21620 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21622 C**********************************************************************
21624 C parton orientated formulation of direct scattering processes
21628 C output: II particle combination (1..4)
21629 C IVAL1,2 0 no valence quarks engaged
21630 C 1 valence quarks engaged
21631 C MSPAR1,2 number of realized soft partons
21632 C MHPAR1,2 number of realized hard partons
21636 C**********************************************************************
21637 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21640 C input/output channels
21642 COMMON /POINOU/ LI,LO
21643 C event debugging information
21645 PARAMETER (NMAXD=100)
21646 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21647 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21648 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21649 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21650 C model switches and parameters
21652 INTEGER ISWMDL,IPAMDL
21653 DOUBLE PRECISION PARMDL
21654 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21655 C hard scattering parameters used for most recent hard interaction
21657 DOUBLE PRECISION ALQCD2,BQCD
21658 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21659 C data of c.m. system of Pomeron / Reggeon exchange
21660 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21661 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21662 & SIDP,CODP,SIFP,COFP
21663 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21664 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21665 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21666 C obsolete cut-off information
21667 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21668 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21669 C hard cross sections and MC selection weights
21671 PARAMETER ( Max_pro_2 = 16 )
21672 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21673 & MH_acc_1,MH_acc_2
21674 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21675 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21676 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21677 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21678 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21679 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21680 C data on most recent hard scattering
21681 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21682 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21683 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21684 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21685 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21686 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21687 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21688 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21689 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21690 C light-cone x fractions and c.m. momenta of soft cut string ends
21692 PARAMETER ( MAXSOF = 50 )
21693 INTEGER IJSI2,IJSI1
21694 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21695 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21696 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21697 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21698 C hard scattering data
21700 PARAMETER ( MSCAHD = 50 )
21701 INTEGER LSCAHD,LSC1HD,LSIDX,
21702 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21703 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21704 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21705 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21706 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21707 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21708 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21709 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21710 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21711 C internal rejection counters
21713 PARAMETER (NMXJ=60)
21714 CHARACTER*10 REJTIT
21716 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21718 DIMENSION P1(4),P2(4),PD1(-6:6)
21720 PARAMETER ( TINY = 1.D-10 )
21727 C check phase space
21728 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21729 IFAIL(18) = IFAIL(18)+1
21734 AS = (PARMDL(160+II)/ECMP)**2
21735 AH = (2.D0*PTWANT/ECMP)**2
21740 XMAX = MAX(TINY,1.D0-AS)
21744 C main loop to select hard and soft parton kinematics
21745 C -----------------------------------------------------
21751 IFAIL(17) = IFAIL(17)+1
21752 IF(ITRY.GE.NTRY) THEN
21765 CALL PHO_HARSCA(1,II)
21769 IF(IDEB(25).GE.20) THEN
21770 WRITE(LO,'(1X,A,2E12.4,2I5)')
21771 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21772 & AS,XMAX,MSPR,ITRY
21773 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21777 IF(MSPR.LE.11) THEN
21778 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21779 ELSE IF(MSPR.LE.13) THEN
21780 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21797 NBRAHD(1,1)= IDPDG1
21798 NBRAHD(1,2)= IDPDG2
21802 PPH(4+I,1) = PHO1(I)
21803 PPH(4+I,2) = PHO2(I)
21811 IF(MSPR.LE.11) THEN
21812 NINHD(1,1) = IDPDG1
21814 PDFVA(1,2) = PDF2(IB)
21816 ELSE IF(MSPR.LE.13) THEN
21818 PDFVA(1,1) = PDF1(IA)
21819 NINHD(1,2) = IDPDG2
21822 NINHD(1,1) = IDPDG1
21823 NINHD(1,2) = IDPDG2
21826 N0INHD(1,1) = NINHD(1,1)
21827 N0INHD(1,2) = NINHD(1,2)
21828 N0IVAL(1,1) = IVAL1
21829 N0IVAL(1,2) = IVAL2
21833 C reweight according to photon virtuality
21834 IF(MSPR.NE.14) THEN
21835 IF(IPAMDL(115).GE.1) THEN
21837 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21839 IF(IPAMDL(115).EQ.1) THEN
21840 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21843 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21844 & /LOG(QQPD/PARMDL(144))
21846 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21847 ELSE IF(IPAMDL(115).EQ.2) THEN
21848 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21849 WGX = PD1(IB)/PDFVA(1,2)
21851 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21852 & .AND.(IDPDG1.EQ.22)) THEN
21854 IF(IPAMDL(115).EQ.1) THEN
21855 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21858 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21859 & /LOG(QQPD/PARMDL(144))
21861 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21862 ELSE IF(IPAMDL(115).EQ.2) THEN
21863 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21864 WGX = PD1(IA)/PDFVA(1,1)
21869 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21870 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21871 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21873 IF(WGX.LT.DT_RNDM(WGX)) THEN
21879 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21880 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21881 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21887 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21888 IF(IPAMDL(109).EQ.1) THEN
21889 Q2H = PARMDL(93)*PT**2
21891 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21893 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
21894 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
21899 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21900 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21901 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21902 XSS1 = XSS1+XISR1-XHD(1,1)
21903 XSS2 = XSS2+XISR2-XHD(1,2)
21915 C add photon/hadron remnant
21919 XMAXX = 1.D0 - XSS2 - AS
21920 XMAXH = MIN(XMAXX,PARMDL(44))
21921 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21927 ELSE IF(IFL1.EQ.0) THEN
21928 XMAXX = 1.D0 - XSS1 - AS
21929 XMAXH = MIN(XMAXX,PARMDL(44))
21930 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21938 ELSE IF(ABS(IFL2).LE.12) THEN
21939 IF(IVAL2.EQ.1) THEN
21940 XS2(1) = 1.D0 - XSS2
21946 XMAXX = 1.D0 - XSS2 - AS
21947 XMAXH = MIN(XMAXX,PARMDL(44))
21948 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21954 ELSE IF(ABS(IFL1).LE.12) THEN
21955 IF(IVAL1.EQ.1) THEN
21956 XS1(1) = 1.D0 - XSS1
21962 XMAXX = 1.D0 - XSS1 - AS
21963 XMAXH = MIN(XMAXX,PARMDL(44))
21964 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21971 C double direct process
21972 ELSE IF(MSPR.EQ.14) THEN
21980 WRITE(LO,'(/1X,A,I3/)')
21981 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21986 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21987 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21991 C soft particle momenta
21992 IF(MSPAR1.GT.0) THEN
21996 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21997 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22000 IF(MSPAR2.GT.0) THEN
22004 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22005 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22009 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22010 KSOFT = MAX(MSPAR1,MSPAR2)
22011 KHARD = MAX(MHPAR1,MHPAR2)
22013 IF(IDEB(25).GE.10) THEN
22014 WRITE(LO,'(/1X,A,2I3,3I5)')
22015 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
22016 & IVAL1,IVAL2,MSPR,ITRY,NTRY
22017 IF(MSPAR1.GT.0) THEN
22018 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
22020 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
22023 IF(MSPAR2.GT.0) THEN
22024 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
22026 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
22029 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
22030 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
22031 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
22032 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
22033 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
22034 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
22035 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
22036 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
22041 IFAIL(16) = IFAIL(16)+1
22042 IF(IDEB(25).GE.2) THEN
22043 WRITE(LO,'(1X,A,3I5)')
22044 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
22045 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
22046 IF(IDEB(25).GE.5) THEN
22049 CALL PHO_PREVNT(-1)
22055 CDECK ID>, PHO_POMSCA
22056 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22057 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22058 C**********************************************************************
22060 C parton orientated formulation of soft and hard inelastic events
22063 C input: II particle combiantion (1..4)
22064 C MSPOM number of soft pomerons
22065 C MHPOM number of semihard pomerons
22066 C MSREG number of soft reggeons
22068 C output: IVAL1,2 0 no valence quark engaged
22069 C otherwise: position of valence quark engaged
22070 C neg.number: gluon connected to valence quark
22072 C MSPAR1,2 number of realized soft partons
22073 C MHPAR1,2 number of realized hard partons
22077 C**********************************************************************
22078 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22081 PARAMETER (TINY = 1.D-30 )
22083 C input/output channels
22085 COMMON /POINOU/ LI,LO
22086 C event debugging information
22088 PARAMETER (NMAXD=100)
22089 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22090 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22091 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22092 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22093 C model switches and parameters
22095 INTEGER ISWMDL,IPAMDL
22096 DOUBLE PRECISION PARMDL
22097 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22098 C general process information
22099 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22100 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22101 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22102 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22103 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22104 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22105 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22106 C event weights and generated cross section
22107 INTEGER IPOWGC,ISWCUT,IVWGHT
22108 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22109 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22110 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22111 C hard cross sections and MC selection weights
22113 PARAMETER ( Max_pro_2 = 16 )
22114 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22115 & MH_acc_1,MH_acc_2
22116 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22117 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22118 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22119 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22120 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22121 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22122 C hard scattering parameters used for most recent hard interaction
22124 DOUBLE PRECISION ALQCD2,BQCD
22125 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22126 C data of c.m. system of Pomeron / Reggeon exchange
22127 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22128 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22129 & SIDP,CODP,SIFP,COFP
22130 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22131 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22132 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22133 C obsolete cut-off information
22134 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22135 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22136 C some hadron information, will be deleted in future versions
22138 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22139 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22140 C data on most recent hard scattering
22141 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22142 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22143 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22144 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22145 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22146 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22147 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22148 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22149 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22150 C light-cone x fractions and c.m. momenta of soft cut string ends
22152 PARAMETER ( MAXSOF = 50 )
22153 INTEGER IJSI2,IJSI1
22154 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22155 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22156 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22157 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22158 C hard scattering data
22160 PARAMETER ( MSCAHD = 50 )
22161 INTEGER LSCAHD,LSC1HD,LSIDX,
22162 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22163 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22164 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22165 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22166 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22167 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22168 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22169 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22170 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22171 C table of particle indices for recursive PHOJET calls
22173 PARAMETER ( MAXIPX = 100 )
22174 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22175 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22176 & IPOIX1,IPOIX2,IPOIX3
22177 C internal rejection counters
22179 PARAMETER (NMXJ=60)
22180 CHARACTER*10 REJTIT
22182 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22184 DIMENSION P1(4),P2(4),PD1(-6:6)
22186 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22187 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22195 C phase space limitation (single hard valence-valence quark scattering)
22196 IF(MHPOM.GT.0) THEN
22197 Emin = 2.D0*PTWANT + 0.2D0
22198 IF(ECMP.LT.Emin) THEN
22199 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22200 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22202 IFAIL(6) = IFAIL(6) + 1
22207 SAS = PARMDL(160+II)/ECMP
22208 SAH = 2.D0*PTWANT/ECMP
22212 C save energy for leading particle effect
22214 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22216 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22219 C main loop to select hard and soft parton kinematics
22220 C -----------------------------------------------------
22221 IFAIL(31) = IFAIL(31)+MHARD
22227 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22228 IF(ITRY.GE.NTRY) THEN
22234 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22235 XSS1 = MAX(0.D0,1.D0-XPSUB)
22236 XSS2 = MAX(0.D0,1.D0-XTSUB)
22243 C partons needed to construct soft/hard interactions
22244 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22249 C number of strings
22250 MSCHA = 2*MSPOM+MSREG
22256 C check actual phase space limit
22257 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22258 IF(XX.GE.1.D0) THEN
22259 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22260 & 'PHO_POMSCA: internal kin. rejection ',
22261 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22262 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22263 if(MSPOM+MSREG+MHPOM.gt.1) then
22264 if(MSREG.gt.0) then
22266 else if(MSPOM.gt.0) THEN
22268 else if(MHPOM.gt.1) then
22273 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22274 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22276 IFAIL(6) = IFAIL(6) + 1
22280 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22281 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22283 C very low energy phase space restriction
22284 if(MHARD.gt.0) then
22285 if((XMAXX1*XMAXX2.le.AH)) then
22286 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22287 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22289 IFAIL(6) = IFAIL(6) + 1
22294 AS = MAX(AS,PSOMIN/PCMP)
22297 Z1MAX = LOG(XMAXX1)
22298 Z2MAX = LOG(XMAXX2)
22299 Z1DIF = Z1MAX+Z2MAX-ALNH
22303 C select hard parton momenta
22304 C ------------------- begin of inner loop -------------------
22305 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22307 IF(MHARD.GT.MSCAHD) THEN
22308 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22309 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22316 C generate one resolved hard scattering
22319 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22320 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22321 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22327 AH = (2.D0*PTWANT/ECMP)**2
22329 Z1DIF = Z1MAX+Z2MAX-ALNH
22331 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22332 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22333 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22334 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22338 CALL PHO_HARSCA(2,II)
22339 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22340 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22345 IPOWGC(4+II) = IPOWGC(4+II)+1
22346 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22347 C minimum bias option
22349 CALL PHO_HARSCA(2,II)
22366 PDFVA(NN,1) = PDF1(IA)
22367 PDFVA(NN,2) = PDF2(IB)
22378 NBRAHD(NN,1) = IDPDG1
22379 NBRAHD(NN,2) = IDPDG2
22383 PPH(I3+I,1) = PHI1(I)
22384 PPH(I3+I,2) = PHI2(I)
22385 PPH(I4+I,1) = PHO1(I)
22386 PPH(I4+I,2) = PHO2(I)
22391 C sort according to pt-hat
22393 PTMX = PTHD(LSIDX(NN))
22396 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22398 PTMX = PTHD(LSIDX(I))
22401 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22405 C copy partons, generate ISR
22408 XSSS1 = XSS1+XHD(NN,1)
22409 XSSS2 = XSS2+XHD(NN,2)
22411 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22412 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22413 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22414 C check phase space
22415 IF( (XSSS1.GT.XMAXX1)
22416 & .OR.(XSSS2.GT.XMAXX2)
22417 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22418 IF(IHARD.EQ.0) THEN
22419 IF(ISWMDL(2).NE.1) GOTO 20
22427 C reweight according to photon virtuality
22428 IF(IPAMDL(115).GE.1) THEN
22431 IF(IDPDG1.EQ.22) THEN
22432 IF(IPAMDL(115).EQ.1) THEN
22433 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22436 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22437 & /LOG(QQPD/PARMDL(144))
22439 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22440 ELSE IF(IPAMDL(115).EQ.2) THEN
22441 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22442 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22447 IF(IDPDG2.EQ.22) THEN
22448 IF(IPAMDL(115).EQ.1) THEN
22449 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22452 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22453 & /LOG(QQPD/PARMDL(144))
22455 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22456 ELSE IF(IPAMDL(115).EQ.2) THEN
22457 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22458 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22464 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22465 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22466 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22468 IF(WGX.LT.DT_RNDM(WGX)) THEN
22477 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22479 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22480 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22485 IF((ISWMDL(8).GE.2)
22486 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22487 IF(IPAMDL(109).EQ.1) THEN
22488 Q2H = PARMDL(93)*PTHD(NN)**2
22490 Q2H = -PARMDL(93)*VHD(NN)
22491 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22493 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22494 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22497 P1(J) = PPH(I3+J,1)
22498 P2(J) = PPH(I3+J,2)
22501 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22502 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22503 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22506 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22507 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22508 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22509 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22510 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22511 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22518 C check phase space
22519 IF( (XSSS1.GT.XMAXX1)
22520 & .OR.(XSSS2.GT.XMAXX2)
22521 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22522 IF(IHARD.EQ.0) THEN
22523 IF(ISWMDL(2).NE.1) GOTO 20
22531 C leave energy for leading particle effect
22532 IF((IHARD.GT.0).AND.
22533 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22537 C hard scattering accepted
22541 IFAIL(31) = IFAIL(31)-1
22545 C ------------------- end of inner (hard) loop -------------------
22552 C count valences involved in hard scattering
22557 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22558 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22568 C photon, pomeron valences
22569 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22570 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22575 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22576 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22582 C total number of quarks
22583 IF(NINHD(NN,1).NE.0) THEN
22585 ELSE IF(IVGLU1.EQ.0) THEN
22588 IF(NINHD(NN,2).NE.0) THEN
22590 ELSE IF(IVGLU2.EQ.0) THEN
22595 C gluons emitted by valence quarks
22597 IF(II.EQ.1) VALPRO = VALPRG(1)
22600 IVAL1 = MAX(IVAL1,0)
22601 IF(IVAL1.EQ.0) THEN
22603 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22609 IF(II.EQ.1) VALPRO = VALPRG(2)
22612 IVAL2 = MAX(IVAL2,0)
22613 IF(IVAL2.EQ.0) THEN
22615 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22620 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22622 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22623 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22624 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22626 C select soft X values
22628 C number of soft/remnant quarks
22629 IF(MSPOM.EQ.0) THEN
22630 IF(IPAMDL(18).EQ.0) THEN
22631 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22632 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22634 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22635 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22638 IF(IPAMDL(18).EQ.0) THEN
22639 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22640 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22642 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22643 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22647 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22648 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22649 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22651 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22652 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22655 IF(IVAL1.LE.0) I1 = 0
22656 IF(IVAL2.LE.0) I2 = 0
22657 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22660 MSDIFF = 2*MAX(0,MSPOM-1)
22664 MSM1 = MSPAR1-MSDIFF
22665 MSM2 = MSPAR2-MSDIFF
22666 XMAXH1 = MIN(XMAX1,PARMDL(44))
22667 XMAXH2 = MIN(XMAX2,PARMDL(44))
22668 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22669 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22671 C correct for proper simulation of high pt tail
22673 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22674 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22675 & MSPOM,MHPOM,I1,I2
22676 IF(MSPOM*MHPOM.GT.0) THEN
22679 ELSE IF(MSPOM.GT.1) THEN
22682 ELSE IF(MHPOM.GT.1) THEN
22684 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22685 & .AND.(IPROCE.EQ.1)) THEN
22686 XSS1 = MAX(0.D0,1.D0-XPSUB)
22687 XSS2 = MAX(0.D0,1.D0-XTSUB)
22694 XSS1 = XSS1+ XHD(I,1)
22695 XSS2 = XSS2+ XHD(I,2)
22703 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22706 C ------------ kinematics sampled ---------------
22708 IF(IDEB(24).GE.10) THEN
22709 WRITE(LO,'(1X,A,I3)')
22710 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22711 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22712 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22715 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22718 XS1(1) = 1.D0 - XSS1
22719 XS2(1) = 1.D0 - XSS2
22723 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22726 C soft particle momenta
22728 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22729 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22730 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22738 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22739 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22744 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22745 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22748 KSOFT = MAX(MSPAR1,MSPAR2)
22749 KHARD = MAX(MHPAR1,MHPAR2)
22755 IF(IDEB(24).GE.10) THEN
22756 WRITE(LO,'(/1X,A,2I3,2I5)')
22757 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22758 & IVAL1,IVAL2,ITRY,NTRY
22759 IF(MSPAR1+MSPAR2.GT.0) THEN
22760 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22763 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22764 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22765 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22766 XTMP1 = XTMP1+XS1(I)
22767 XTMP2 = XTMP2+XS2(I)
22768 ELSE IF(I.LE.MSPAR1) THEN
22769 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22770 XTMP1 = XTMP1+XS1(I)
22771 ELSE IF(I.LE.MSPAR2) THEN
22772 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22773 XTMP2 = XTMP2+XS2(I)
22776 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22778 IF(MHPAR1.GT.0) THEN
22780 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22783 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22784 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22785 & NINHD(I,1),NINHD(I,2)
22786 XTMP1 = XTMP1+XHD(I,1)
22787 XTMP2 = XTMP2+XHD(I,2)
22789 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22790 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22794 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22797 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22801 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22808 C event rejected, print debug information
22810 IFAIL(4) = IFAIL(4)+1
22811 IF(IDEB(24).GE.2) THEN
22812 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22813 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22814 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22815 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22816 IF(IDEB(24).GE.5) THEN
22819 CALL PHO_PREVNT(-1)
22825 CDECK ID>, PHO_HARX12
22826 SUBROUTINE PHO_HARX12
22827 C**********************************************************************
22829 C selection of x1 and x2 according to 1/x1*1/x2
22831 C**********************************************************************
22832 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22835 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22837 C input/output channels
22839 COMMON /POINOU/ LI,LO
22840 C data on most recent hard scattering
22841 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22842 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22843 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22844 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22845 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22846 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22847 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22848 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22849 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22852 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22853 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22854 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22858 W = SQRT(MAX(TINY,1.D0-AXX))
22863 CDECK ID>, PHO_HARDX1
22864 SUBROUTINE PHO_HARDX1
22865 C**********************************************************************
22867 C selection of x1 according to 1/x1
22870 C**********************************************************************
22871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22874 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22876 C input/output channels
22878 COMMON /POINOU/ LI,LO
22879 C data on most recent hard scattering
22880 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22881 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22882 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22883 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22884 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22885 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22886 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22887 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22888 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22890 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22894 W = SQRT(MAX(TINY,1.D0-AXX))
22899 CDECK ID>, PHO_HARKIN
22900 SUBROUTINE PHO_HARKIN(IREJ)
22901 C***********************************************************************
22903 C selection of kinematic variables
22904 C (resolved and direct processes)
22906 C***********************************************************************
22907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22910 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22912 C input/output channels
22914 COMMON /POINOU/ LI,LO
22915 C event debugging information
22917 PARAMETER (NMAXD=100)
22918 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22919 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22920 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22921 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22922 C data of c.m. system of Pomeron / Reggeon exchange
22923 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22924 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22925 & SIDP,CODP,SIFP,COFP
22926 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22927 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22928 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22929 C data on most recent hard scattering
22930 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22931 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22932 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22933 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22934 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22935 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22936 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22937 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22938 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22939 C internal cross check information on hard scattering limits
22940 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22941 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22943 PARAMETER ( Max_pro_2 = 16 )
22944 DIMENSION RM(-1:Max_pro_2)
22945 DATA RM / 3.31D0, 0.0D0,
22946 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22947 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
22948 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
22954 C------------- resolved processes -----------
22957 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22959 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22960 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22961 & 'PHO_HARKIN:weight error',M
22962 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22963 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22964 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22967 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22969 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22970 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22971 & 'PHO_HARKIN:weight error',M
22972 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22973 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22974 ELSEIF ( M.EQ.3 ) THEN
22976 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22978 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22979 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22980 & 'PHO_HARKIN:weight error',M
22981 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22982 ELSEIF ( M.EQ.5 ) THEN
22984 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22986 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22987 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22988 & 'PHO_HARKIN:weight error',M
22989 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22990 ELSEIF ( M.EQ.6 ) THEN
22992 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22994 R = (4.D0/9.D0)*(U*U+V*V)*AXX
22995 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22996 & 'PHO_HARKIN:weight error',M
22997 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22998 ELSEIF ( M.EQ.7 ) THEN
23000 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23002 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
23003 & -(4.D0/27.D0)*V/U)
23004 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23005 & 'PHO_HARKIN:weight error',M
23006 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
23007 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23008 ELSEIF ( M.EQ.8 ) THEN
23010 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23012 R = (4.D0/9.D0)*(1.D0+U*U)
23013 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23014 & 'PHO_HARKIN:weight error',M
23015 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
23016 ELSEIF ( M.EQ.-1 ) THEN
23019 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23021 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
23022 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23023 & 'PHO_HARKIN:weight error',M
23024 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
23025 C------------- direct / single-resolved processes -----------
23026 ELSEIF ( M.EQ.10 ) THEN
23027 100 CALL PHO_HARDX1
23028 WL = LOG(AXX/(1.D0+W)**2)
23029 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23030 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
23031 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23032 & 'PHO_HARKIN:weight error',M
23033 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
23037 ELSEIF ( M.EQ.11) THEN
23038 110 CALL PHO_HARDX1
23040 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23042 R = (U*U+V*V)/V*WL*AXX
23043 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23044 & 'PHO_HARKIN:weight error',M
23045 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
23046 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23049 ELSEIF ( M.EQ.12 ) THEN
23050 120 CALL PHO_HARDX1
23051 WL = LOG(AXX/(1.D0+W)**2)
23052 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23053 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
23054 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23055 & 'PHO_HARKIN:weight error',M
23056 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
23057 ELSEIF ( M.EQ.13) THEN
23058 130 CALL PHO_HARDX1
23060 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23062 R = (U*U+V*V)/U*WL*AXX
23063 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23064 & 'PHO_HARKIN:weight error',M
23065 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
23066 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23067 C------------- (double) direct process -----------
23068 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23072 W = SQRT(MAX(TINY,1.D0-AXX))
23075 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23078 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23079 & 'PHO_HARKIN:weight error',M
23080 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23081 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23082 C---------------------------------------------
23084 WRITE(LO,'(/1X,A,I3)')
23085 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23089 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23091 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23092 PT = SQRT(U*V*X1*X2)*ECMP
23093 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23094 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23096 ***************************************************************
23099 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23100 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23101 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23102 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23103 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23104 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23105 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23106 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23107 ***************************************************************
23109 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23110 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23114 CDECK ID>, PHO_HARWGH
23115 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23116 C***********************************************************************
23118 C calculate product of PDFs and coupling constants
23119 C according to selected MSPR (process type)
23123 C output: PDS resulting from PDFs alone
23124 C FDISTR complete weight function
23125 C PDA,PDB fields containing the PDFs
23127 C***********************************************************************
23128 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23131 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23133 C input/output channels
23135 COMMON /POINOU/ LI,LO
23136 C event debugging information
23138 PARAMETER (NMAXD=100)
23139 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23140 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23141 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23142 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23143 C model switches and parameters
23145 INTEGER ISWMDL,IPAMDL
23146 DOUBLE PRECISION PARMDL
23147 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23148 C data of c.m. system of Pomeron / Reggeon exchange
23149 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23150 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23151 & SIDP,CODP,SIFP,COFP
23152 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23153 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23154 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23155 C currently activated parton density parametrizations
23157 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23158 DOUBLE PRECISION PDFLAM,PDFQ2M
23159 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23160 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23161 C hard scattering parameters used for most recent hard interaction
23163 DOUBLE PRECISION ALQCD2,BQCD
23164 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23165 C some hadron information, will be deleted in future versions
23167 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23168 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23169 C scale parameters for parton model calculations
23170 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23171 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23172 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23173 & NQQAL,NQQALI,NQQALF,NQQPD
23174 C data on most recent hard scattering
23175 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23176 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23177 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23178 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23179 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23180 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23181 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23182 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23183 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23184 C hard cross sections and MC selection weights
23186 PARAMETER ( Max_pro_2 = 16 )
23187 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23188 & MH_acc_1,MH_acc_2
23189 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23190 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23191 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23192 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23193 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23194 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23196 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23197 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23198 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23200 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23201 DIMENSION PDA(-6:6),PDB(-6:6)
23204 C set hard scale QQ for alpha and partondistr.
23205 IF ( NQQAL.EQ.1 ) THEN
23207 ELSEIF ( NQQAL.EQ.2 ) THEN
23208 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23209 ELSEIF ( NQQAL.EQ.3 ) THEN
23210 QQAL = AQQAL*X1*X2*ECMP*ECMP
23211 ELSEIF ( NQQAL.EQ.4 ) THEN
23212 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23214 IF ( NQQPD.EQ.1 ) THEN
23216 ELSEIF ( NQQPD.EQ.2 ) THEN
23217 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23218 ELSEIF ( NQQPD.EQ.3 ) THEN
23219 QQPD = AQQPD*X1*X2*ECMP*ECMP
23220 ELSEIF ( NQQPD.EQ.4 ) THEN
23221 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23223 C coupling constants, PDFs
23225 ALPHA1 = PHO_ALPHAS(QQAL,3)
23227 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23228 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23229 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23230 PDS = PDA(0)*PDB(0)
23237 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23238 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23239 S4 = S4+PDA(I)+PDA(-I)
23240 S5 = S5+PDB(I)+PDB(-I)
23242 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23244 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23245 PDS = PDA(0)*S5+PDB(0)*S4
23246 ELSE IF(MSPR.EQ.7) THEN
23248 ELSE IF(MSPR.EQ.8) THEN
23249 PDS = S4*S5-(S2+S3)
23252 ELSE IF(MSPR.LT.12) THEN
23253 ALPHA2 = PHO_ALPHAS(QQAL,2)
23254 IF(IDPDG1.EQ.22) THEN
23255 ALPHA1 = pho_alphae(QQAL)
23256 ELSE IF(IDPDG1.EQ.990) THEN
23257 ALPHA1 = PARMDL(74)
23259 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23263 S4 = S4+PDB(I)+PDB(-I)
23265 * IF(MOD(I,2).EQ.0) THEN
23266 * S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23268 * S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23270 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23272 IF(MSPR.EQ.10) THEN
23273 IF(IDPDG1.EQ.990) THEN
23281 ELSE IF(MSPR.LT.14) THEN
23282 ALPHA1 = PHO_ALPHAS(QQAL,1)
23283 IF(IDPDG2.EQ.22) THEN
23284 ALPHA2 = pho_alphae(QQAL)
23285 ELSE IF(IDPDG2.EQ.990) THEN
23286 ALPHA2 = PARMDL(74)
23288 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23292 S4 = S4+PDA(I)+PDA(-I)
23294 * IF(MOD(I,2).EQ.0) THEN
23295 * S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23297 * S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23299 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23301 IF(MSPR.EQ.12) THEN
23302 IF(IDPDG2.EQ.990) THEN
23310 ELSE IF(MSPR.EQ.14) THEN
23311 SSR = X1*X2*ECMP*ECMP
23312 IF(IDPDG1.EQ.22) THEN
23313 ALPHA1 = pho_alphae(SSR)
23314 ELSE IF(IDPDG1.EQ.990) THEN
23315 ALPHA1 = PARMDL(74)
23317 IF(IDPDG2.EQ.22) THEN
23318 ALPHA2 = pho_alphae(SSR)
23319 ELSE IF(IDPDG2.EQ.990) THEN
23320 ALPHA2 = PARMDL(74)
23324 WRITE(LO,'(/1X,A,I4)')
23325 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23330 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23333 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23334 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23335 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23339 CDECK ID>, PHO_HARSCA
23340 SUBROUTINE PHO_HARSCA(IMODE,IP)
23341 C***********************************************************************
23343 C PHO_HARSCA determines the type of hard subprocess, the partons
23344 C taking part in this subprocess and the kinematic variables
23346 C input: IMODE 1 direct processes
23347 C 2 resolved processes
23348 C -1 initialization
23349 C -2 output of statistics
23350 C IP 1-4 particle combination (hadron/photon)
23352 C***********************************************************************
23353 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23356 PARAMETER( EPS = 1.D-10,
23359 C input/output channels
23361 COMMON /POINOU/ LI,LO
23362 C event debugging information
23364 PARAMETER (NMAXD=100)
23365 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23366 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23367 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23368 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23369 C model switches and parameters
23371 INTEGER ISWMDL,IPAMDL
23372 DOUBLE PRECISION PARMDL
23373 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23374 C internal rejection counters
23376 PARAMETER (NMXJ=60)
23377 CHARACTER*10 REJTIT
23379 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23380 C hard scattering parameters used for most recent hard interaction
23382 DOUBLE PRECISION ALQCD2,BQCD
23383 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23384 C data of c.m. system of Pomeron / Reggeon exchange
23385 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23386 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23387 & SIDP,CODP,SIFP,COFP
23388 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23389 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23390 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23391 C names of hard scattering processes
23393 PARAMETER ( Max_pro_1 = 16 )
23395 COMMON /POHPRO/ PROC(0:Max_pro_1)
23396 C data on most recent hard scattering
23397 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23398 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23399 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23400 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23401 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23402 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23403 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23404 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23405 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23406 C hard scattering data
23408 PARAMETER ( MSCAHD = 50 )
23409 INTEGER LSCAHD,LSC1HD,LSIDX,
23410 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23411 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23412 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23413 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23414 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23415 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23416 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23417 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23418 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23419 C hard cross sections and MC selection weights
23421 PARAMETER ( Max_pro_2 = 16 )
23422 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23423 & MH_acc_1,MH_acc_2
23424 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23425 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23426 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23427 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23428 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23429 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23431 INTEGER IPFIL,IFAFIL,IFBFIL
23432 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23433 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23434 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23435 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23436 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23437 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23438 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23439 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23440 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23441 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23442 & IPFIL,IFAFIL,IFBFIL
23444 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23445 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23446 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23450 C resolved processes
23451 IF(IMODE.EQ.2) THEN
23453 MH_pro_on(0,IP) = 0
23456 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23458 IF(HWgx(9).LT.DEPS) THEN
23459 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23460 & 'no resolved process possible for IP',IP,HWgx(9)
23464 C ----------------------------------------------I
23465 C begin of iteration loop (resolved processes) I
23470 IF(IREJSC.GT.1000) THEN
23471 WRITE(LO,'(/1X,A,I10)')
23472 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23477 B = DT_RNDM(X1)*HWgx(9)
23481 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23482 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23484 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23485 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23487 C find kin. variables X1,X2 and V
23488 CALL PHO_HARKIN(IREJ)
23490 IFAIL(29) = IFAIL(29)+1
23493 C calculate remaining distribution
23494 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23495 C actualize counter for cross-section calculation
23496 if(F.LE.1.D-15) then
23500 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23501 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23502 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23503 C check F against FMAX
23504 WEIGHT = F/(HWgx(MSPR)+DEPS)
23505 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23506 C-------------------------------------------------------------------
23507 IF(WEIGHT.GT.1.D0) THEN
23508 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23509 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23510 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23511 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23512 & ECMP,PTWANT,AS,AH,PT
23513 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23514 & ETAC,ETAD,X1,X2,V
23515 CALL PHO_PREVNT(-1)
23517 C-------------------------------------------------------------------
23519 C end of iteration loop (resolved processes) I
23520 C --------------------------------------------I
23522 C*********************************************************************
23526 ELSE IF(IMODE.EQ.1) THEN
23528 C single-resolved processes kinematically forbidden
23529 if(Z1DIF.lt.0.D0) then
23537 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23539 IF(MH_pro_on(M,IP).EQ.1) then
23540 if((M.eq.10).or.(M.eq.11)) then
23541 fac = FSUH(1)*FSUP(2)
23542 else if((M.eq.12).or.(M.eq.13)) then
23543 fac = FSUP(1)*FSUH(2)
23545 fac = FSUH(1)*FSUH(2)
23547 HWgx(15) = HWgx(15)+HWgx(M)*fac
23552 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23555 IF(HWgx(15).LT.DEPS) THEN
23556 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23557 & 'no direct/single-resolved process possible (IP)',IP
23561 C ----------------------------------------------I
23562 C begin of iteration loop (direct processes) I
23567 IF(IREJSC.GT.1000) THEN
23568 WRITE(LO,'(/1X,A,I10)')
23569 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23574 B = DT_RNDM(X1)*HWgx(15)
23577 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23580 IF(MH_pro_on(MSPR,IP).EQ.1) then
23581 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23582 fac = FSUH(1)*FSUP(2)
23583 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23584 fac = FSUP(1)*FSUH(2)
23586 fac = FSUH(1)*FSUH(2)
23588 SUM = SUM+HWgx(MSPR)*fac
23590 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23594 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23595 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23598 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23599 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23601 C find kin. variables X1,X2 and V
23602 CALL PHO_HARKIN(IREJ)
23604 IFAIL(28) = IFAIL(28)+1
23608 C calculate remaining distribution
23609 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23611 C counter for cross-section calculation
23612 if(F.LE.1.D-15) then
23616 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23617 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23618 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23619 C check F against FMAX
23620 WEIGHT = F/(HWgx(MSPR)+DEPS)
23621 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23622 C-------------------------------------------------------------------
23623 IF(WEIGHT.GT.1.D0) THEN
23624 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23625 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23626 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23627 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23628 & ECMP,PTWANT,AS,AH,PT
23629 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23630 & ETAC,ETAD,X1,X2,V
23631 CALL PHO_PREVNT(-1)
23633 C-------------------------------------------------------------------
23635 C end of iteration loop (direct processes) I
23636 C --------------------------------------------I
23638 ELSE IF(IMODE.EQ.-1) THEN
23640 C initialize cross section calculations
23642 DO 40 M=-1,Max_pro_2
23644 * XSECT(I,M) = 0.D0
23653 IF(IDEB(78).GE.0) THEN
23654 C *** Commented by Chiara
23655 C WRITE(LO,'(/1X,A,/1X,A)')
23656 C & 'PHO_HARSCA: activated hard processes',
23657 C & '------------------------------------'
23658 C WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23659 DO 42 M=1,Max_pro_2
23660 C WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23661 C & (MH_pro_on(M,J),J=1,4)
23666 ELSE IF(IMODE.EQ.-2) THEN
23668 C calculation of process statistics
23682 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23683 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23684 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23687 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23688 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23689 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23692 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23693 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23694 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23696 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23697 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23698 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23701 IF(IDEB(78).GE.1) THEN
23702 WRITE(LO,'(/1X,A,/1X,A)')
23703 & 'PHO_HARSCA: internal rejection statistics',
23704 & '-----------------------------------------'
23706 IF(MH_tried(0,K).GT.0) THEN
23707 WRITE(LO,'(5X,A,I3)')
23708 & 'process (sampled/accepted) for IP:',K
23710 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23711 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23712 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23720 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23721 & 'unsupported mode',IMODE
23725 C the event is accepted now
23726 C actualize counter for accepted events
23727 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23728 IF(MSPR.EQ.-1) MSPR = 3
23730 C find flavor of initial partons
23733 SCHECK = DT_RNDM(SUM)*PDS-EPS
23734 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23737 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23739 IF ( IA.EQ.0 ) GOTO 610
23740 SUM = SUM+PDF1(IA)*PDF2(-IA)
23741 IF ( SUM.GE.SCHECK ) GOTO 620
23744 ELSEIF ( MSPR.EQ.3 ) THEN
23747 IF ( IA.EQ.0 ) GOTO 630
23748 SUM = SUM+PDF1(0)*PDF2(IA)
23749 IF ( SUM.GE.SCHECK ) GOTO 640
23750 SUM = SUM+PDF1(IA)*PDF2(0)
23751 IF ( SUM.GE.SCHECK ) GOTO 650
23756 ELSEIF ( MSPR.EQ.7 ) THEN
23758 IF ( IA.EQ.0 ) GOTO 660
23759 SUM = SUM+PDF1(IA)*PDF2(IA)
23760 IF ( SUM.GE.SCHECK ) GOTO 670
23763 ELSEIF ( MSPR.EQ.8 ) THEN
23765 IF ( IA.EQ.0 ) GOTO 690
23767 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23768 SUM = SUM+PDF1(IA)*PDF2(IB)
23769 IF ( SUM.GE.SCHECK ) GOTO 700
23773 ELSEIF ( MSPR.EQ.10 ) THEN
23776 IF ( IB.NE.0 ) THEN
23777 IF(IDPDG1.EQ.22) THEN
23778 * IF(MOD(ABS(IB),2).EQ.0) THEN
23779 * SUM = SUM+PDF2(IB)*4.D0/9.D0
23781 * SUM = SUM+PDF2(IB)*1.D0/9.D0
23783 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23787 IF ( SUM.GE.SCHECK ) GOTO 720
23791 ELSEIF ( MSPR.EQ.12 ) THEN
23794 IF ( IA.NE.0 ) THEN
23795 IF(IDPDG2.EQ.22) THEN
23796 * IF(MOD(ABS(IA),2).EQ.0) THEN
23797 * SUM = SUM+PDF1(IA)*4.D0/9.D0
23799 * SUM = SUM+PDF1(IA)*1.D0/9.D0
23801 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23805 IF ( SUM.GE.SCHECK ) GOTO 820
23809 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23814 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23815 print LO,'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23816 print LO,'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23820 C find flavour of final partons
23824 IF ( MSPR.EQ.2 ) THEN
23827 ELSEIF ( MSPR.EQ.4 ) THEN
23828 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23829 IF ( IC.GT.NF ) IC = NF-IC
23831 ELSEIF ( MSPR.EQ.6 ) THEN
23832 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23833 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23834 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23836 ELSEIF ( MSPR.EQ.11) THEN
23839 IF ( IC.NE.0 ) THEN
23840 IF(IDPDG1.EQ.22) THEN
23841 * IF(MOD(ABS(IC),2).EQ.0) THEN
23846 SUM = SUM + Q_ch2(IC)
23852 SCHECK = DT_RNDM(SUM)*SUM-EPS
23855 IF ( IC.NE.0 ) THEN
23856 IF(IDPDG1.EQ.22) THEN
23857 * IF(MOD(ABS(IC),2).EQ.0) THEN
23862 SUM = SUM + Q_ch2(IC)
23866 IF ( SUM.GE.SCHECK ) GOTO 750
23871 ELSEIF ( MSPR.EQ.12) THEN
23874 ELSEIF ( MSPR.EQ.13) THEN
23877 IF ( IC.NE.0 ) THEN
23878 IF(IDPDG2.EQ.22) THEN
23879 * IF(MOD(ABS(IC),2).EQ.0) THEN
23884 SUM = SUM + Q_ch2(IC)
23890 SCHECK = DT_RNDM(SUM)*SUM-EPS
23893 IF ( IC.NE.0 ) THEN
23894 IF(IDPDG2.EQ.22) THEN
23895 * IF(MOD(ABS(IC),2).EQ.0) THEN
23900 SUM = SUM + Q_ch2(IC)
23904 IF ( SUM.GE.SCHECK ) GOTO 850
23909 ELSEIF ( MSPR.EQ.14) THEN
23914 IF(MOD(ABS(IC),2).EQ.0) THEN
23915 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23916 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23918 SUM = SUM + FAC1*FAC2
23920 IF(IPAMDL(64).NE.0) THEN
23921 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23923 SCHECK = DT_RNDM(SUM)*SUM-EPS
23928 IF(MOD(ABS(IC),2).EQ.0) THEN
23929 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23930 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23932 SUM = SUM + FAC1*FAC2
23933 IF ( SUM.GE.SCHECK ) GOTO 950
23938 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23943 XM3 = PHO_PMASS(IC,3)
23948 XM4 = PHO_PMASS(ID,3)
23950 IF(ABS(IC).EQ.15) GOTO 955
23952 C valence quarks involved?
23955 IF(IDPDG1.EQ.22) THEN
23956 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23957 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23959 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23964 IF(IDPDG2.EQ.22) THEN
23965 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23966 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23968 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23972 C fill event record
23975 CALL PHO_SFECFE(SINPHI,COSPHI)
23989 PHO1(1) = PT*COSPHI
23990 PHO1(2) = PT*SINPHI
23991 PHO1(3) = -ECM2*(U*X1-V*X2)
23992 PHO1(4) = -ECM2*(U*X1+V*X2)
23996 PHO2(3) = -ECM2*(V*X1-U*X2)
23997 PHO2(4) = -ECM2*(V*X1+U*X2)
24000 C convert to mass shell
24001 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
24003 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
24004 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
24008 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
24011 IF(IDEB(78).GE.20) THEN
24012 SHAT = X1*X2*ECMP*ECMP
24013 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
24015 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
24016 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
24017 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
24018 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
24019 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
24020 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
24025 CDECK ID>, PHO_HARFAC
24026 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24027 C*********************************************************************
24029 C initialization: find scaling factors and maxima of remaining
24032 C input: PTCUT transverse momentum cutoff
24035 C output: Hfac(-1:Max_pro_2) field for sampling hard processes
24037 C*********************************************************************
24038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24041 PARAMETER ( MXABWT = 96 )
24043 C input/output channels
24045 COMMON /POINOU/ LI,LO
24046 C data of c.m. system of Pomeron / Reggeon exchange
24047 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24048 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24049 & SIDP,CODP,SIFP,COFP
24050 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24051 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24052 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24054 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24055 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24056 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24057 C hard scattering parameters used for most recent hard interaction
24059 DOUBLE PRECISION ALQCD2,BQCD
24060 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24061 C integration precision for hard cross sections (obsolete)
24062 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24063 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24064 C data on most recent hard scattering
24065 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24066 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24067 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24068 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24069 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24070 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24071 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24072 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24073 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24074 C hard cross sections and MC selection weights
24076 PARAMETER ( Max_pro_2 = 16 )
24077 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24078 & MH_acc_1,MH_acc_2
24079 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24080 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24081 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24082 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24083 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24084 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24086 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24087 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24088 & F124(-1:Max_pro_2)
24089 DATA F124 / 1.D0,0.D0,
24090 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24091 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24094 AH = (2.D0*PTCUT/ECMI)**2
24098 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24099 DO 10 M=-1,Max_pro_2
24103 C resolved processes
24112 Z2 = (1.D0-Z1)*ABSZ(I2)
24115 W = SQRT(1.D0-FAXX)
24125 VA =-0.5D0*W1/(W1+Z*W)
24127 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24129 VC =-EXP(HLN+Z*WLOG)
24131 VE =-0.5D0*(1.D0+W)+Z*W
24133 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24135 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24137 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24138 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24139 & (8./27.)*UA*UA*VA)*WEIG(I)
24140 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24141 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24142 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24143 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24144 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24146 S(4) = S(2)*(9./32.)
24148 S2(M) = S2(M)+S(M)*WEIG(I2)*W
24152 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24156 S1(6) = S1(6)*MAX(0,NF-1)
24159 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24160 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24165 W = SQRT(1.D0-FAXX)
24168 WL = LOG(FAXX/(1.D0+W)**2)
24170 FWW2 = FAXX*WLOG/ALN
24177 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24179 VB =-EXP(HLN+Z*WLOG)
24181 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24182 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24185 S1(M) = S1(M)+S(M)*WEIG(I1)
24190 C quark charges fractions
24191 IF(IDPDG1.EQ.22) THEN
24194 CHRNF = CHRNF + Q_ch2(I)
24196 S1(11) = S1(11)*CHRNF
24197 ELSE IF(IDPDG1.EQ.990) THEN
24202 IF(IDPDG2.EQ.22) THEN
24205 CHRNF = CHRNF + Q_ch2(I)
24207 S1(13) = S1(13)*CHRNF
24208 ELSE IF(IDPDG2.EQ.990) THEN
24216 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24217 DO 90 M=-1,Max_pro_2
24218 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24221 C double direct process
24222 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24223 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24226 IF(IDPDG1.EQ.22) THEN
24231 IF(IDPDG2.EQ.22) THEN
24236 FAC = FAC+F1*F2*3.D0
24238 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24239 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24244 CDECK ID>, PHO_HARWGX
24245 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24246 C**********************************************************************
24248 C find maximum of remaining weight for MC sampling
24250 C input: PTCUT transverse momentum cutoff
24253 C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24255 C**********************************************************************
24256 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24259 PARAMETER ( NKM = 10 )
24260 PARAMETER ( TINY = 1.D-20 )
24262 C input/output channels
24264 COMMON /POINOU/ LI,LO
24265 C event debugging information
24267 PARAMETER (NMAXD=100)
24268 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24269 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24270 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24271 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24272 C data on most recent hard scattering
24273 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24274 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24275 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24276 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24277 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24278 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24279 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24280 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24281 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24282 C hard cross sections and MC selection weights
24284 PARAMETER ( Max_pro_2 = 16 )
24285 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24286 & MH_acc_1,MH_acc_2
24287 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24288 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24289 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24290 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24291 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24292 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24294 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24295 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24296 DIMENSION IFTAB(-1:Max_pro_2)
24297 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24300 AH = (2.D0*PTCUT/ECM)**2
24322 C start configuration
24324 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24330 ELSE IF(IST.EQ.2) THEN
24337 ELSE IF(IST.EQ.3) THEN
24338 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24344 ELSE IF(IST.EQ.4) THEN
24345 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24353 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24354 C process possible?
24355 IF(F2.LE.0.D0) GOTO 35
24363 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24364 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24365 IF ( F2.GT.F3 ) D(I) =-D(I)
24370 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24371 IF ( F3.GT.F2 ) GOTO 20
24373 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24374 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24375 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24376 IF ( F1.LE.F2 ) Z(I) = ZZ
24379 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24381 IF(F2.GT.FF(NKON)) THEN
24382 FF(NKON) = MAX(F2,0.D0)
24401 IF(IDEB(38).GE.5) THEN
24402 WRITE(LO,'(/1X,A)')
24403 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24405 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24406 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24407 & DMX(2,I),DMX(3,I)
24411 DO 70 I=-1,Max_pro_2
24412 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24416 IF(IDEB(38).GE.5) THEN
24417 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24418 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24419 DO 80 I=-1,Max_pro_2
24420 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24422 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24423 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24425 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24426 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24433 CDECK ID>, PHO_HARWGI
24434 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24435 C**********************************************************************
24437 C auxiliary subroutine to find maximum of remaining weight
24439 C input: ECMX current CMS energy
24440 C PTCUT current pt cutoff
24441 C NKON process label 1..5 resolved
24442 C 6..7 direct particle 1
24443 C 8..9 direct particle 2
24445 C Z(3) transformed variable
24447 C output: remaining weight
24449 C**********************************************************************
24450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24455 PARAMETER ( NKM = 10 )
24456 PARAMETER ( TINY = 1.D-30,
24459 C input/output channels
24461 COMMON /POINOU/ LI,LO
24462 C event debugging information
24464 PARAMETER (NMAXD=100)
24465 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24466 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24467 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24468 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24469 C model switches and parameters
24471 INTEGER ISWMDL,IPAMDL
24472 DOUBLE PRECISION PARMDL
24473 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24474 C data of c.m. system of Pomeron / Reggeon exchange
24475 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24476 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24477 & SIDP,CODP,SIFP,COFP
24478 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24479 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24480 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24481 C currently activated parton density parametrizations
24483 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24484 DOUBLE PRECISION PDFLAM,PDFQ2M
24485 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24486 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24487 C hard scattering parameters used for most recent hard interaction
24489 DOUBLE PRECISION ALQCD2,BQCD
24490 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24491 C some hadron information, will be deleted in future versions
24493 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24494 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24495 C scale parameters for parton model calculations
24496 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24497 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24498 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24499 & NQQAL,NQQALI,NQQALF,NQQPD
24500 C data on most recent hard scattering
24501 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24502 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24503 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24504 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24505 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24506 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24507 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24508 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24509 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24511 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24512 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24516 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24517 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24518 C check input values
24519 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24520 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24521 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24523 Y1 = EXP(ALNH*Z(1))
24525 C resolved kinematic
24526 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24527 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24529 X1 = MIN(X1,0.999999999999D0)
24530 X2 = MIN(X2,0.999999999999D0)
24531 ELSE IF(NKON.LE.7) THEN
24532 C direct kinematic 1
24534 X2 = MIN(Y1,0.999999999999D0)
24535 ELSE IF(NKON.LE.9) THEN
24536 C direct kinematic 2
24537 X1 = MIN(Y1,0.999999999999D0)
24540 C double direct kinematic
24544 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24545 V =-0.5D0+W*(Z(3)-0.5D0)
24547 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24549 C set hard scale QQ for alpha and partondistr.
24550 IF ( NQQAL.EQ.1 ) THEN
24552 ELSEIF ( NQQAL.EQ.2 ) THEN
24553 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24554 ELSEIF ( NQQAL.EQ.3 ) THEN
24555 QQAL = AQQAL*Y1*ECMX*ECMX
24556 ELSEIF ( NQQAL.EQ.4 ) THEN
24557 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24559 IF ( NQQPD.EQ.1 ) THEN
24561 ELSEIF ( NQQPD.EQ.2 ) THEN
24562 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24563 ELSEIF ( NQQPD.EQ.3 ) THEN
24564 QQPD = AQQPD*Y1*ECMX*ECMX
24565 ELSEIF ( NQQPD.EQ.4 ) THEN
24566 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24573 C resolved processes
24574 ALPHA1 = PHO_ALPHAS(QQAL,3)
24576 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24577 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24578 C calculate full distribution FDIS
24580 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24581 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24582 F(4) = F(4)+PDA(I)+PDA(-I)
24583 F(5) = F(5)+PDB(I)+PDB(-I)
24585 F(1) = PDA(0)*PDB(0)
24586 T = PDA(0)*F(5)+PDB(0)*F(4)
24587 F(5) = F(4)*F(5)-(F(2)+F(3))
24589 ELSE IF(NKON.LE.7) THEN
24590 C direct processes particle 1
24591 IF(IDPDG1.EQ.22) THEN
24592 ALPHA1 = pho_alphae(QQAL)
24595 ELSE IF(IDPDG1.EQ.990) THEN
24596 ALPHA1 = PARMDL(74)
24603 ALPHA2 = PHO_ALPHAS(QQAL,2)
24604 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24607 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24610 ELSE IF(NKON.LE.9) THEN
24611 C direct processes particle 2
24612 ALPHA1 = PHO_ALPHAS(QQAL,1)
24613 IF(IDPDG2.EQ.22) THEN
24614 ALPHA2 = pho_alphae(QQAL)
24617 ELSE IF(IDPDG2.EQ.990) THEN
24618 ALPHA2 = PARMDL(74)
24625 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24628 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24632 C double direct process
24634 IF(IDPDG1.EQ.22) THEN
24635 ALPHA1 = pho_alphae(SSR)
24636 ELSE IF(IDPDG1.EQ.990) THEN
24637 ALPHA1 = PARMDL(74)
24642 IF(IDPDG2.EQ.22) THEN
24643 ALPHA2 = pho_alphae(SSR)
24644 ELSE IF(IDPDG2.EQ.990) THEN
24645 ALPHA2 = PARMDL(74)
24653 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24656 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24657 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24658 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24662 CDECK ID>, PHO_HARINI
24663 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24664 C**********************************************************************
24666 C initialize calculation of hard cross section
24668 C must not be called during MC generation
24670 C***********************************************************************
24671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24674 PARAMETER ( DEPS = 1.D-10 )
24676 C input/output channels
24678 COMMON /POINOU/ LI,LO
24679 C event debugging information
24681 PARAMETER (NMAXD=100)
24682 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24683 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24684 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24685 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24686 C model switches and parameters
24688 INTEGER ISWMDL,IPAMDL
24689 DOUBLE PRECISION PARMDL
24690 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24691 C currently activated parton density parametrizations
24693 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24694 DOUBLE PRECISION PDFLAM,PDFQ2M
24695 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24696 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24698 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24699 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24700 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24701 C scale parameters for parton model calculations
24702 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24703 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24704 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24705 & NQQAL,NQQALI,NQQALF,NQQPD
24706 C data of c.m. system of Pomeron / Reggeon exchange
24707 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24708 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24709 & SIDP,CODP,SIFP,COFP
24710 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24711 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24712 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24713 C obsolete cut-off information
24714 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24715 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24716 C hard scattering parameters used for most recent hard interaction
24718 DOUBLE PRECISION ALQCD2,BQCD
24719 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24721 double precision pho_alphas
24725 C set local Pomeron c.m. system data
24731 CALL PHO_ACTPDF(IDPDG1,1)
24732 CALL PHO_ACTPDF(IDPDG2,2)
24733 C initialize alpha_s calculation
24734 DUMMY = PHO_ALPHAS(0.D0,-4)
24735 C initialize scales with defaults
24736 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24737 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24739 AQQALI = PARMDL(86)
24740 AQQALF = PARMDL(89)
24743 NQQALI = IPAMDL(86)
24744 NQQALF = IPAMDL(89)
24748 AQQALI = PARMDL(85)
24749 AQQALF = PARMDL(88)
24752 NQQALI = IPAMDL(85)
24753 NQQALF = IPAMDL(88)
24756 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24758 AQQALI = PARMDL(85)
24759 AQQALF = PARMDL(88)
24762 NQQALI = IPAMDL(85)
24763 NQQALF = IPAMDL(88)
24767 AQQALI = PARMDL(84)
24768 AQQALF = PARMDL(87)
24771 NQQALI = IPAMDL(84)
24772 NQQALF = IPAMDL(87)
24775 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24776 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24777 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24778 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24779 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24780 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24781 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24782 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24783 AQQAL = PARMDL(109+IP)
24784 AQQALI = PARMDL(113+IP)
24785 AQQALF = PARMDL(117+IP)
24786 AQQPD = PARMDL(121+IP)
24787 NQQAL = IPAMDL(64+IP)
24788 NQQALI = IPAMDL(68+IP)
24789 NQQALF = IPAMDL(72+IP)
24790 NQQPD = IPAMDL(76+IP)
24791 PTCUT(1) = PARMDL(36)
24792 PTCUT(2) = PARMDL(37)
24793 PTCUT(3) = PARMDL(38)
24794 PTCUT(4) = PARMDL(39)
24795 PTANO(1) = PARMDL(130)
24796 PTANO(2) = PARMDL(131)
24797 PTANO(3) = PARMDL(132)
24798 PTANO(4) = PARMDL(133)
24799 RFLAG = '(energy-independent)'
24800 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24802 C write out all settings
24803 C *** Commented by Chiara
24804 C IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24805 C WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24806 C & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24807 C & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24808 C & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24810 C & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24811 C & 5X,'particle 1 / particle 2:',2I8,/,
24812 C & 5X,'min. PT :',F7.1,2X,A,/,
24813 C & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24814 C & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24815 C & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24816 C & 5X,'max. number of active flavours NF :',I3,/,
24817 C & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24822 CDECK ID>, PHO_HARINT
24823 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24824 C**********************************************************************
24826 C interpolate cross sections and weights for hard scattering
24828 C input: IPP particle combination (neg. for add. user cuts)
24829 C ECM CMS energy (GeV)
24830 C P2V1/2 particle virtualities (pos., GeV**2)
24831 C I1 first subprocess to calculate
24832 C I2 last subprocess to calculate
24833 C <-1 only scales and cutoffs calculated
24834 C K1 first variable to calculate
24835 C K2 last variable to calculate
24836 C MSPOM cross sections to use for pt distribution
24840 C for K1 < 3 the soft pt distribution is also calculated
24842 C output: interpolated values in HWgx, HSig, Hdpt
24844 C***********************************************************************
24845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24848 PARAMETER ( DEPS = 1.D-15,
24851 C input/output channels
24853 COMMON /POINOU/ LI,LO
24854 C event debugging information
24856 PARAMETER (NMAXD=100)
24857 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24858 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24859 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24860 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24861 C model switches and parameters
24863 INTEGER ISWMDL,IPAMDL
24864 DOUBLE PRECISION PARMDL
24865 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24866 C Reggeon phenomenology parameters
24867 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24868 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24869 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24870 & ALREG,ALREGP,GR(2),B0REG(2),
24871 & GPPP,GPPR,B0PPP,B0PPR,
24872 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24873 C parameters of 2x2 channel model
24874 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24875 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24876 C data needed for soft-pt calculation
24877 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24878 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24879 C scale parameters for parton model calculations
24880 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24881 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24882 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24883 & NQQAL,NQQALI,NQQALF,NQQPD
24884 C obsolete cut-off information
24885 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24886 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24887 C event weights and generated cross section
24888 INTEGER IPOWGC,ISWCUT,IVWGHT
24889 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24890 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24891 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24892 C parameters for DGLAP backward evolution in ISR
24894 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24895 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24896 C hard cross sections and MC selection weights
24898 PARAMETER ( Max_pro_2 = 16 )
24899 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24900 & MH_acc_1,MH_acc_2
24901 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24902 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24903 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24904 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24905 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24906 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24907 C interpolation tables for hard cross section and MC selection weights
24908 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24909 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24910 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24911 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24912 & HQ2a_tab,HQ2b_tab,HEcm_tab
24914 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24915 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24916 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24917 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24918 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24919 & HEcm_tab(1:Max_tab_E,0:4),
24920 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24921 C data on most recent hard scattering
24922 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24923 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24924 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24925 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24926 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24927 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24928 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24929 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24930 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24931 C energy-interpolation table
24933 PARAMETER ( IEETA2 = 20 )
24935 DOUBLE PRECISION SIGTAB,SIGECM
24936 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24938 DOUBLE PRECISION XP,PTS
24939 DIMENSION XP(2),PTS(0:2,2)
24944 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24945 & 'PHO_HARINT: called with ',
24946 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24947 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24951 C default minimum bias cutoff
24952 PTCUT(IP) = pho_ptcut(ECM,IP)
24954 C user defined additional cutoff
24955 PTCUT(IP) = HSWCUT(4+IP)
24960 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24961 Q2MISR(1) = MAX(P2V1,Q2CUT)
24962 Q2MISR(2) = MAX(P2V2,Q2CUT)
24963 C cutoff for direct photon contribution to photon PDF
24964 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24966 C scales for hard scattering
24967 AQQAL = PARMDL(109+IP)
24968 AQQALI = PARMDL(113+IP)
24969 AQQALF = PARMDL(117+IP)
24970 AQQPD = PARMDL(121+IP)
24971 NQQAL = IPAMDL(64+IP)
24972 NQQALI = IPAMDL(68+IP)
24973 NQQALF = IPAMDL(72+IP)
24974 NQQPD = IPAMDL(76+IP)
24975 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24976 & 'PHO_HARINT: scales:',
24977 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24979 IF(I2.LT.-1) RETURN
24982 IF(IPP.LT.0) IL = 0
24984 C double-log interpolation
24985 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24996 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
25000 fac = LOG(ECM/HEcm_tab(I-1,IL))
25001 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
25003 C factor due to phase space integration
25004 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25005 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
25006 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
25008 IF(XX.LT.DEPS2) XX = 0.D0
25011 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25012 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
25013 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
25015 IF(XX.LT.DEPS2) XX = 0.D0
25017 C hard cross section
25018 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25019 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
25020 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
25022 IF(XX.LT.DEPS2) XX = 0.D0
25024 C differential hard cross section
25025 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25026 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
25027 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
25029 IF(XX.LT.DEPS2) XX = 0.D0
25034 IF((K1.LT.3).AND.(K2.GE.3)) THEN
25036 IF((I1.GT.9).OR.(I2.LT.9)) THEN
25037 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
25038 & 'hard cross section not calculated ',I1,I2
25042 C load soft cross sections from interpolation table
25043 IF(ECM.LE.SIGECM(IP,1)) THEN
25046 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
25048 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
25054 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25055 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25056 & IP,ECM,SIGECM(IP,ISIMAX)
25057 CALL PHO_PREVNT(-1)
25062 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25063 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25065 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25066 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25070 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25076 IF(IDEB(58).GE.15) THEN
25077 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25078 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25079 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25081 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25082 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25088 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25089 C***********************************************************************
25091 C calculate energy-dependent transverse momentum cutoff
25093 C***********************************************************************
25099 double precision ECM
25102 C input/output channels
25104 COMMON /POINOU/ LI,LO
25105 C event debugging information
25107 PARAMETER (NMAXD=100)
25108 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25109 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25110 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25111 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25112 C model switches and parameters
25114 INTEGER ISWMDL,IPAMDL
25115 DOUBLE PRECISION PARMDL
25116 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25118 pho_ptcut = PARMDL(35+IP)
25120 IF(IPAMDL(7).EQ.1) THEN
25121 C Bopp et al. type (DPMJET)
25122 pho_ptcut = PARMDL(35+IP)
25123 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25124 ELSE IF(IPAMDL(7).EQ.2) THEN
25125 C Gribov-Levin-Ryskin type
25126 pho_ptcut = PARMDL(35+IP)
25127 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25132 CDECK ID>, PHO_HARMCI
25133 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25134 C**********************************************************************
25136 C initialize MC sampling and calculate hard cross section
25138 C input: IP particle combination (neg. number for user cut)
25139 C EMAXF maximum CMS energy for
25140 C interpolation table in reference to PTCUT(1..4)
25142 C***********************************************************************
25143 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25146 PARAMETER (DEPS = 1.D-10,
25149 C input/output channels
25151 COMMON /POINOU/ LI,LO
25152 C event debugging information
25154 PARAMETER (NMAXD=100)
25155 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25156 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25157 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25158 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25160 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25161 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25162 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25163 C global event kinematics and particle IDs
25164 INTEGER IFPAP,IFPAB
25165 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25166 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25167 C data of c.m. system of Pomeron / Reggeon exchange
25168 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25169 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25170 & SIDP,CODP,SIFP,COFP
25171 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25172 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25173 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25174 C model switches and parameters
25176 INTEGER ISWMDL,IPAMDL
25177 DOUBLE PRECISION PARMDL
25178 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25179 C obsolete cut-off information
25180 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25181 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25182 C scale parameters for parton model calculations
25183 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25184 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25185 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25186 & NQQAL,NQQALI,NQQALF,NQQPD
25187 C names of hard scattering processes
25189 PARAMETER ( Max_pro_1 = 16 )
25191 COMMON /POHPRO/ PROC(0:Max_pro_1)
25192 C hard cross sections and MC selection weights
25194 PARAMETER ( Max_pro_2 = 16 )
25195 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25196 & MH_acc_1,MH_acc_2
25197 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25198 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25199 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25200 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25201 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25202 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25203 C interpolation tables for hard cross section and MC selection weights
25204 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25205 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25206 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25207 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25208 & HQ2a_tab,HQ2b_tab,HEcm_tab
25210 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25211 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25212 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25213 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25214 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25215 & HEcm_tab(1:Max_tab_E,0:4),
25216 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25217 C event weights and generated cross section
25218 INTEGER IPOWGC,ISWCUT,IVWGHT
25219 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25220 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25221 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25224 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25226 C initialization for all pt cutoffs
25233 PTC = pho_ptcut(parmdl(19),I)
25236 C skip unassigned PTCUT
25237 IF(PTC.LT.0.5D0) GOTO 1000
25245 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25246 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25247 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25248 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25254 ELLOW = LOG(2.05*PTC)
25255 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25257 IF(DELTA.LE.0.D0) GOTO 1000
25259 C switch between external particles and Pomeron
25265 ELSE IF(I.EQ.3) THEN
25270 ELSE IF(I.EQ.2) THEN
25282 C initialize PT scales
25283 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25284 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25285 FPS(I) = PARMDL(105)
25286 FPH(I) = PARMDL(106)
25288 FPS(I) = PARMDL(103)
25289 FPH(I) = PARMDL(104)
25291 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25292 FPS(I) = PARMDL(103)
25293 FPH(I) = PARMDL(104)
25295 FPS(I) = PARMDL(101)
25296 FPH(I) = PARMDL(102)
25299 C initialize hard scattering
25301 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25303 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25306 C energy/virtuality grid
25307 do Ie=1,IH_Ecm_up(IL)
25308 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25310 do Ia=1,IH_Q2a_up(IL)
25311 HQ2a_tab(Ia,IL) = 0.D0
25313 do Ib=1,IH_Q2b_up(IL)
25314 HQ2b_tab(Ib,IL) = 0.D0
25317 C initialization for several energies and particle virtualities
25318 do Ie=1,IH_Ecm_up(IL)
25319 do Ia=1,IH_Q2a_up(IL)
25320 do Ib=1,IH_Q2b_up(IL)
25322 EE = HEcm_tab(IE,IL)
25323 Q2a = HQ2a_tab(Ia,IL)
25324 Q2b = HQ2b_tab(Ib,IL)
25325 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25326 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25327 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25328 & PTCUT(I),EE,IDPDG1,IDPDG2
25329 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25330 CALL PHO_HARFAC(PTCUT(I),EE)
25331 CALL PHO_HARWGX(PTCUT(I),EE)
25332 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25333 IF(IDEB(8).GE.10) THEN
25334 WRITE(LO,'(1X,A,/,1X,A)')
25335 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25336 & '------------------------------------------------'
25338 WRITE(LO,'(10X,A,1P2E14.4)')
25339 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25343 C store in interpolation tables
25344 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25345 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25347 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25348 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25349 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25350 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25353 C summed quantities
25354 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25355 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25357 IF(MH_pro_on(M,I).GT.0) THEN
25358 HSig_tab(9,IE,Ia,Ib,IL) =
25359 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25360 Hdpt_tab(9,IE,Ia,Ib,IL) =
25361 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25364 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25365 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25367 IF(MH_pro_on(M,I).GT.0) THEN
25368 HSig_tab(15,IE,Ia,Ib,IL) =
25369 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25370 Hdpt_tab(15,IE,Ia,Ib,IL) =
25371 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25374 HSig_tab(0,IE,Ia,Ib,IL) =
25375 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25376 Hdpt_tab(0,IE,Ia,Ib,IL) =
25377 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25383 C debug output of weights
25385 IF(IDEB(8).GE.5) THEN
25386 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25387 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25388 & IDPDG1,IDPDG2,IP,PTCUT(I),
25389 & '------------------------------------------'
25391 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25392 WRITE(LO,'(2X,A,I3,2I7)')
25393 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25395 do k=1,IH_Ecm_up(IL)
25396 do ia=1,IH_Q2a_up(IL)
25397 do ib=1,IH_Q2b_up(IL)
25398 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25399 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25400 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25401 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25411 CDECK ID>, PHO_HARXR3
25412 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25413 C**********************************************************************
25415 C differential cross section DSIG/(DETAC*DETAD*DPT)
25417 C input: ECMH CMS energy
25419 C ETAC pseudorapidity of parton C
25420 C ETAD pseudorapidity of parton D
25422 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25424 C**********************************************************************
25425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25428 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25430 PARAMETER ( Max_pro_2 = 16 )
25432 DIMENSION DSIGMC(0:Max_pro_2)
25433 DIMENSION DSIGM(0:Max_pro_2)
25435 C input/output channels
25437 COMMON /POINOU/ LI,LO
25439 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25440 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25441 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25442 C Reggeon phenomenology parameters
25443 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25444 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25445 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25446 & ALREG,ALREGP,GR(2),B0REG(2),
25447 & GPPP,GPPR,B0PPP,B0PPR,
25448 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25449 C currently activated parton density parametrizations
25451 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25452 DOUBLE PRECISION PDFLAM,PDFQ2M
25453 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25454 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25455 C hard scattering parameters used for most recent hard interaction
25457 DOUBLE PRECISION ALQCD2,BQCD
25458 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25459 C scale parameters for parton model calculations
25460 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25461 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25462 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25463 & NQQAL,NQQALI,NQQALF,NQQPD
25465 DOUBLE PRECISION PHO_ALPHAS
25466 DIMENSION PDA(-6:6),PDB(-6:6)
25469 DSIGMC(I) = CMPLX(0.D0,0.D0)
25475 C kinematic conversions
25476 XA = PT*(EC+ED)/ECMH
25478 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25479 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25482 SP = XA*XB*ECMH*ECMH
25488 C set hard scale QQ for alpha and partondistr.
25489 IF ( NQQAL.EQ.1 ) THEN
25491 ELSEIF ( NQQAL.EQ.2 ) THEN
25492 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25493 ELSEIF ( NQQAL.EQ.3 ) THEN
25495 ELSEIF ( NQQAL.EQ.4 ) THEN
25496 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25498 IF ( NQQPD.EQ.1 ) THEN
25500 ELSEIF ( NQQPD.EQ.2 ) THEN
25501 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25502 ELSEIF ( NQQPD.EQ.3 ) THEN
25504 ELSEIF ( NQQPD.EQ.4 ) THEN
25505 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25508 ALPHA = PHO_ALPHAS(QQAL,3)
25509 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25510 C parton distributions (times x)
25511 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25512 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25519 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25520 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25521 S4 = S4+PDA(I)+PDA(-I)
25522 S5 = S5+PDB(I)+PDB(-I)
25524 C partial cross sections (including color and symmetry factors)
25525 C resolved photon matrix elements (light quarks)
25526 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25527 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25528 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25529 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25530 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25531 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25532 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25533 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25534 & (8.D0/27.D0)/(UP*TP))
25536 DSIGM(1) = FACTOR*DSIGM(1)*S1
25537 DSIGM(2) = FACTOR*DSIGM(2)*S2
25538 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25539 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25540 DSIGM(5) = FACTOR*DSIGM(5)*S2
25541 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25542 DSIGM(7) = FACTOR*DSIGM(7)*S3
25543 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25546 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25549 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25550 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25551 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25555 CDECK ID>, PHO_HARXR2
25556 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25557 C**********************************************************************
25559 C differential cross section DSIG/(DETAC*DPT)
25561 C input: ECMH CMS energy
25563 C ETAC pseudorapidity of parton C
25565 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25567 C**********************************************************************
25568 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25571 PARAMETER ( TINY= 1.D-20 )
25573 PARAMETER ( Max_pro_2 = 16 )
25575 DIMENSION DSIGMC(0:Max_pro_2)
25577 C input/output channels
25579 COMMON /POINOU/ LI,LO
25580 C integration precision for hard cross sections (obsolete)
25581 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25582 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25585 DIMENSION DSIG1(0:Max_pro_2)
25586 DIMENSION ABSZ(32),WEIG(32)
25589 DSIGMC(M) = CMPLX(0.D0,0.D0)
25595 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25597 EDL =-LOG(ARG-1.D0/EC)
25599 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25601 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25603 PCTRL= DREAL(DSIG1(M))/TINY
25604 IF( PCTRL.GE.1.D0 ) THEN
25605 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25611 CDECK ID>, PHO_HARXD2
25612 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25613 C**********************************************************************
25615 C differential cross section DSIG/(DETAC*DPT) for direct processes
25617 C input: ECMH CMS energy of scattering system
25619 C ETAC pseudorapidity of parton C
25621 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25623 C**********************************************************************
25624 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25627 PARAMETER ( Max_pro_2 = 16 )
25629 DIMENSION DSIGMC(0:Max_pro_2)
25630 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25632 C input/output channels
25634 COMMON /POINOU/ LI,LO
25635 C model switches and parameters
25637 INTEGER ISWMDL,IPAMDL
25638 DOUBLE PRECISION PARMDL
25639 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25640 C data of c.m. system of Pomeron / Reggeon exchange
25641 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25642 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25643 & SIDP,CODP,SIFP,COFP
25644 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25645 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25646 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25647 C Reggeon phenomenology parameters
25648 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25649 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25650 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25651 & ALREG,ALREGP,GR(2),B0REG(2),
25652 & GPPP,GPPR,B0PPP,B0PPR,
25653 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25654 C currently activated parton density parametrizations
25656 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25657 DOUBLE PRECISION PDFLAM,PDFQ2M
25658 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25659 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25660 C hard scattering parameters used for most recent hard interaction
25662 DOUBLE PRECISION ALQCD2,BQCD
25663 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25664 C some hadron information, will be deleted in future versions
25666 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25667 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25668 C scale parameters for parton model calculations
25669 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25670 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25671 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25672 & NQQAL,NQQALI,NQQALF,NQQPD
25674 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25675 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25676 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25678 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25679 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25684 DSIGMC(I) = CMPLX(0.D0,0.D0)
25687 DSIGMC(15) = CMPLX(0.D0,0.D0)
25690 C direct particle 1
25691 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25694 C kinematic conversions
25697 IF ( XB.GE.1.D0 ) THEN
25698 WRITE(LO,'(/1X,A,2E12.4)')
25699 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25702 SP = XA*XB*ECMH*ECMH
25708 C set hard scale QQ for alpha and partondistr.
25709 IF ( NQQAL.EQ.1 ) THEN
25711 ELSEIF ( NQQAL.EQ.2 ) THEN
25712 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25713 ELSEIF ( NQQAL.EQ.3 ) THEN
25715 ELSEIF ( NQQAL.EQ.4 ) THEN
25716 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25718 IF ( NQQPD.EQ.1 ) THEN
25720 ELSEIF ( NQQPD.EQ.2 ) THEN
25721 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25722 ELSEIF ( NQQPD.EQ.3 ) THEN
25724 ELSEIF ( NQQPD.EQ.4 ) THEN
25725 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25728 ALPHA2 = PHO_ALPHAS(QQAL,2)
25729 IF(IDPDG1.EQ.22) THEN
25730 ALPHA1 = pho_alphae(QQAL)
25731 ELSE IF(IDPDG1.EQ.990) THEN
25732 ALPHA1 = PARMDL(74)
25734 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25735 C parton distribution (times x)
25736 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25741 IF(IDPDG1.EQ.22) THEN
25743 * IF(MOD(I,2).EQ.0) THEN
25744 * S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25747 * S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25750 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25753 ELSE IF(IDPDG1.EQ.990) THEN
25755 S2 = S2 + PDB(I)+PDB(-I)
25759 C partial cross sections (including color and symmetry factors)
25760 C direct photon matrix elements
25761 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25762 DSIGM(11) = (UU+TT)/(UP*TP)
25764 DSIGM(10) = FACTOR*DSIGM(10)*S2
25765 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25768 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25771 IF(DSIGM(I).LT.0.D0) THEN
25772 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25773 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25776 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25777 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25781 C direct particle 2
25782 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25784 ED = 1.D0/(ECMH/PT-1.D0/EC)
25785 C kinematic conversions
25786 XA = PT*(EC+ED)/ECMH
25788 IF ( XA.GE.1.D0 ) THEN
25789 WRITE(LO,'(/1X,A,2E12.4)')
25790 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25793 SP = XA*XB*ECMH*ECMH
25799 C set hard scale QQ for alpha and partondistr.
25800 IF ( NQQAL.EQ.1 ) THEN
25802 ELSEIF ( NQQAL.EQ.2 ) THEN
25803 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25804 ELSEIF ( NQQAL.EQ.3 ) THEN
25806 ELSEIF ( NQQAL.EQ.4 ) THEN
25807 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25809 IF ( NQQPD.EQ.1 ) THEN
25811 ELSEIF ( NQQPD.EQ.2 ) THEN
25812 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25813 ELSEIF ( NQQPD.EQ.3 ) THEN
25815 ELSEIF ( NQQPD.EQ.4 ) THEN
25816 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25819 ALPHA1 = PHO_ALPHAS(QQAL,1)
25820 IF(IDPDG2.EQ.22) THEN
25821 ALPHA2 = pho_alphae(QQAL)
25822 ELSE IF(IDPDG2.EQ.990) THEN
25823 ALPHA2 = PARMDL(74)
25825 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25826 C parton distribution (times x)
25827 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25832 IF(IDPDG2.EQ.22) THEN
25834 * IF(MOD(I,2).EQ.0) THEN
25835 * S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25838 * S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25841 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25844 ELSE IF(IDPDG2.EQ.990) THEN
25846 S2 = S2 + PDA(I)+PDA(-I)
25850 C partial cross sections (including color and symmetry factors)
25851 C direct photon matrix elements
25852 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25853 DSIGM(13) = (UU+TT)/(UP*TP)
25855 DSIGM(12) = FACTOR*DSIGM(12)*S2
25856 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25859 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25862 IF(DSIGM(I).LT.0.D0) THEN
25863 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25864 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25867 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25868 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25873 CDECK ID>, PHO_HARXPT
25874 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25875 C**********************************************************************
25877 C differential cross section DSIG/DPT
25879 C input: ECMH CMS energy of scattering system
25881 C IPRO 1 resolved processes
25882 C 2 direct processes
25883 C 3 resolved and direct processes
25885 C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25887 C**********************************************************************
25888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25891 PARAMETER ( Max_pro_2 = 16 )
25893 DIMENSION DSIGMC(0:Max_pro_2)
25894 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25896 C input/output channels
25898 COMMON /POINOU/ LI,LO
25900 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25901 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25902 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25903 C model switches and parameters
25905 INTEGER ISWMDL,IPAMDL
25906 DOUBLE PRECISION PARMDL
25907 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25908 C data of c.m. system of Pomeron / Reggeon exchange
25909 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25910 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25911 & SIDP,CODP,SIFP,COFP
25912 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25913 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25914 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25915 C Reggeon phenomenology parameters
25916 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25917 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25918 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25919 & ALREG,ALREGP,GR(2),B0REG(2),
25920 & GPPP,GPPR,B0PPP,B0PPR,
25921 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25922 C integration precision for hard cross sections (obsolete)
25923 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25924 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25925 C hard scattering parameters used for most recent hard interaction
25927 DOUBLE PRECISION ALQCD2,BQCD
25928 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25929 C some hadron information, will be deleted in future versions
25931 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25932 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25934 double precision pho_alphae
25937 DIMENSION DSIG1(0:Max_pro_2)
25938 DIMENSION ABSZ(32),WEIG(32)
25940 DO 10 M=0,Max_pro_2
25941 DSIGMC(M) = CMPLX(0.D0,0.D0)
25942 DSIG1(M) = CMPLX(0.D0,0.D0)
25945 C resolved and direct processes
25947 IF ( AMT.GE.1.D0 ) RETURN
25948 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25951 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25953 DSIG1(9) = CMPLX(0.D0,0.D0)
25954 DSIG1(15) = CMPLX(0.D0,0.D0)
25956 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25957 ELSE IF(IPRO.EQ.2) THEN
25958 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25960 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25961 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25963 DO 20 M=1,Max_pro_2
25964 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25969 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25970 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25973 ALPHAE = pho_alphae(SS)
25975 IF(IDPDG1.EQ.22) THEN
25976 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25977 F1 = Q_ch2(I)*ALPHAE
25981 IF(IDPDG2.EQ.22) THEN
25982 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25983 F2 = Q_ch2(I)*ALPHAE
25987 FAC = FAC+F1*F2*3.D0
25989 C direct cross sections
25990 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25991 T1 = -SS/2.D0*(1.D0+ZZ)
25992 T2 = -SS/2.D0*(1.D0-ZZ)
25993 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25995 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25997 C leptonic part (e, mu, tau)
25999 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26000 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
26001 C simulation of tau together with quarks
26002 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26006 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
26007 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
26011 CDECK ID>, PHO_HARXTO
26012 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26013 C**********************************************************************
26015 C total hard cross section (perturbative QCD, Parton Model)
26017 C input: ECMH CMS energy of scattering system
26018 C PTCUTR PT cutoff for resolved processes
26019 C PTCUTD PT cutoff for direct processes (photon, Pomeron)
26021 C output: DSIGMC(0:MARPR2) cross sections for given cutoff
26022 C DSDPTC(0:MARPR2) differential cross sections at cutoff
26024 C note: COMPLEX*16 DSIGMC
26025 C DOUBLE PRECISION DSDPTC
26027 C**********************************************************************
26028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26031 PARAMETER ( Max_pro_2 = 16 )
26033 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
26035 C input/output channels
26037 COMMON /POINOU/ LI,LO
26038 C model switches and parameters
26040 INTEGER ISWMDL,IPAMDL
26041 DOUBLE PRECISION PARMDL
26042 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26043 C data of c.m. system of Pomeron / Reggeon exchange
26044 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26045 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26046 & SIDP,CODP,SIFP,COFP
26047 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26048 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26049 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26050 C Reggeon phenomenology parameters
26051 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26052 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26053 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26054 & ALREG,ALREGP,GR(2),B0REG(2),
26055 & GPPP,GPPR,B0PPP,B0PPR,
26056 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26058 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26059 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26060 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26061 C integration precision for hard cross sections (obsolete)
26062 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26063 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26064 C some hadron information, will be deleted in future versions
26066 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26067 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26068 C hard scattering parameters used for most recent hard interaction
26070 DOUBLE PRECISION ALQCD2,BQCD
26071 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26073 double precision pho_alphae
26076 DIMENSION DSIG1(0:Max_pro_2)
26077 DIMENSION ABSZ(32),WEIG(32)
26081 DO 10 M=0,Max_pro_2
26082 DSIGMC(M)= CMPLX(0.D0,0.D0)
26086 IF ( PTCUTR.GE.EEC ) GOTO 100
26088 C integration for resolved processes
26090 PTMAX = MIN(FAC*PTMIN,EEC)
26092 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26094 DSDPTC(M) = DREAL(DSIG1(M))
26096 DSIGH = DREAL(DSIG1(9))
26097 PTMXX = 0.95D0*PTMAX
26098 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26099 DSIGL = DREAL(DSIG1(9))
26100 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26103 IF ( PTMIN.GE.PTMAX ) GOTO 40
26106 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26109 PT = R**(1.0D0/EX1)
26110 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26111 F = WEIG(I)*PT/(R*EX1)
26113 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26121 DSIGMC(0) = DSIGMC(9)
26122 DSDPTC(0) = DSDPTC(9)
26124 C integration for direct processes
26125 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26127 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26128 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26130 PTMAX = MIN(FAC*PTMIN,EEC)
26132 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26133 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26135 DSDPTC(M) = DREAL(DSIG1(M))
26137 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26138 PTMXX = 0.95D0*PTMAX
26139 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26140 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26141 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26144 IF ( PTMIN.GE.PTMAX ) GOTO 140
26147 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26150 PT = R**(1.0D0/EX1)
26151 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26152 F = WEIG(I)*PT/(R*EX1)
26154 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26165 C double direct process
26166 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26167 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26170 ALPHAE = pho_alphae(SS)
26172 IF(IDPDG1.EQ.22) THEN
26173 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26174 F1 = Q_ch2(I)*ALPHAE
26178 IF(IDPDG2.EQ.22) THEN
26179 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26180 F2 = Q_ch2(I)*ALPHAE
26184 FACC = FACC + F1*F2*3.D0
26187 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26188 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26189 C hadronic cross section
26190 DSIGMC(14) = R*FACC*AKFAC
26191 C leptonic cross section
26192 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26193 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26194 C simulation of tau together with quarks
26195 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26196 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26198 DSIGMC(16) = CMPLX(0.D0,0.D0)
26200 C sum of direct part
26201 DSIGMC(15) = CMPLX(0.D0,0.D0)
26203 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26206 C total sum (hadronic)
26207 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26208 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26212 CDECK ID>, PHO_HARISR
26213 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26214 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26215 C********************************************************************
26217 C initial state radiation according to DGLAP evolution equations
26218 C (backward evolution, no spin effects)
26220 C input: IHPOM index of hard Pomeron
26221 C negative: delete all previous entries
26222 C P1,P2 4 momenta of hard scattered final partons
26223 C (in CMS of hard scattering)
26224 C IPF1,2 flavours of final partons
26225 C IPA1,2 flavours of initial partons
26226 C IV1,2 valence quark labels (0/1)
26227 C Q2H momentum transfer (squared, positive)
26228 C XH1,XH2 x values of initial partons
26229 C XHMAX1,2 max. x values allowed
26231 C output: all emitted partons in /POPISR/, final state
26232 C partons are the first two entries
26233 C shower evolution traced in /PODGL1/
26234 C IPB1,2 flavours of new initial partons
26235 C XISR1,2 x values of new initial partons
26236 C IVO1,2 valence quark labels (0/1)
26238 C attention: quark numbering according to PDG convention,
26241 C********************************************************************
26242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26245 PARAMETER (RHOMAS = 0.766D0,
26249 DIMENSION P1(4),P2(4)
26251 C input/output channels
26253 COMMON /POINOU/ LI,LO
26254 C event debugging information
26256 PARAMETER (NMAXD=100)
26257 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26258 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26259 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26260 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26261 C internal rejection counters
26263 PARAMETER (NMXJ=60)
26264 CHARACTER*10 REJTIT
26266 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26267 C model switches and parameters
26269 INTEGER ISWMDL,IPAMDL
26270 DOUBLE PRECISION PARMDL
26271 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26272 C data of c.m. system of Pomeron / Reggeon exchange
26273 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26274 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26275 & SIDP,CODP,SIFP,COFP
26276 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26277 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26278 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26279 C some hadron information, will be deleted in future versions
26281 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26282 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26283 C currently activated parton density parametrizations
26285 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26286 DOUBLE PRECISION PDFLAM,PDFQ2M
26287 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26288 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26289 C scale parameters for parton model calculations
26290 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26291 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26292 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26293 & NQQAL,NQQALI,NQQALF,NQQPD
26294 C parameters for DGLAP backward evolution in ISR
26296 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26297 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26298 C initial state parton radiation (internal part)
26299 INTEGER MXISR3,MXISR4
26300 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26301 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26302 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26303 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26304 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26305 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26306 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26308 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26309 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26310 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26311 C particles created by initial state evolution
26312 INTEGER MXISR1,MXISR2
26313 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26314 INTEGER IFLISR,IPOISR,IMXISR
26315 DOUBLE PRECISION PHISR
26316 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26317 & IPOISR(2,2,MXISR2),IMXISR(2)
26319 DOUBLE PRECISION PYP,EER,THER,QMAXR
26322 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26323 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26324 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26330 IF(IDEB(79).GE.10) THEN
26331 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26332 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26333 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26335 IF(IHPOM.EQ.0) RETURN
26342 C copy final state partons to local fields
26345 IF(IHIDX.GT.MXISR2) THEN
26346 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26347 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26353 IF(IHPOM.LT.0) IMXISR(K) = 0
26354 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26355 IPAL(K) = IPOISR(K,1,IHIDX)
26358 PHISR(1,I,IPAL(1)) = P1(I)
26359 PHISR(2,I,IPAL(2)) = P2(I)
26361 IFLISR(1,IPAL(1)) = IPF1
26362 IFLISR(2,IPAL(2)) = IPF2
26364 C check limitations, initialize /PODGL1/
26365 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26372 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26387 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26390 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26392 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26393 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26394 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26396 C initialize parton shower loop
26397 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26398 AL2ISR(1) = PDFLAM(1)
26399 AL2ISR(2) = PDFLAM(2)
26402 XHMI(1) = PMISR(1)/PCMP
26403 XHMI(2) = PMISR(2)/PCMP
26406 SHAT1 = XH1*XH2*ECMP**2
26407 IF(IPAMDL(109).EQ.1) THEN
26410 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26412 PT2SH(2,1) = PT2SH(1,1)
26413 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26414 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26415 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26416 THSH(2,1) = THSH(1,1)
26420 IF(IREJ.NE.0) GOTO 800
26422 C main generation loop
26423 C -------------------------------------------------
26425 C choose parton side to become solved
26426 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26427 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26429 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26432 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26434 ELSE IF(NEXT(1).EQ.1) THEN
26436 ELSE IF(NEXT(2).EQ.1) THEN
26442 C INDX now parton position of parton to become solved
26443 C IP now side to be treated
26445 Q2P = Q2SH(IP,INDX)
26446 PT2 = PT2SH(IP,INDX)
26447 IFLB = IFL1(IP,INDX)
26448 C check available x
26450 C cutoff by x limitation: no further development
26451 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26453 Q2SH(IP,INDX) = 0.D0
26454 IF(IDEB(79).GE.17) THEN
26455 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26456 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26457 & XP,XMIP,XHMA(IP),IP,INDX
26461 C initial value of evolution variable t
26462 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26463 DO 110 I=-NFSISR,NFSISR
26469 ZMAX = XP/(XP+XMIP)
26471 C q --> q g, g --> g g
26473 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26474 & +2.D0*LOG(ZMAX/ZMIN))
26476 WGGAP(I) = WGGAP(0)
26477 WGGAP(-I) = WGGAP(0)
26479 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26480 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26481 C q --> g q, g --> q qb
26482 ELSE IF(ABS(IFLB).LE.6) THEN
26483 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26484 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26485 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26486 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26488 WRITE(LO,'(/1X,A,I7)')
26489 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26492 C anomalous/resolved evolution
26494 IF(IPAMDL(110).GE.1) THEN
26495 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26496 & .AND.(IFLB.NE.21)) THEN
26498 IF(NQQALI.EQ.1) THEN
26503 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26505 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26506 XI = DT_RNDM(XP)*PD1(IFLB)
26507 IF(WGDIR.GT.XI) THEN
26509 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26511 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26512 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26513 Q2SH(IP,INDX) = 0.D0
26521 C rejection loop for z,t sampling
26522 C ------------------------------------
26525 IF(NITER.GE.NTRY) THEN
26526 WRITE(LO,'(1X,A,2I6)')
26527 & 'PHO_HARISR: too many rejections',NITER,NTRY
26528 CALL PHO_PREVNT(-1)
26534 IF(IPDFC.EQ.0) THEN
26535 IF(NQQALI.EQ.1) THEN
26540 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26545 DO 210 I=-NFSISR,NFSISR
26546 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26547 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26551 C sample new t value
26552 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26553 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26555 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26556 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26557 C compare to limits
26558 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26559 Q2SH(IP,INDX) = 0.D0
26561 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26562 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26563 & Q2NEW,Q2MISR(IP),IP,INDX
26566 Q2SH(IP,INDX) = Q2NEW
26567 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26568 C selection of flavours
26569 XI = WGTOT*DT_RNDM(TT)
26573 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26574 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26576 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26577 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26579 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26581 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26582 & 'PHO_HARISR: pre-selected ZZ',ZZ
26584 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26585 IF(THETA.GT.THSH(IP,INDX)) THEN
26586 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26587 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26588 & THETA,THSH(IP,INDX)
26591 C rejection weight given by new PDFs
26593 PT2NEW = Q2NEW*(1.D0-ZZ)
26594 IF(NQQALI.EQ.1) THEN
26595 SCALE2 = PT2NEW*AQQPD
26597 SCALE2 = Q2NEW*AQQPD
26599 IF(SCALE2.LT.Q2MISR(IP)) THEN
26600 Q2SH(IP,INDX) = 0.D0
26602 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26603 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26604 & Q2NEW,Q2MISR(IP),IP,INDX
26607 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26608 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26609 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26610 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26611 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26612 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26613 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26614 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26615 WRITE(LO,'(1X,A,E12.3)')
26616 & 'PHO_HARISR: final weight:',WGF
26617 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26618 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26620 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26622 IF(IDEB(79).GE.15) THEN
26623 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26624 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26625 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26628 IF(INDX.GE.MXISR3) THEN
26629 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26630 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26635 C branching accepted, registration
26636 Q2SH(IP,INDX) = Q2NEW
26637 PT2SH(IP,INDX) = PT2NEW
26639 IFL2(IP,INDX) = IFLA-IFLB
26640 Q2SH(IP,INDX+1) = Q2NEW
26641 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26642 XPSH(IP,INDX+1) = XNEW
26643 THSH(IP,INDX+1) = THETA
26644 IFL1(IP,INDX+1) = IFLA
26645 ISH(IP) = ISH(IP)+1
26649 IF(NACC.GT.MXISR4) THEN
26650 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26651 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26658 IBRA(2,NACC) = INDX
26661 C generation of next branching
26662 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26666 C new initial flavours, x values
26667 IPB1 = IFL1(1,ISH(1))
26668 IPB2 = IFL1(2,ISH(2))
26669 XISR1 = XPSH(1,ISH(1))
26670 XISR2 = XPSH(2,ISH(2))
26675 IF(ISH(1).GT.1) THEN
26676 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26677 IF(IDPDG1.EQ.22) THEN
26678 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26679 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26681 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26682 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26687 IF(ISH(2).GT.1) THEN
26688 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26689 IF(IDPDG2.EQ.22) THEN
26690 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26691 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26693 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26698 C parton kinematics
26700 C final partons in CMS
26701 PM(3) = (XH1-XH2)*ECMP/2.D0
26702 PM(4) = (XH1+XH2)*ECMP/2.D0
26703 SH = XH1*XH2*ECMP**2
26707 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26708 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26709 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26710 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26711 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26712 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26718 IL(IPA) = IBRA(2,I)
26719 C new initial partons in CMS
26722 SHZ = SH/ZPSH(IPA,IL(IPA))
26724 Q2(1) = Q2SH(1,IL(1))
26725 Q2(2) = Q2SH(2,IL(2))
26728 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26730 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26734 PC(2,4) = SSH-PC(1,4)
26735 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26736 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26737 S1 = SH+Q2(IPA)+Q2(IPB)
26738 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26739 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26740 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26741 IF(Q2(IPB).LT.0.1D0) THEN
26742 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26743 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26745 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26746 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26749 C max. virtuality for time-like showers
26750 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26751 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26752 C generate time-like parton shower
26753 KF = IFL2(IPA,IL(IPA))
26754 IF(KF.EQ.0) KF = 21
26755 EER = MIN(EE3-PC(IPA,4),ECMP)
26758 CALL PY1ENT(1,KF,EER,THER,THER)
26760 CALL PYSHOW(1,0,QMAXR)
26762 IF(IDEB(79).GE.25) THEN
26763 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26764 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26765 & EER,QMAX,XMS4M,Q2(IPA)
26778 IF(PYK(K,1).LE.4) THEN
26781 IF(KK.GT.MXISR1) THEN
26782 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26783 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26788 PHISR(IPA,1,KK) = PYP(K,1)
26789 PJX = PJX+PHISR(IPA,1,KK)
26790 PHISR(IPA,2,KK) = PYP(K,2)
26791 PJY = PJY+PHISR(IPA,2,KK)
26792 PHISR(IPA,3,KK) = PYP(K,3)
26793 PJZ = PJZ+PHISR(IPA,3,KK)
26794 PHISR(IPA,4,KK) = PYP(K,4)
26795 PJE = PJE+PHISR(IPA,4,KK)
26796 IFLISR(IPA,KK) = PYK(K,2)
26798 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26799 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26800 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26803 NGEN = KK-IPAL(IPA)
26804 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26805 PP4 = SQRT(PJE**2-XMS4)
26806 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26808 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26810 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26811 & PJE,PJX,PJY,PJZ,PP4,XMS4
26814 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26815 & /(2.D0*PC(IPA,3))
26816 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26817 IF(PT3.LT.0.D0) THEN
26818 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26819 & 'PHO_HARISR: rejection due to PT3',PT3
26823 CALL PHO_SFECFE(SFE,CFE)
26828 C time-like shower generated
26829 EE4 = EE3-PC(IPA,4)
26830 PZ4 = PZ3-PC(IPA,3)
26831 PP4 = SQRT(PT3**2+PZ4**2)
26833 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26834 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26837 SIDD = SQRT(PX3**2+PY3**2)/PP4
26840 IF(PP4*SIDD.GT.1.D-5) THEN
26841 COFD = PX3/(SIDD*PP4)
26842 SIFD = PY3/(SIDD*PP4)
26843 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26847 C copy partons back
26851 PX = PHISR(IPA,1,KK)
26852 PY = PHISR(IPA,2,KK)
26853 PZ = PHISR(IPA,3,KK)
26854 COH= PHISR(IPA,4,KK)
26855 EE = GAM*COH+BEG*PZ
26856 PZ = GAM*PZ +BEG*COH
26857 PHISR(IPA,4,KK) = EE
26858 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26859 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26863 C no time-like shower generated
26864 IPAL(IPA) = IPAL(IPA)+1
26865 PHISR(IPA,1,IPAL(IPA)) = PX3
26866 PHISR(IPA,2,IPAL(IPA)) = PY3
26867 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26868 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26869 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
26875 C boost / rotate into new CMS
26877 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26879 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26880 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26882 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26885 IF(PTOT1*SIG.GT.1.D-5) THEN
26886 COH=PM(1)/(SIG*PTOT1)
26887 SIH=PM(2)/(SIG*PTOT1)
26888 ANORF=SQRT(COH*COH+SIH*SIH)
26893 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26894 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26895 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26896 & PTOT1,PM(1),PM(2),PM(3),PM(4))
26897 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26899 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26900 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26901 PHISR(K,4,L) = PM(4)
26905 C boost back to global CMS
26906 PM(3) = (XISR1-XISR2)/2.D0
26907 PM(4) = (XISR1+XISR2)/2.D0
26908 SSH = SQRT(XISR1*XISR2)
26912 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26913 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26914 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26915 & PM(2),PM(3),PM(4))
26916 PHISR(K,1,L) = PM(1)
26917 PHISR(K,2,L) = PM(2)
26918 PHISR(K,3,L) = PM(3)
26919 PHISR(K,4,L) = PM(4)
26923 IPOISR(1,2,IHIDX) = IPAL(1)
26924 IPOISR(2,2,IHIDX) = IPAL(2)
26925 IMXISR(1) = IPAL(1)
26926 IMXISR(2) = IPAL(2)
26929 IF(IDEB(79).GE.10) THEN
26930 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26931 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26933 WRITE(LO,'(1X,A,2I5,/6X,A)')
26934 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26935 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
26939 WRITE(LO,'(5X,4I5,4E11.3)')
26940 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26944 C check of final configuration
26951 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26953 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26954 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26955 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26956 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26957 PX3 = PX3 + PHISR(K,1,L)
26958 PY3 = PY3 + PHISR(K,2,L)
26959 PZ3 = PZ3 + PHISR(K,3,L)
26960 EE3 = EE3 + PHISR(K,4,L)
26963 IFSUM(1) = IFSUM(1)-IPB1
26964 IFSUM(2) = IFSUM(2)-IPB2
26965 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26966 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26967 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26968 & IFSUM,PX3,PY3,PZ3,EE3
26972 CDECK ID>, PHO_HARZSP
26973 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26974 C*********************************************************************
26976 C sampling of z values from DGLAP kernels
26978 C input: IFLA,IFLB parton flavours
26979 C NFSH flavours involved in hard processes
26980 C ZMIN minimal ZZ allowed
26981 C ZMAX maximal ZZ allowed
26983 C output: ZZ z value
26985 C*********************************************************************
26986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26989 PARAMETER ( DEPS = 1.D-10 )
26991 C input/output channels
26993 COMMON /POINOU/ LI,LO
26994 C event debugging information
26996 PARAMETER (NMAXD=100)
26997 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26998 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26999 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27000 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27001 C internal rejection counters
27003 PARAMETER (NMXJ=60)
27004 CHARACTER*10 REJTIT
27006 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27008 IF(ZMAX.LE.ZMIN) THEN
27009 WRITE(LO,'(1X,A,2E12.3)')
27010 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
27011 CALL PHO_PREVNT(-1)
27019 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
27020 C2 = (1.D0-ZMIN)/ZMIN
27022 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
27023 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
27024 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27028 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
27029 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
27033 ELSE IF(ABS(IFLB).LE.NFSH) THEN
27038 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
27039 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
27040 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27042 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
27045 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
27046 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27054 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27055 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27056 & IFLA,IFLB,ZZ,ZMIN,ZMAX
27060 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27066 CDECK ID>, PHO_ALPHAE
27067 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27068 C**********************************************************************
27070 C calculation of ALPHA_em
27072 C input: Q2 scale in GeV**2
27074 C**********************************************************************
27080 DOUBLE PRECISION Q2
27082 C input/output channels
27084 COMMON /POINOU/ LI,LO
27085 C model switches and parameters
27087 INTEGER ISWMDL,IPAMDL
27088 DOUBLE PRECISION PARMDL
27089 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27091 DOUBLE PRECISION PYALEM
27093 pho_alphae = 1.D0/137.D0
27095 if(ipamdl(120).eq.1) then
27097 pho_alphae = PYALEM(Q2)
27103 CDECK ID>, PHO_ALPHAS
27104 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27105 C**********************************************************************
27107 C calculation of ALPHA_S
27109 C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27110 C 2 lambda_QCD**2 for PDF 2 evolution
27111 C 3 lambda_QCD**2 for hard scattering
27112 C Q2 scale in GeV**2
27114 C initialization needed:
27115 C IMODE = 0 lambda values taken from PDF table
27116 C -1 given Q2 is 4-flavour lambda 1
27117 C -2 given Q2 is 4-flavour lambda 2
27118 C -3 given Q2 is 4-flavour lambda 3
27121 C**********************************************************************
27127 DOUBLE PRECISION Q2
27130 C input/output channels
27132 COMMON /POINOU/ LI,LO
27133 C model switches and parameters
27135 INTEGER ISWMDL,IPAMDL
27136 DOUBLE PRECISION PARMDL
27137 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27138 C hard scattering parameters used for most recent hard interaction
27140 DOUBLE PRECISION ALQCD2,BQCD
27141 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27142 C currently activated parton density parametrizations
27144 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27145 DOUBLE PRECISION PDFLAM,PDFQ2M
27146 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27147 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27153 IF(IMODE.GT.0) THEN
27155 IF(Q2.LT.PARMDL(148)) THEN
27157 ELSE IF(Q2.LT.PARMDL(149)) THEN
27159 ELSE IF(Q2.LT.PARMDL(150)) THEN
27165 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27168 ELSE IF(IMODE.EQ.0) THEN
27172 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27174 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27176 ALQCD2(I,1) = PARMDL(148)
27177 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27178 ALQCD2(I,3) = PARMDL(149)
27179 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27180 ALQCD2(I,4) = PARMDL(150)
27181 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27185 ELSE IF(IMODE.LT.0) THEN
27187 if(IMODE.eq.-4) then
27189 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27194 ALQCD2(I,1) = PARMDL(148)
27195 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27196 ALQCD2(I,3) = PARMDL(149)
27197 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27198 ALQCD2(I,4) = PARMDL(150)
27199 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27205 CDECK ID>, PHO_DFWRAP
27206 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27207 C**********************************************************************
27209 C wrapper for diffraction dissociation in hadron-nucleus and
27210 C nucleus-nucleus collisions with DPMJET
27212 C input: MODE 1: transformation into CMS
27213 C 2: transformation into Lab
27214 C JM1/2 indices of old mother particles
27215 C JM1/2N indices of new mother particles
27217 C**********************************************************************
27223 INTEGER MODE,JM1,JM2
27225 C input/output channels
27227 COMMON /POINOU/ LI,LO
27228 C event debugging information
27230 PARAMETER (NMAXD=100)
27231 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27232 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27233 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27234 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27236 C standard particle data interface
27239 PARAMETER (NMXHEP=4000)
27241 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27242 DOUBLE PRECISION PHEP,VHEP
27243 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27244 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27246 C extension to standard particle data interface (PHOJET specific)
27247 INTEGER IMPART,IPHIST,ICOLOR
27248 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27250 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27251 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27252 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27253 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27254 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27256 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27257 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27259 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27261 C transformation into CMS
27273 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27274 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27275 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27276 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27277 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27280 GAMBED(I) = P1(I)/ECMD
27282 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27283 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27284 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27287 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27290 IF(PTOT1*SIDD.GT.1.D-5) THEN
27291 COFD = P1(1)/(SIDD*PTOT1)
27292 SIFD = P1(2)/(SIDD*PTOT1)
27293 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27298 C initial particles in CMS
27302 P1(3) = ECMD/2.D0*XPSUB
27307 P2(3) = -ECMD/2.D0*XTSUB
27310 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27312 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27313 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27314 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27316 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27317 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27318 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27323 C transformation into lab.
27325 ELSE IF(MODE.EQ.2) THEN
27327 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27328 & GAMBED(1),GAMBED(2),GAMBED(3))
27333 C clean up after rejection
27335 ELSE IF(MODE.EQ.-2) THEN
27344 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27350 CDECK ID>, PHO_DIFDIS
27351 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27352 & MSOFT,MHARD,IREJ)
27353 C***********************************************************************
27355 C sampling of diffractive events of different kinds,
27356 C (produced particles stored in /POEVT1/)
27358 C input: IDIF1/2 diffractive process particle 1/2
27359 C 0 elastic/quasi-elastic scattering
27360 C 1 diffraction dissociation
27361 C IMOTH1/2 index of mother particles in /POEVT1/
27362 C SPROB suppression factor (survival probability) for
27363 C resolved diffraction dissociation
27364 C IMODE mode of operation
27365 C 0 sampling of diffractive cut
27366 C 1 sampling of enhanced cut
27367 C 2 sampling of diffractive cut without
27368 C scattering (needed for double-pomeron)
27369 C -1 initialization
27370 C -2 output of statistics
27372 C output: MSOFT number of generated soft strings
27373 C MHARD number of generated hard strings
27374 C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27375 C 0 quasi elastic scattering
27376 C 1 low-mass diffractive dissociation
27377 C 2 soft high-mass diffractive dissociation
27378 C 3 hard resolved diffractive dissociation
27379 C 4 hard direct diffractive dissociation
27380 C IREJ rejection label
27381 C 0 successful generation of partons
27384 C***********************************************************************
27385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27388 PARAMETER ( EPS = 1.D-7,
27391 C input/output channels
27393 COMMON /POINOU/ LI,LO
27394 C event debugging information
27396 PARAMETER (NMAXD=100)
27397 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27398 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27399 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27400 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27401 C general process information
27402 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27403 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27404 C internal rejection counters
27406 PARAMETER (NMXJ=60)
27407 CHARACTER*10 REJTIT
27409 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27410 C global event kinematics and particle IDs
27411 INTEGER IFPAP,IFPAB
27412 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27413 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27414 C c.m. kinematics of diffraction
27416 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27417 & SIDD,CODD,SIFD,COFD,PDCMS
27418 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27419 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27420 C obsolete cut-off information
27421 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27422 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27424 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27425 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27426 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27427 C model switches and parameters
27429 INTEGER ISWMDL,IPAMDL
27430 DOUBLE PRECISION PARMDL
27431 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27432 C Reggeon phenomenology parameters
27433 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27434 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27435 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27436 & ALREG,ALREGP,GR(2),B0REG(2),
27437 & GPPP,GPPR,B0PPP,B0PPR,
27438 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27439 C parameters of 2x2 channel model
27440 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27441 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27442 C table of particle indices for recursive PHOJET calls
27444 PARAMETER ( MAXIPX = 100 )
27445 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27446 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27447 & IPOIX1,IPOIX2,IPOIX3
27449 C standard particle data interface
27452 PARAMETER (NMXHEP=4000)
27454 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27455 DOUBLE PRECISION PHEP,VHEP
27456 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27457 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27459 C extension to standard particle data interface (PHOJET specific)
27460 INTEGER IMPART,IPHIST,ICOLOR
27461 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27463 C event weights and generated cross section
27464 INTEGER IPOWGC,ISWCUT,IVWGHT
27465 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27466 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27467 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27469 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27470 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27471 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27472 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27475 IF(IMODE.EQ.-1) THEN
27478 ELSE IF(IMODE.EQ.-2) THEN
27479 C output of statistics
27487 IF(IDEB(45).GE.10) THEN
27488 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27489 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27490 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27494 C save current status
27504 JDA11 = JDAHEP(1,IMOTH1)
27505 JDA21 = JDAHEP(2,IMOTH1)
27506 JDA12 = JDAHEP(1,IMOTH2)
27507 JDA22 = JDAHEP(2,IMOTH2)
27508 ISTH1 = ISTHEP(IMOTH1)
27509 ISTH2 = ISTHEP(IMOTH2)
27515 IDPDG(I) = IDHEP(NPOSD(I))
27516 IDBAM(I) = IMPART(NPOSD(I))
27517 AMP(I) = PHO_PMASS(IDBAM(I),0)
27518 IF(IDPDG(I).EQ.22) THEN
27519 PMASSD(I) = 0.765D0
27520 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27522 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27527 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27528 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27529 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27530 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27531 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27533 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27534 & 'PHO_DIFDIS: availabe energy',ECMD
27535 C check total available energy
27536 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27537 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27539 & 'not enough energy for inelastic diffraction',
27540 & 'ECM, particle masses:',ECMD,AMP
27541 IFAIL(7) = IFAIL(7)+1
27547 GAMBED(I) = P1(I)/ECMD
27549 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27550 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27551 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27554 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27557 IF(PTOT1*SIDD.GT.1.D-5) THEN
27558 COFD = P1(1)/(SIDD*PTOT1)
27559 SIFD = P1(2)/(SIDD*PTOT1)
27560 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27564 C initial particles in CMS
27571 PDCMS(3,2) = -PTOT1
27572 PDCMS(4,2) = ECMD-P1(4)
27573 C get new CM momentum
27574 AM12 = PMASSD(1)**2
27575 AM22 = PMASSD(2)**2
27576 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27578 C coherence constraint (min/max diffractive mass allowed)
27579 IF(IMODE.EQ.2) THEN
27580 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27581 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27582 THRM2 = SQRT(1-PARMDL(72))*ECMD
27583 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27586 THRM2 = PARMDL(45)*ECMD
27587 C check kinematic limits
27588 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27589 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27592 C check energy vs. coherence constraints
27593 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27594 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27596 C no phase space available
27597 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27598 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27600 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27601 & 'side 1: min. mass, upper mass limit:',
27602 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27603 & 'side 2: min. mass, upper mass limit:',
27604 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27605 IFAIL(7) = IFAIL(7)+1
27615 C main rejection loop
27616 C -------------------------------
27620 IFAIL(13) = IFAIL(13)+1
27621 IF(ITRY.GE.ITRYM) THEN
27622 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27623 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27624 IFAIL(7) = IFAIL(7)+1
27635 C reset mother-daugther relations
27637 JDAHEP(1,IMOTH1) = JDA11
27638 JDAHEP(2,IMOTH1) = JDA21
27639 JDAHEP(1,IMOTH2) = JDA12
27640 JDAHEP(2,IMOTH2) = JDA22
27641 ISTHEP(IMOTH1) = ISTH1
27642 ISTHEP(IMOTH2) = ISTH2
27651 C calculation of kinematics
27653 C sampling of masses
27656 IFL1P(I) = IDPDG(I)
27657 IFL2P(I) = IDBAM(I)
27663 IF(IPAR(I).EQ.0) THEN
27664 C vector meson dominance assumed
27666 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27667 C diffraction dissociation
27668 ELSE IF(IPAR(I).EQ.1) THEN
27669 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27670 PREF2 = PMASSD(I)**2
27671 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27673 WRITE(LO,'(/1X,A,2I3)')
27674 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27679 C sampling of momentum transfer
27680 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27681 & THRM2,TT,SLWGHT,IREJ)
27684 IF(NSLP.LT.100) GOTO 55
27685 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27686 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27691 C correct for t-M^2 correlation in diffraction
27692 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27694 IF(NCOR.LT.100) GOTO 55
27695 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27696 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27702 IF(IDEB(45).GE.5) THEN
27703 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27704 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27706 C not double pomeron scattering
27707 IF(IMODE.NE.2) THEN
27708 C sample diffractive interaction processes
27710 IF(IPAR(I).NE.0) THEN
27711 C find particle combination
27712 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27714 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27716 ELSE IF(IDPDG(I).EQ.990) THEN
27721 C sample dissociation process
27722 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27723 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27725 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27726 C store process label
27727 IF(IDIR(I).GT.0) THEN
27729 ELSE IF(KSAM(I).GT.0) THEN
27731 ELSE IF(ISAM(I).GT.0) THEN
27735 C mass fine correction
27736 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27737 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27741 C diffractive pomeron-hadron interaction
27742 IPAR(I) = 10+IPROC(I)
27745 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27746 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27747 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27751 C actualize debug information
27752 IF(IMODE.EQ.1) THEN
27756 C calculate new momenta in CMS
27757 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27758 IF(IREJ.NE.0) GOTO 50
27764 C comment line for diffraction
27765 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27766 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27767 C write diffractive strings/particles
27775 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27777 IGEN = IPHIST(2,NPOSD(I1))
27778 if(IGEN.eq.0) IGEN = -I1*10
27779 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27780 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27782 IFAIL(7+I) = IFAIL(7+I)+1
27783 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27784 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27785 & I,IPAR(I),XMASS(I)
27788 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27790 C double-pomeron scattering?
27791 IF(IMODE.EQ.2) GOTO 150
27793 C diffractive final states
27796 IF(IPAR(I).EQ.0) THEN
27797 C vector meson production
27798 IF(IDPDG(I).EQ.22) THEN
27799 IF(ISWMDL(21).GE.0) THEN
27801 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27802 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27804 C hadronic state of multi-pomeron coupling
27805 ELSE IF(IDPDG(I).EQ.990) THEN
27806 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27809 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27810 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27811 IF(IDIR(I).GT.0) THEN
27813 ELSE IF(KSAM(I).GT.0) THEN
27815 ELSE IF(ISAM(I).GT.0) THEN
27821 IPAR(I) = 10+IPROC(I)
27823 IPHIST(I,ICPOS) = IPAR(I)
27824 C update debug informantion
27831 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27833 C resonance decay, pi+pi- background
27834 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27835 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27836 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27837 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27838 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27839 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27841 IF(IDPDG(I).EQ.22) THEN
27843 IF(ISWMDL(21).GE.0) THEN
27845 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27846 CALL PHO_SDECAY(IPOS,ISP,2)
27849 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27854 C particle-pomeron scattering
27855 IF(IPAR(I).LE.4) THEN
27856 C non-diffractive particle-pomeron scattering
27857 IGEN = IPHIST(2,NPOSD(I))
27865 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27866 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27868 C diffractive particle-pomeron scattering
27870 IPORES(IPOIX2) = IPROC(I)
27871 IPOPOS(1,IPOIX2) = IPOSP(1,I)
27872 IPOPOS(2,IPOIX2) = IPOSP(2,I)
27879 IFAIL(20+I) = IFAIL(20+I)+1
27880 IF(IPAR(I).GT.1) THEN
27881 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27882 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27883 IF(IDIR(I).GT.0) THEN
27885 ELSE IF(KSAM(I).GT.0) THEN
27886 KSAM(I) = KSAM(I)-1
27887 ELSE IF(ISAM(I).GT.0) THEN
27888 ISAM(I) = ISAM(I)-1
27892 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27893 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27894 & I,IPAR(I),XMASS(I)
27902 C update debug information
27903 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27904 KSREG = KSREGS+JSAM(1)+JSAM(2)
27905 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27906 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27911 IF(IDEB(45).GE.10) THEN
27912 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27913 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27914 & IPAR,NPOSD,MSOFT,MHARD,IMODE
27916 IF(IDEB(45).GE.15) THEN
27917 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27918 & '------------------------------'
27924 CDECK ID>, PHO_DIFPRO
27925 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27926 & IPROC,ISAM,JSAM,KSAM,IDIR)
27927 C*********************************************************************
27929 C sampling of diffraction dissociation process
27931 C input: IP particle combination
27932 C ICUT user imposed limitations
27933 C ID1/2 PDG particle code of scattering particles
27934 C XMASS diffractively produced mass (GeV)
27935 C P2V1/2 virtuality of scattering particles (Gev**2)
27936 C SPROB suppression factor for resolved single and
27937 C double diffraction dissociation
27939 C output: IRPOC process ID
27940 C ISAM number of cut pomerons (soft)
27941 C JSAM number of cut reggeons
27942 C KSAM number of cut pomerons (hard)
27943 C IDIR direct hard interaction
27945 C*********************************************************************
27946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27949 C input/output channels
27951 COMMON /POINOU/ LI,LO
27952 C event debugging information
27954 PARAMETER (NMAXD=100)
27955 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27956 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27957 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27958 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27959 C general process information
27960 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27961 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27962 C model switches and parameters
27964 INTEGER ISWMDL,IPAMDL
27965 DOUBLE PRECISION PARMDL
27966 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27967 C energy-interpolation table
27969 PARAMETER ( IEETA2 = 20 )
27971 DOUBLE PRECISION SIGTAB,SIGECM
27972 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27979 IF(XMASS.GT.3.D0) THEN
27980 C rapidity gap survival probability
27982 IF(ISWMDL(28).GE.1) SPRO = SPROB
27983 C sample interaction
27985 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27989 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27990 C non-diffractive hadron-pomeron interaction
27991 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27992 C option for suppression of multiple interaction
27995 IF(ISAM+KSAM+IDIR.GT.0) THEN
28003 ELSE IF(ICUT.EQ.1) THEN
28005 ELSE IF(KSAM.GT.0) THEN
28009 ELSE IF(ISAM.GT.0) THEN
28015 ELSE IF(ICUT.EQ.2) THEN
28017 ELSE IF(ICUT.EQ.3) THEN
28023 CDECK ID>, PHO_DIFPAR
28024 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28025 & IPOSH1,IPOSH2,IMODE,IREJ)
28026 C***********************************************************************
28028 C perform string construction for diffraction dissociation
28030 C input: IMOTH1,2 index of mother particles in POEVT1
28031 C IGENM production process of mother particles
28032 C IFL1,IFL2 particle numbers
28033 C (IDPDG,IDBAM for quasi-elas. hadron)
28034 C IPAR 0 quasi-elasic scattering
28035 C 1 single string configuration
28036 C 2 two string configuration
28037 C P1 massive 4 momentum of first
28038 C P1(6) virtuality/squ.mass of particle (GeV**2)
28039 C P1(7) virtuality of Pomeron (neg, GeV**2)
28040 C P2 massive 4 momentum of second particle
28041 C IMODE 1 diffraction dissociation
28042 C 2 double-pomeron scattering
28044 C output: IPOSH1,2 index of the particles in /POEVT1/
28045 C IREJ 0 successful string construction
28046 C 1 no string construction possible
28048 C***********************************************************************
28049 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28052 DIMENSION P1(7),P2(7)
28054 PARAMETER ( EPS = 1.D-7,
28057 C input/output channels
28059 COMMON /POINOU/ LI,LO
28060 C event debugging information
28062 PARAMETER (NMAXD=100)
28063 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28064 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28065 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28066 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28067 C internal rejection counters
28069 PARAMETER (NMXJ=60)
28070 CHARACTER*10 REJTIT
28072 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28073 C c.m. kinematics of diffraction
28075 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28076 & SIDD,CODD,SIFD,COFD,PDCMS
28077 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28078 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28079 C model switches and parameters
28081 INTEGER ISWMDL,IPAMDL
28082 DOUBLE PRECISION PARMDL
28083 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28085 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28086 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28087 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28089 C standard particle data interface
28092 PARAMETER (NMXHEP=4000)
28094 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28095 DOUBLE PRECISION PHEP,VHEP
28096 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28097 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28099 C extension to standard particle data interface (PHOJET specific)
28100 INTEGER IMPART,IPHIST,ICOLOR
28101 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28103 DIMENSION PCH1(2,4)
28110 if(IGENM.le.-10) IGEN = 0
28114 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28115 if(IGEN.eq.0) IGEN = 3
28116 C pi+/pi- isotropic background
28117 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28118 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28119 CALL PHO_SDECAY(IPOSH1,0,-2)
28123 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28125 C registration of particle or resonance
28126 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28127 & P1(4),0,IGEN,0,0,IPOSH1,1)
28130 C diffraction dissociation
28131 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28132 C calculation of resulting particle momenta
28133 IF(IMOTH1.EQ.NPOSD(1)) THEN
28139 PCH1(2,I) = PDCMS(I,K)-P2(I)
28140 PCH1(1,I) = P1(I)-PCH1(2,I)
28144 if(IMODE.LT.2) then
28145 if(IGEN.eq.0) IGEN = -IGENM/10+4
28146 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28147 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28149 if(IGEN.eq.0) IGEN = 4
28151 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28152 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28156 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28160 C back transformation
28161 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28162 & GAMBED(1),GAMBED(2),GAMBED(3))
28166 CDECK ID>, PHO_QELAST
28167 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28168 C**********************************************************************
28170 C sampling of quasi elastic processes
28172 C input: IPROC 2 purely elastic scattering
28173 C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28174 C IPROC 4 double pomeron scattering
28175 C IPROC -1 initialization
28176 C IPROC -2 output of statistics
28177 C JM1/2 index of initial particle 1/2
28179 C output: initial and final particles in /POEVT1/ involving
28180 C polarized resonances in /POEVT1/ and decay
28183 C IREJ 0 successful
28185 C 50 user rejection
28187 C**********************************************************************
28188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28191 PARAMETER ( NTAB = 20,
28196 C input/output channels
28198 COMMON /POINOU/ LI,LO
28199 C event debugging information
28201 PARAMETER (NMAXD=100)
28202 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28203 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28204 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28205 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28206 C global event kinematics and particle IDs
28207 INTEGER IFPAP,IFPAB
28208 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28209 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28210 C c.m. kinematics of diffraction
28212 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28213 & SIDD,CODD,SIFD,COFD,PDCMS
28214 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28215 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28216 C model switches and parameters
28218 INTEGER ISWMDL,IPAMDL
28219 DOUBLE PRECISION PARMDL
28220 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28222 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28223 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28224 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28226 INTEGER IPFIL,IFAFIL,IFBFIL
28227 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28228 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28229 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28230 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28231 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28232 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28233 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28234 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28235 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28236 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28237 & IPFIL,IFAFIL,IFBFIL
28239 C standard particle data interface
28242 PARAMETER (NMXHEP=4000)
28244 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28245 DOUBLE PRECISION PHEP,VHEP
28246 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28247 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28249 C extension to standard particle data interface (PHOJET specific)
28250 INTEGER IMPART,IPHIST,ICOLOR
28251 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28253 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28254 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28255 DIMENSION IFL(2),IDPRO(4)
28256 character*15 pho_pname
28257 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28258 DIMENSION ISAMVM(4,4)
28259 DATA IDPRO / 113,223,333,92 /
28260 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28262 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28265 C sampling of elastic/quasi-elastic processes
28266 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28271 PMI(I) = PHEP(5,NPOSD(I))
28272 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28275 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28276 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28277 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28278 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28279 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28282 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28283 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28284 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28291 GAMBED(I) = PK1(I)/ECMD
28293 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28294 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28295 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28297 CODD = PK1(3)/PTOT1
28298 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28301 IF(PTOT1*SIDD.GT.1.D-5) THEN
28302 COFD = PK1(1)/(SIDD*PTOT1)
28303 SIFD = PK1(2)/(SIDD*PTOT1)
28304 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28311 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28313 C production process of mother particles
28314 IGEN = IPHIST(2,NPOSD(1))
28315 if(IGEN.eq.0) IGEN = IPROC
28318 C main rejection label
28320 C determine process and final particles
28321 IFL(1) = IDHEP(NPOSD(1))
28322 IFL(2) = IDHEP(NPOSD(2))
28323 IF(IPROC.EQ.3) THEN
28327 IF(ITRY.GT.50) THEN
28328 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28329 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28334 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28338 IF(XI.LE.0.D0) GOTO 130
28342 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28343 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28344 ISAMVM(I,J) = ISAMVM(I,J)+1
28346 C sample new masses
28347 CALL PHO_SAMASS(IFL(1),RMASS(1))
28348 CALL PHO_SAMASS(IFL(2),RMASS(2))
28349 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28350 ELSE IF(IPROC.EQ.2) THEN
28354 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28355 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28357 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28360 C sample momentum transfer
28361 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28363 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28364 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28365 C calculate new momenta
28366 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28367 IF(IREJ.NE.0) GOTO 50
28372 C comment line for elastic/quasi-elastic scattering
28373 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28374 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28380 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28381 C pi+/pi- isotropic background
28383 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28384 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28385 ICOLOR(I,ICPOS) = IPOS
28386 CALL PHO_SDECAY(IPOS,0,-2)
28390 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28391 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28392 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28393 ICOLOR(I,ICPOS) = IPOS
28397 C search for vector mesons
28399 C decay according to polarization
28400 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28402 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28403 CALL PHO_SDECAY(I,ISP,2)
28407 C back transformation
28408 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28409 & GAMBED(2),GAMBED(3))
28411 C initialization of tables
28412 ELSE IF(IPROC.EQ.-1) THEN
28420 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28421 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28422 CALL PHO_SAMASS(-1,RMASS(1))
28425 C output of statistics
28426 ELSE IF(IPROC.EQ.-2) THEN
28427 IF(ICALL.LT.10) RETURN
28428 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28429 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28430 & '---------------------------------------------------'
28431 WRITE(LO,'(1X,A,I10)')
28432 & 'sampled elastic processes:',ISAMEL
28433 WRITE(LO,'(1X,A,I10)')
28434 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28435 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28437 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28439 CALL PHO_SAMASS(-2,RMASS(1))
28441 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28442 & 'unknown process ID',IPROC
28448 CDECK ID>, PHO_CDIFF
28449 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28450 C**********************************************************************
28452 C preparation of /POEVT1/ for double-pomeron scattering
28454 C input: IMOTH1/2 index of mother particles in /POEVT1/
28456 C IMODE 1 sampling of pomeron-pomeron scattering
28457 C -1 initialization
28458 C -2 output of statistics
28460 C output: MSOFT number of generated soft strings
28461 C MHARD number of generated hard strings
28464 C 50 user rejection
28466 C**********************************************************************
28467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28470 PARAMETER ( EPS = 1.D-10,
28473 C input/output channels
28475 COMMON /POINOU/ LI,LO
28476 C event debugging information
28478 PARAMETER (NMAXD=100)
28479 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28480 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28481 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28482 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28483 C internal rejection counters
28485 PARAMETER (NMXJ=60)
28486 CHARACTER*10 REJTIT
28488 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28489 C model switches and parameters
28491 INTEGER ISWMDL,IPAMDL
28492 DOUBLE PRECISION PARMDL
28493 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28494 C general process information
28495 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28496 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28497 C Reggeon phenomenology parameters
28498 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28499 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28500 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28501 & ALREG,ALREGP,GR(2),B0REG(2),
28502 & GPPP,GPPR,B0PPP,B0PPR,
28503 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28504 C parameters of 2x2 channel model
28505 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28506 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28508 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28509 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28510 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28511 C energy-interpolation table
28513 PARAMETER ( IEETA2 = 20 )
28515 DOUBLE PRECISION SIGTAB,SIGECM
28516 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28517 C table of particle indices for recursive PHOJET calls
28519 PARAMETER ( MAXIPX = 100 )
28520 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28521 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28522 & IPOIX1,IPOIX2,IPOIX3
28524 C standard particle data interface
28527 PARAMETER (NMXHEP=4000)
28529 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28530 DOUBLE PRECISION PHEP,VHEP
28531 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28532 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28534 C extension to standard particle data interface (PHOJET specific)
28535 INTEGER IMPART,IPHIST,ICOLOR
28536 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28540 if(IMODE.ne.1) return
28544 C select first diffraction
28545 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28555 C save current status
28565 JDA11 = JDAHEP(1,IMOTH1)
28566 JDA21 = JDAHEP(2,IMOTH1)
28567 JDA12 = JDAHEP(1,IMOTH2)
28568 JDA22 = JDAHEP(2,IMOTH2)
28569 ISTH1 = ISTHEP(IMOTH1)
28570 ISTH2 = ISTHEP(IMOTH2)
28573 C find mother particle production process
28574 IGEN = IPHIST(2,IMOTH1)
28575 if(IGEN.eq.0) IGEN = 4
28577 C main generation loop
28586 C reset mother-daugther relations
28588 JDAHEP(1,IMOTH1) = JDA11
28589 JDAHEP(2,IMOTH1) = JDA21
28590 JDAHEP(1,IMOTH2) = JDA12
28591 JDAHEP(2,IMOTH2) = JDA22
28592 ISTHEP(IMOTH1) = ISTH1
28593 ISTHEP(IMOTH2) = ISTH2
28597 C rejection counter
28599 IF(ITRY2.GT.1) THEN
28600 IFAIL(39) = IFAIL(39)+1
28601 IF(ITRY2.GE.ITRYM) GOTO 50
28603 C generate two diffractive events
28604 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28605 IF(IREJ.NE.0) GOTO 50
28606 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28607 IF(IREJ.NE.0) GOTO 50
28608 C mass of pomeron-pomeron system
28609 DO 100 I2 = NHEP,1,-1
28610 IF(IDHEP(I2).EQ.990) GOTO 110
28613 DO 120 I1 = I2-1,1,-1
28614 IF(IDHEP(I1).EQ.990) GOTO 130
28618 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28620 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28621 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28622 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28623 IF(XMASS.LT.0.1D0) GOTO 60
28624 XMASS = SQRT(XMASS)
28625 IF(XMASS.LT.PARMDL(71)) GOTO 60
28627 C sample pomeron-pomeron interaction process
28628 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28629 & IPROC,ISAM,JSAM,KSAM,IDIR)
28631 C non-diffractive pomeron-pomeron interactions
28632 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28634 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28636 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28637 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28638 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28639 C store debug information
28642 ELSE IF(KSAM.GT.0) THEN
28644 ELSE IF(ISAM.GT.0) THEN
28650 IF(ISAM+JSAM.GT.0) KSDPO = 1
28651 IF(KSAM+IDIR.GT.0) KHDPO = 1
28658 C generate pomeron-pomeron interaction
28659 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28661 IFAIL(3) = IFAIL(3)+1
28663 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28665 IFAIL(10) = IFAIL(10)+1
28667 ELSE IF(KSAM.GT.0) THEN
28669 ELSE IF(ISAM.GT.0) THEN
28674 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28675 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28681 C diffractive pomeron-pomeron interactions
28684 IPORES(IPOIX2) = IPROC
28685 IPOPOS(1,IPOIX2) = I1
28686 IPOPOS(2,IPOIX2) = I2
28691 C update debug information
28692 KSPOM = KSPOMS+ISAM
28693 KSREG = KSREGS+JSAM
28694 KHPOM = KHPOMS+KSAM
28695 KHDIR = KHDIRS+IDIR
28696 C comment line for central diffraction
28697 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28698 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28699 PHEP(5,IPOS) = XMASS
28701 IF(IDEB(59).GE.15) THEN
28702 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28703 & '-----------------------------'
28708 C treatment of rejection
28711 IFAIL(40) = IFAIL(40)+1
28712 IF(IDEB(59).GE.3) THEN
28714 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28715 IF(IDEB(59).GE.10) THEN
28718 CALL PHO_PREVNT(-1)
28724 CDECK ID>, PHO_SAMASS
28725 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28726 C**********************************************************************
28728 C resonance mass sampling of quasi elastic processes
28730 C input: IFLA PDG number of particle
28731 C IFLA -1 initialization
28732 C IFLA -2 output of statistics
28734 C output: RMASS particle mass (in GeV)
28736 C**********************************************************************
28737 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28740 PARAMETER(EPS = 1.D-10 )
28742 C input/output channels
28744 COMMON /POINOU/ LI,LO
28745 C event debugging information
28747 PARAMETER (NMAXD=100)
28748 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28749 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28750 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28751 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28752 C model switches and parameters
28754 INTEGER ISWMDL,IPAMDL
28755 DOUBLE PRECISION PARMDL
28756 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28757 C parameters of the "simple" Vector Dominance Model
28758 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28759 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28761 PARAMETER(NTABM=50)
28762 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28763 DIMENSION SUM(4),ICALL(4)
28765 C*****************************************************************
28766 C initialization of tables
28767 IF(IFLA.EQ.-1) THEN
28773 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28775 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28778 C calculate table of dsig/dm
28779 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28781 IF(IDEB(35).GE.1) THEN
28782 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28783 WRITE(LO,'(1X,A,/1X,A)')
28784 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28785 & ' -------------------------------------------------------'
28787 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28788 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28791 C make second table for sampling
28795 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28802 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28805 IF(IDEB(35).GE.10) THEN
28806 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28807 WRITE(LO,'(1X,A,/1X,A)')
28808 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28809 & ' -------------------------------------------------------'
28811 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28812 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28816 C**************************************************
28817 C output of statistics
28818 ELSE IF(IFLA.EQ.-2) THEN
28819 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28820 & '----------------------'
28821 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
28822 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
28825 C********************************************************
28826 C sampling of RMASS
28828 C quasi-elastic vector meson production
28829 IF(IFLA.EQ.113) THEN
28831 ELSE IF(IFLA.EQ.223) THEN
28833 ELSE IF(IFLA.EQ.333) THEN
28835 ELSE IF(IFLA.EQ.92) THEN
28837 C quasi-elastic production of h*
28838 ELSE IF(IFLA.EQ.91) THEN
28841 C elastic hadron scattering
28843 RMASS = PHO_PMASS(IFLA,1)
28844 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28845 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28849 C sample mass of vector mesonsn / two-pi background
28850 XI = DT_RNDM(RMASS) + EPS
28852 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28856 IF((KMAX-KMIN).EQ.1) GOTO 400
28858 IF(XI.LE.XMC(KP,KK)) THEN
28866 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28867 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28868 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28871 C fine interpolation
28872 RMASS = RMA(KP,KMIN)+
28873 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
28874 & (XMC(KP,KMAX)-XMC(KP,KMIN))
28875 & *(XI-XMC(KP,KMIN))
28876 IF(IDEB(35).GE.20) THEN
28877 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28878 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28879 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28880 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28883 ICALL(KP) = ICALL(KP)+1
28888 CDECK ID>, PHO_DSIGDM
28889 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28890 C**********************************************************************
28892 C differential cross section DSIG/DM of low mass enhancement
28894 C input: RMA(4,NTABM) mass values
28895 C output: XMA(4,NTABM) DSIG/DM of resonances
28897 C 2 omega production
28899 C 4 pi-pi continuum
28901 C**********************************************************************
28902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28905 PARAMETER ( EPS = 1.D-10 )
28907 PARAMETER(NTABM=50)
28908 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28910 C input/output channels
28912 COMMON /POINOU/ LI,LO
28913 C event debugging information
28915 PARAMETER (NMAXD=100)
28916 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28917 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28918 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28919 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28920 C model switches and parameters
28922 INTEGER ISWMDL,IPAMDL
28923 DOUBLE PRECISION PARMDL
28924 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28925 C parameters of the "simple" Vector Dominance Model
28926 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28927 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28930 C rho meson shape (mass dependent width)
28931 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28934 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28935 GAMMA = GAMM(1)*(QQ/QRES)**3
28936 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28937 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28939 C omega/phi meson (constant width)
28943 XMA(K,I) = XMASS*GAMM(K)
28944 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28950 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28955 CDECK ID>, PHO_SDECAY
28956 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28957 C**********************************************************************
28959 C decay of single resonance of /POEVT1/:
28960 C decay in helicity frame according to polarization, isotropic
28961 C decay and decay with limited transverse phase space possible
28964 C reference to particle number of CPC has to exist
28966 C input: NPOS position in /POEVT1/
28967 C ISP 0 decay according to phase space
28968 C 1 decay according to transversal polarization
28969 C 2 decay according to longitudinal polarization
28970 C 3 decay with limited phase space
28971 C ILEV decay mode to use
28973 C 2 strong and ew of tau, charm, and bottom
28974 C 3 strong and electro-weak decays
28975 C negative: remove mother resonance after decay
28977 C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28979 C**********************************************************************
28980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28983 PARAMETER ( EPS = 1.D-15,
28986 C input/output channels
28988 COMMON /POINOU/ LI,LO
28989 C event debugging information
28991 PARAMETER (NMAXD=100)
28992 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28993 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28994 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28995 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28996 C model switches and parameters
28998 INTEGER ISWMDL,IPAMDL
28999 DOUBLE PRECISION PARMDL
29000 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29002 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29003 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29004 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29006 C standard particle data interface
29009 PARAMETER (NMXHEP=4000)
29011 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
29012 DOUBLE PRECISION PHEP,VHEP
29013 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
29014 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
29016 C extension to standard particle data interface (PHOJET specific)
29017 INTEGER IMPART,IPHIST,ICOLOR
29018 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
29020 C general particle data
29021 double precision xm_list,tau_list,gam_list,
29022 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29023 & xm_bb82_list,xm_bb102_list
29024 integer ich3_list,iba3_list,iq_list,
29025 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29026 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29027 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29028 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29029 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29030 & ich3_list(300),iba3_list(300),iq_list(3,300),
29031 & id_psm_list(6,6),id_vem_list(6,6),
29032 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29033 C particle decay data
29034 double precision wg_sec_list
29035 integer idec_list,isec_list
29036 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
29038 C auxiliary data for three particle decay
29039 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29040 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29042 DIMENSION WGHD(20),KCH(20),ID(3)
29045 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
29046 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
29049 IF(ISTHEP(NPOS).GT.11) RETURN
29052 IDcpc = IMPART(NPOS)
29053 IF(IDcpc.EQ.0) return
29054 if(idec_list(1,IDcpc).eq.0) return
29055 IDabs = iabs(IDcpc)
29057 C different decay modi (times)
29058 IF(IMODE.EQ.1) THEN
29059 if(idec_list(1,IDabs).ne.1) return
29060 ELSE IF(IMODE.EQ.2) THEN
29061 if(idec_list(1,IDabs).gt.2) return
29062 ELSE IF(IMODE.EQ.3) THEN
29063 if(idec_list(1,IDabs).gt.3) return
29065 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29069 C decay products, check for mass limitations
29072 AMIST = PHEP(5,NPOS)
29073 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29076 ID(L) = isec_list(L,I)
29077 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29079 IF(AMSUM.LT.AMIST) THEN
29081 WGHD(K) = wg_sec_list(I)
29086 WRITE(LO,'(/1X,A,I6,3E12.4)')
29087 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29093 C sample new decay channel
29094 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29099 WGSUM = WGSUM+WGHD(K)
29100 IF(XI.GT.WGSUM) GOTO 500
29102 ID(1) = isec_list(1,IK)
29103 ID(2) = isec_list(2,IK)
29104 ID(3) = isec_list(3,IK)
29105 if(IDcpc.lt.0) then
29106 ID(1) = ipho_anti(ID(1))
29107 ID(2) = ipho_anti(ID(2))
29108 ID(3) = ipho_anti(ID(3))
29112 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29113 CXS = PHEP(1,NPOS)/PTOT
29114 CYS = PHEP(2,NPOS)/PTOT
29115 CZS = PHEP(3,NPOS)/PTOT
29118 GAM = PHEP(4,NPOS)/AMIST
29120 IF(ID(3).EQ.0) THEN
29121 C two particle decay
29122 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29124 C three particle decay
29125 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29126 & pho_pmass(ID(3),0),ISP)
29130 IF(NHEP.NE.NPOS) THEN
29131 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29132 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29135 IMO1 = JMOHEP(1,NPOS)
29136 IMO2 = JMOHEP(2,NPOS)
29142 IPH1 = IPHIST(1,NPOS)
29143 IPH2 = IPHIST(2,NPOS)
29145 C back transformation and registration
29147 IF(ID(I).NE.0) THEN
29148 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29149 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29153 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29154 & IPH1,IPH2,0,0,IPOS,1)
29160 IF(IDEB(36).GE.20) THEN
29161 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29162 & '--------------------'
29168 CDECK ID>, PHO_SDECY2
29169 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29170 C**********************************************************************
29172 C isotropic/anisotropic two particle decay in CM system,
29173 C (transversely/longitudinally polarized boson into two
29174 C pseudo-scalar mesons)
29176 C**********************************************************************
29177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29180 C input/output channels
29182 COMMON /POINOU/ LI,LO
29183 C auxiliary data for three particle decay
29184 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29185 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29190 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29192 WAU=ECM(1)*ECM(1)-AM11
29193 IF(WAU.LT.0.D0) THEN
29194 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29200 CALL PHO_SFECFE(SIF(1),COF(1))
29203 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29204 ELSE IF(ISP.EQ.1) THEN
29205 C transverse polarization
29207 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29208 SID12 = 1.D0-COD(1)*COD(1)
29209 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29210 ELSE IF(ISP.EQ.2) THEN
29211 C longitudinal polarization
29213 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29214 COD12 = COD(1)*COD(1)
29215 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29217 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29218 & 'invalid polarization',ISP
29228 CDECK ID>, PHO_SDECY3
29229 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29230 C**********************************************************************
29232 C isotropic/anisotropic three particle decay in CM system,
29233 C (transversely/longitudinally polarized boson into three
29234 C pseudo-scalar mesons)
29236 C**********************************************************************
29237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29240 PARAMETER ( DEPS = 1.D-30,
29243 C input/output channels
29245 COMMON /POINOU/ LI,LO
29246 C auxiliary data for three particle decay
29247 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29248 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29250 DIMENSION F(5),XX(5)
29252 C calculation of maximum of S2 phase space weight
29256 UFAK=1.0000000000001D0
29257 IF (GU.GT.GO) UFAK=0.99999999999999D0
29270 S22=GU+(I-1.D0)*DS2
29272 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29273 IF(RHO2.LT.RHO1) GOTO 125
29277 S2SUP=(S22-S21)/2.D0+S21
29278 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29280 SUPRHO=SUPRHO*1.05D0
29282 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29283 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29289 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29290 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29292 X4=(XX(1)+XX(2))*0.5D0
29293 X5=(XX(2)+XX(3))*0.5D0
29294 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29295 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29301 IF(F(II).LT.F(III)) THEN
29316 IF (XX(II).LT.XX(III)) THEN
29334 IF(ITH.GT.200) THEN
29335 WRITE(LO,'(/1X,A,I10)')
29336 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29339 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29340 Y=DT_RNDM(AM23)*SUPRHO
29341 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29342 IF(Y.GT.RHO) GOTO 200
29345 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29346 & /(2.D0*S2)-RHO/2.D0
29347 S3=UMO2+AM11+AM22+AM33-S1-S2
29348 ECM(1)=(UMO2+AM11-S2)/UMOO
29349 ECM(2)=(UMO2+AM22-S3)/UMOO
29350 ECM(3)=(UMO2+AM33-S1)/UMOO
29351 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29352 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29353 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29355 C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29356 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29357 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29359 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29361 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29362 & /(2.D0*PCM(2)*PCM(3))
29363 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29364 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29365 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29367 C selection of the sperical coordinates of particle 3
29368 CALL PHO_SFECFE(SIF(3),COF(3))
29371 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29372 ELSE IF(ISP.EQ.1) THEN
29373 C transverse polarization
29375 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29376 SID32 = 1.D0-COD(3)*COD(3)
29377 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29378 ELSE IF(ISP.EQ.2) THEN
29379 C longitudinal polarization
29381 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29382 COD32 = COD(3)*COD(3)
29383 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29385 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29386 & 'invalid polarization',ISP
29390 C selection of the rotation angle of p1-p2 plane along p3
29392 CALL PHO_SFECFE(SFE,CFE)
29404 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29405 COD(1)=CX11*COD(3)+CZ11*SID3
29406 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29407 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29408 & COD(1),COF(3),SID3,CX11,CZ11
29409 CALL PHO_PREVNT(-1)
29412 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29413 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29414 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29415 COD(2)=CX22*COD(3)+CZ22*SID3
29416 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29417 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29418 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29422 CDECK ID>, PHO_DFMASS
29423 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29424 C**********************************************************************
29426 C sampling of Mx diffractive mass distribution within
29427 C limits XMIN, XMAX
29429 C input: XMIN,XMAX mass limitations (GeV)
29430 C PREF2 original particle mass/ reference mass
29431 C (squared, GeV**2)
29432 C PVIRT2 particle virtuality
29433 C IMODE M**2 mass distribution
29435 C 2 1/(M**2+Q**2)**alpha
29436 C -1 1/(M**2-Mref**2+Q**2)
29437 C -2 1/(M**2-Mref**2+Q**2)**alpha
29439 C output: diffractive mass (GeV)
29441 C**********************************************************************
29442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29445 PARAMETER(EPS = 1.D-10)
29447 C input/output channels
29449 COMMON /POINOU/ LI,LO
29450 C event debugging information
29452 PARAMETER (NMAXD=100)
29453 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29454 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29455 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29456 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29457 C model switches and parameters
29459 INTEGER ISWMDL,IPAMDL
29460 DOUBLE PRECISION PARMDL
29461 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29463 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29464 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29465 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29467 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29468 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29469 & 'invalid mass limits',XMIN,XMAX,PREF2
29470 CALL PHO_PREVNT(-1)
29471 PHO_DFMASS = 0.135D0
29475 IF(IMODE.GT.0) THEN
29478 PM2 = PREF2 - PVIRT2
29482 IF(ABS(IMODE).EQ.1) THEN
29483 XMIN2 = LOG(XMIN**2-PM2)
29484 XMAX2 = LOG(XMAX**2-PM2)
29485 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29488 C supercritical pomeron
29489 ELSE IF(ABS(IMODE).EQ.2) THEN
29490 DDELTA = 1.D0-PARMDL(48)
29491 XMIN2 = (XMIN**2-PM2)**DDELTA
29492 XMAX2 = (XMAX**2-PM2)**DDELTA
29493 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29494 XMA2 = XI**(1.D0/DDELTA)+PM2
29496 WRITE(LO,'(/,1X,A,I3)')
29497 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29501 PHO_DFMASS = SQRT(XMA2)
29503 IF(IDEB(43).GE.15) THEN
29504 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29505 & XMIN,XMAX,PREF2,SQRT(XMA2)
29510 CDECK ID>, PHO_DIFSLP
29511 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29513 C**********************************************************************
29515 C sampling of T (Mandelstam variable) distribution within
29516 C certain limits TMIN, TMAX
29518 C input: IDF1,2 type of diffractive vertex
29519 C 0 elastic/quasi-elastic scattering
29520 C 1 diffraction dissociation
29521 C IVEC1,2 vector meson IDs in case of quasi-elastic
29522 C scattering, otherwise 0
29523 C XM1 mass of diffractive system 1 (GeV)
29524 C XM2 mass of diffractive system 2 (GeV)
29525 C XMX max. mass of diffractive system (GeV)
29527 C output: TT squared momentum transfer ( < 0, GeV**2)
29528 C SLWGHT weight to allow for mass-dependent slope
29529 C IREJ 0 successful sampling
29530 C 1 masses too big for given T range
29532 C**********************************************************************
29533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29536 PARAMETER(EPS = 1.D-10)
29538 C input/output channels
29540 COMMON /POINOU/ LI,LO
29541 C event debugging information
29543 PARAMETER (NMAXD=100)
29544 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29545 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29546 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29547 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29548 C model switches and parameters
29550 INTEGER ISWMDL,IPAMDL
29551 DOUBLE PRECISION PARMDL
29552 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29553 C internal rejection counters
29555 PARAMETER (NMXJ=60)
29556 CHARACTER*10 REJTIT
29558 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29559 C c.m. kinematics of diffraction
29561 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29562 & SIDD,CODD,SIFD,COFD,PDCMS
29563 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29564 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29566 INTEGER IPFIL,IFAFIL,IFBFIL
29567 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29568 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29569 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29570 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29571 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29572 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29573 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29574 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29575 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29576 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29577 & IPFIL,IFAFIL,IFBFIL
29578 C Reggeon phenomenology parameters
29579 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29580 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29581 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29582 & ALREG,ALREGP,GR(2),B0REG(2),
29583 & GPPP,GPPR,B0PPP,B0PPR,
29584 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29585 C parameters of 2x2 channel model
29586 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29587 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29588 C parameters of the "simple" Vector Dominance Model
29589 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29590 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29592 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29593 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29594 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29601 C range of momentum transfer t
29604 C determine min. abs(t) necessary to produce masses
29606 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29607 IF(PCMP2.LE.0.D0) THEN
29612 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29613 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29615 IF(TMINP.LT.TMAX) THEN
29616 IF(IDEB(44).GE.3) THEN
29617 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29618 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29619 & XM1,XM2,TMIN,TMAX,TMINP
29621 IFAIL(32) = IFAIL(32)+1
29626 TMINA = MIN(TMIN,TMINP)
29628 C calculation of slope (mass-dependent parametrization)
29629 IF(IDF1+IDF2.GT.0) THEN
29630 C diffraction dissociation
29631 XMP12 = XM1**2+PVIRTD(1)
29632 XMP22 = XM2**2+PVIRTD(2)
29635 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29636 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29637 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29638 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29639 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29640 SLOPE = MAX(SLOPE,1.D0)
29646 ELSE IF(IDF1.EQ.0) THEN
29649 XMP12 = XMA1**2+PVIRTD(1)
29650 XMP22 = XMA2**2+PVIRTD(2)
29653 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29654 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29655 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29656 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29657 SLMIN = MAX(SLMIN,1.D0)
29659 C elastic/quasi-elastic scattering
29660 IF(ISWMDL(13).EQ.0) THEN
29661 C external slope values
29662 PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
29664 ELSE IF(ISWMDL(13).EQ.1) THEN
29666 IF(IVEC1*IVEC2.EQ.0) THEN
29669 SLOPE = SLOVM(IVEC1,IVEC2)
29673 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29679 C determine max. abs(t) to avoid underflows
29680 TMAXP = -25.D0/SLOPE
29681 TMAXA = MAX(TMAX,TMAXP)
29683 IF(TMINA.LT.TMAXA) THEN
29684 IF(IDEB(44).GE.3) THEN
29685 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29686 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29687 & XM1,XM2,TMINA,TMAXA,SLOPE
29689 IFAIL(32) = IFAIL(32)+1
29695 C sampling from corrected range of T
29696 TMINE = EXP(SLMIN*TMINA)
29697 TMAXE = EXP(SLMIN*TMAXA)
29698 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29700 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29703 IF(IDEB(44).GE.15) THEN
29704 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29705 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29706 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29707 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29711 CDECK ID>, PHO_DIFKIN
29712 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29713 C**********************************************************************
29715 C calculation of diffractive kinematics
29717 C input: XMP1 mass of outgoing particle system 1 (GeV)
29718 C XMP2 mass of outgoing particle system 2 (GeV)
29719 C TT momentum transfer (GeV**2, negative)
29721 C output: PMOM1(5) four momentum of outgoing system 1
29722 C PMOM2(5) four momentum of outgoing system 2
29723 C IREJ 0 kinematics consistent
29724 C 1 kinematics inconsistent
29726 C**********************************************************************
29727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29730 PARAMETER(EPS = 1.D-10,
29733 C input/output channels
29735 COMMON /POINOU/ LI,LO
29736 C event debugging information
29738 PARAMETER (NMAXD=100)
29739 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29740 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29741 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29742 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29743 C c.m. kinematics of diffraction
29745 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29746 & SIDD,CODD,SIFD,COFD,PDCMS
29747 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29748 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29750 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29751 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29752 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29754 DOUBLE PRECISION PMOM1,PMOM2
29755 DIMENSION PMOM1(5),PMOM2(5)
29758 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29759 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29760 & ECMD,PCMD,XMP1,XMP2,TT
29762 C general kinematic constraints
29764 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29766 C new squared cms momentum
29771 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29773 C new longitudinal/transverse momentum
29774 E1I = SQRT(PCM2+PMASSD(1)**2)
29775 E1F = SQRT(PCMP2+XMP12)
29776 E2F = SQRT(PCMP2+XMP22)
29777 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29778 PTRAN = PCMP2-PLONG**2
29780 C check consistency of kinematics
29781 IF(PTRAN.LT.0.D0) THEN
29782 IF(IDEB(49).GE.1) THEN
29783 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29784 & 'inconsistent kinematics in event call: ',KEVENT
29785 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29786 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29787 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29792 PTRAN = SQRT(PTRAN)
29794 XI = PI2*DT_RNDM(PTRAN)
29796 C outgoing momenta in cm. system
29798 PMOM1(1) = PTRAN*COS(XI)
29799 PMOM1(2) = PTRAN*SIN(XI)
29804 PMOM2(1) = -PMOM1(1)
29805 PMOM2(2) = -PMOM1(2)
29810 C debug output / precision check
29811 IF(IDEB(49).GE.0) THEN
29813 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29814 & -PMOM1(1)**2-PMOM1(2)**2
29815 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29816 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29817 & -PMOM2(1)**2-PMOM2(2)**2
29818 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29819 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29820 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29821 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29822 & XMP1,XM1,XMP2,XM2
29823 CALL PHO_PREVNT(-1)
29826 IF(IDEB(49).GT.10) THEN
29827 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29828 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
29834 CDECK ID>, PHO_VECRES
29835 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29836 C**********************************************************************
29838 C sampling of vector meson resonance in diffractive processes
29839 C (nothing done for hadrons)
29841 C input: /POSVDM/ VDMFAC factors
29843 C output: IVEC 0 incoming hadron
29847 C 4 pi+/pi- background
29848 C RMASS mass of vector meson (GeV)
29849 C IDPDG particle ID according to PDG
29850 C IDBAM particle ID according to CPC
29852 C**********************************************************************
29853 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29856 PARAMETER(EPS = 1.D-10)
29858 C input/output channels
29860 COMMON /POINOU/ LI,LO
29861 C event debugging information
29863 PARAMETER (NMAXD=100)
29864 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29865 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29866 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29867 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29868 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
29869 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29870 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29871 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29872 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29873 C parameters of the "simple" Vector Dominance Model
29874 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29875 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29877 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29878 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29879 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29881 C particle code translation
29882 DIMENSION ITRANS(4)
29883 C rho0,omega,phi,pi+/pi-
29884 DATA ITRANS /113, 223, 333, 92 /
29888 C vector meson production
29889 IF(IDPDG.EQ.22) THEN
29890 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29893 SUM = SUM + VMFA(K)
29894 IF(XI.LE.SUM) GOTO 65
29899 IDBAM = ipho_pdg2id(IDPDG)
29901 C sample mass of vector meson
29902 CALL PHO_SAMASS(IDPDG,RMASS)
29904 C hadronic resonance of multi-pomeron coupling
29905 ELSE IF(IDPDG.EQ.990) THEN
29908 IDBAM = ipho_pdg2id(IDPDG)
29910 C sample mass of two-pion system
29911 CALL PHO_SAMASS(IDPDG,RMASS)
29913 C hadron remnants in inucleus interactions
29914 ELSE IF(IDPDG.EQ.81) THEN
29915 IF(IHFLD(1,1).EQ.0) THEN
29916 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29917 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29919 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29921 RMAS1 = PHO_PMASS(IDBA1,0)
29922 RMAS2 = PHO_PMASS(IDBA2,0)
29923 IF((IDBA2.NE.0).AND.
29924 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29931 IDPDG = IPHO_ID2PDG(IDBAM)
29933 ELSE IF(IDPDG.EQ.82) THEN
29934 IF(IHFLD(2,1).EQ.0) THEN
29935 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29936 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29938 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29940 RMAS1 = PHO_PMASS(IDBA1,0)
29941 RMAS2 = PHO_PMASS(IDBA2,0)
29942 IF((IDBA2.NE.0).AND.
29943 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29950 IDPDG = IPHO_ID2PDG(IDBAM)
29954 IF(IDEB(47).GE.5) THEN
29955 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29956 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29957 & IDPDO,IDPDG,IDBAM,RMASS
29962 CDECK ID>, PHO_DIFRES
29963 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29964 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29965 C**********************************************************************
29967 C list of resonance states for low mass resonances
29969 C input: IDMOTH PDG ID of mother particle
29970 C IVAL1,2 quarks (photon only)
29972 C output: IDPDG list of PDG IDs for possible resonances
29973 C IDBAM list of corresponding CPC IDs
29975 C RGAMS decay width
29976 C RMASS additional weight factor
29977 C LISTL entries in current list
29979 C**********************************************************************
29980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29983 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29985 PARAMETER (EPS = 1.D-10,
29988 C input/output channels
29990 COMMON /POINOU/ LI,LO
29991 C event debugging information
29993 PARAMETER (NMAXD=100)
29994 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29995 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29996 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29997 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29998 C particle ID translation table
29999 integer ID_pdg_list,ID_list,ID_pdg_max
30000 character*12 name_list
30001 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
30003 C general particle data
30004 double precision xm_list,tau_list,gam_list,
30005 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30006 & xm_bb82_list,xm_bb102_list
30007 integer ich3_list,iba3_list,iq_list,
30008 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30009 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30010 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30011 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30012 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30013 & ich3_list(300),iba3_list(300),iq_list(3,300),
30014 & id_psm_list(6,6),id_vem_list(6,6),
30015 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30017 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
30018 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
30019 & 12212, 42212, -12212, -42212,
30021 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
30022 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
30030 if(IRPDG(i).ne.0) then
30031 IRBAM(i) = ipho_pdg2id(IRPDG(i))
30037 C copy table with particles and isospin weights
30039 IF(IDMOTH.EQ.22) THEN
30042 ELSE IF(IDMOTH.EQ.2212) THEN
30045 ELSE IF(IDMOTH.EQ.-2212) THEN
30054 IDBAM(LISTL) = IRBAM(I)
30055 IDPDG(LISTL) = IRPDG(I)
30056 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30057 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
30058 RWG(LISTL) = RWGHT(I)
30062 IF(IDEB(85).GE.20) THEN
30063 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30066 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30072 CDECK ID>, PHO_MASSAD
30073 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30074 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30075 C***********************************************************************
30077 C fine-correction of low mass strings to mass of corresponding
30078 C resonance or two particle threshold
30080 C input: IFLMO PDG ID of mother particle
30081 C IFL1,2 requested parton flavours
30082 C (not used at the moment)
30083 C PMASS reference mass (mass of mother particle)
30084 C XMCON conjecture of mass
30086 C output: XMOUT output mass (adjusted input mass)
30087 C moved ot nearest mass possible
30088 C IDPDG PDG resonance ID
30089 C IDcpc CPC resonance ID
30091 C**********************************************************************
30092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30095 PARAMETER ( DEPS = 1.D-8 )
30097 C input/output channels
30099 COMMON /POINOU/ LI,LO
30100 C event debugging information
30102 PARAMETER (NMAXD=100)
30103 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30104 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30105 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30106 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30107 C model switches and parameters
30109 INTEGER ISWMDL,IPAMDL
30110 DOUBLE PRECISION PARMDL
30111 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30112 C general particle data
30113 double precision xm_list,tau_list,gam_list,
30114 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30115 & xm_bb82_list,xm_bb102_list
30116 integer ich3_list,iba3_list,iq_list,
30117 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30118 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30119 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30120 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30121 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30122 & ich3_list(300),iba3_list(300),iq_list(3,300),
30123 & id_psm_list(6,6),id_vem_list(6,6),
30124 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30125 C particle decay data
30126 double precision wg_sec_list
30127 integer idec_list,isec_list
30128 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30131 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30138 C resonance treatment activated?
30139 IF(ISWMDL(23).EQ.0) RETURN
30141 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30142 IF(LISTL.LT.1) THEN
30143 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30144 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30149 PMASSL = (PMASS+0.15D0)**2
30151 C determine resonance probability
30153 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30154 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30155 C sample new resonance
30158 XWG(I) = RWG(I)/RMA(I)**2
30159 XWGSUM = XWGSUM+XWG(I)
30173 XI = XWGSUM*DT_RNDM(XMOUT)
30176 XWGSUM = XWGSUM-XWG(I)
30177 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30183 C sample new mass (from Breit-Wigner cross section)
30184 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30185 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30186 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30187 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30188 XMOUT = SQRT(XMOUT)
30190 C check mass for decay
30193 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30196 IF(isec_list(I,IK).NE.0)
30197 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30199 AMDCY = MIN(AMDCY,AMSUM)
30201 IF(AMDCY.GE.XMOUT) GOTO 150
30205 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30207 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30208 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30215 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30216 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30217 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30222 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30223 C***************************************************************
30225 C call different PDF sets for different particle types
30227 C input: NPAR 1 IGRP(1),ISET(1)
30228 C 2 IGRP(2),ISET(2)
30229 C X momentum fraction
30230 C SCALE2 squared scale (GeV**2)
30231 C P2VIR particle virtuality (positive, GeV**2)
30233 C output PD(-6:6) field containing the x*PDF fractions
30235 C***************************************************************
30236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30241 C input/output channels
30243 COMMON /POINOU/ LI,LO
30244 C currently activated parton density parametrizations
30246 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30247 DOUBLE PRECISION PDFLAM,PDFQ2M
30248 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30249 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30250 C event debugging information
30252 PARAMETER (NMAXD=100)
30253 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30254 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30255 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30256 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30257 C model switches and parameters
30259 INTEGER ISWMDL,IPAMDL
30260 DOUBLE PRECISION PARMDL
30261 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30263 DIMENSION PARAM(20),VALUE(20)
30266 REAL XR,P2R,Q2R,F2GM,XPDFGM
30267 DIMENSION XPDFGM(-6:6)
30269 C check of kinematic boundaries
30272 IF(IDEB(37).GE.0) THEN
30273 WRITE(LO,'(/,1X,A,E15.8/)')
30274 & 'PHO_PDF: x>1 (corrected to x=1)',X
30275 CALL PHO_PREVNT(-1)
30277 XI = 0.99999999999D0
30278 ELSE IF(X.LE.0.D0) THEN
30279 IF(IDEB(37).GE.0) THEN
30280 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30281 CALL PHO_PREVNT(-1)
30291 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30295 IF(IEXT(NPAR).EQ.0) THEN
30296 IF(ITYPE(NPAR).EQ.1) THEN
30298 IF(IGRP(NPAR).EQ.5) THEN
30299 IF(ISET(NPAR).EQ.3) THEN
30300 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30305 ELSE IF(ISET(NPAR).EQ.4) THEN
30306 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30311 ELSE IF(ISET(NPAR).EQ.5) THEN
30312 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30313 C heavy quarks from GRV92-HO
30315 ALAM2 = 0.248 * 0.248
30316 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30320 AKC = -0.625 - 0.523 * S
30322 BC = 1.896 + 1.616 * S
30323 DC = 4.12 + 0.683 * S
30324 EC = 4.36 + 1.328 * S
30325 ESC = 0.677 + 0.679 * S
30326 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30330 AKB = 0.0 - 0.193 * S
30333 DB = 3.447 + 0.927 * S
30334 EB = 4.68 + 1.259 * S
30335 ESB = 1.892 + 2.199 * S
30336 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30338 ELSE IF(ISET(NPAR).EQ.6) THEN
30339 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30340 C heavy quarks from GRV92-LO
30343 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30349 BC = 4.24 - 0.804 * S
30350 DC = 3.46 + 1.076 * S
30351 EC = 4.61 + 1.490 * S
30352 ESC = 2.555 + 1.961 * S
30353 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30360 DB = 2.929 + 1.396 * S
30361 EB = 4.71 + 1.514 * S
30362 ESB = 4.02 + 1.239 * S
30363 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30365 ELSE IF(ISET(NPAR).EQ.7) THEN
30366 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30367 C heavy quarks from GRV92-HO
30369 ALAM2 = 0.248 * 0.248
30370 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30374 AKC = -0.625 - 0.523 * S
30376 BC = 1.896 + 1.616 * S
30377 DC = 4.12 + 0.683 * S
30378 EC = 4.36 + 1.328 * S
30379 ESC = 0.677 + 0.679 * S
30380 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30384 AKB = 0.0 - 0.193 * S
30387 DB = 3.447 + 0.927 * S
30388 EB = 4.68 + 1.259 * S
30389 ESB = 1.892 + 2.199 * S
30390 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30392 ELSE IF(ISET(NPAR).EQ.8) THEN
30393 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30396 C heavy quarks from GRV92-LO
30399 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30405 BC = 4.24 - 0.804 * S
30406 DC = 3.46 + 1.076 * S
30407 EC = 4.61 + 1.490 * S
30408 ESC = 2.555 + 1.961 * S
30409 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30416 DB = 2.929 + 1.396 * S
30417 EB = 4.71 + 1.514 * S
30418 ESB = 4.02 + 1.239 * S
30419 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30421 ELSE IF(ISET(NPAR).EQ.9) THEN
30422 * CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30425 C heavy quarks from GRV92-LO
30428 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30434 BC = 4.24 - 0.804 * S
30435 DC = 3.46 + 1.076 * S
30436 EC = 4.61 + 1.490 * S
30437 ESC = 2.555 + 1.961 * S
30438 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30445 DB = 2.929 + 1.396 * S
30446 EB = 4.71 + 1.514 * S
30447 ESB = 4.02 + 1.239 * S
30448 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30454 PD(-2) = 0.5D0*(UDB-DEL)
30455 PD(-1) = 0.5D0*(UDB+DEL)
30463 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30464 C pion PDFs (default for pi+)
30465 IF(IGRP(NPAR).EQ.5) THEN
30466 IF(ISET(NPAR).EQ.1) THEN
30467 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30469 ELSE IF(ISET(NPAR).EQ.2) THEN
30470 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30485 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30487 IF(IGRP(NPAR).EQ.5) THEN
30488 IF(ISET(NPAR).EQ.1) THEN
30489 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30491 ELSE IF(ISET(NPAR).EQ.2) THEN
30492 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30494 ELSE IF(ISET(NPAR).EQ.3) THEN
30495 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30498 C reweight with Drees-Godbole factor
30500 IF(P2VIR.GT.0.001D0) THEN
30501 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30502 & /LOG(SCALE2/PARMDL(144))
30503 WGX = MAX(WGX,0.D0)
30505 PD(-5) = BB*WGX/137.D0
30506 PD(-4) = CB*WGX/137.D0
30507 PD(-3) = SB*WGX/137.D0
30508 PD(-2) = UB*WGX/137.D0
30509 PD(-1) = DB*WGX/137.D0
30510 PD(0) = GL*WGX*WGX/137.D0
30516 ELSE IF(IGRP(NPAR).EQ.8) THEN
30517 IF(ISET(NPAR).EQ.1) THEN
30518 CALL PHO_PHGAL (XI,SCALE2,PD)
30522 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30526 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30528 ELSE IF(MODE.EQ.2) THEN
30529 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30531 ELSE IF(MODE.EQ.3) THEN
30532 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30534 ELSE IF(MODE.EQ.4) THEN
30535 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30537 PD(I) = PD(I)*PARMDL(78)
30545 ELSE IF(IEXT(NPAR).EQ.2) THEN
30546 C PDFLIB call: new PDF numbering
30547 IF(NPAR.NE.NPAOLD) THEN
30548 PARAM(1) = 'NPTYPE'
30549 PARAM(2) = 'NGROUP'
30552 VALUE(1) = ITYPE(NPAR)
30553 VALUE(2) = ABS(IGRP(NPAR))
30554 VALUE(3) = ISET(NPAR)
30555 CALL PDFSET(PARAM,VALUE)
30557 IF(ITYPE(NPAR).EQ.3) THEN
30559 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30560 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30562 SCALE = SQRT(SCALE2)
30563 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30564 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30569 IF(ITYPE(NPAR).EQ.1) THEN
30570 C proton valence quarks
30571 PD(1) = PD(1)+PD(-1)
30572 PD(2) = PD(2)+PD(-2)
30573 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30577 PD(-1) = DVAL+PD(1)
30578 PD(2) = PD(2)+PD(-2)
30579 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30580 C photon conventions
30586 ELSE IF(IEXT(NPAR).EQ.3) THEN
30587 C PHOLIB call: version 2.0
30588 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30590 WRITE(LO,'(/1X,A,I2)')
30591 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30596 C photon PDFs depending on photon virtuality
30598 ELSE IF(IEXT(NPAR).EQ.4) THEN
30599 IF(IGRP(NPAR).EQ.1) THEN
30600 C Schuler/Sjostrand PDF (interface to single precision)
30605 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30607 PD(I) = DBLE(XPDFGM(I))
30610 ELSE IF(IGRP(NPAR).EQ.5) THEN
30611 C Gluck/Reya/Stratmann
30612 IF(ISET(NPAR).EQ.4) THEN
30613 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30614 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30635 WRITE(LO,'(/1X,A,/10X,5I6)')
30636 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30637 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30642 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30647 C valence quark treatment
30649 IF(ITYPE(NPAR).EQ.2) THEN
30650 C meson conventions
30651 IF(IPARID(NPAR).EQ.111) THEN
30652 C pi0 valence quarks
30653 PD(-1) = (PD(1)+PD(-1))/2.D0
30655 PD(-2) = (PD(2)+PD(-2))/2.D0
30657 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30659 VALS = PD(-1)-PD(1)
30661 PD(-3) = PD(-3)+VALS
30662 ELSE IF( (IPARID(NPAR).EQ.311)
30663 & .OR.(IPARID(NPAR).EQ.310)
30664 & .OR.(IPARID(NPAR).EQ.130)) THEN
30666 VALS = PD(-1)-PD(1)
30667 VALU = PD(2)-PD(-2)
30670 PD(2) = PD(2)+VALU/2.D0
30671 PD(-2) = PD(-2)+VALU/2.D0
30672 PD(3) = PD(3)+VALS/2.D0
30673 PD(-3) = PD(-3)+VALS/2.D0
30675 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30676 C nucleon conventions
30677 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30678 C neutron valence quarks
30682 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30684 VALS = PD(1)-PD(-1)
30687 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30689 VALS = PD(1)-PD(-1)
30690 VALD = PD(2)-PD(-2)
30695 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30696 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30697 C (anti-)sigma0 and (anti-)lambda
30698 VALS = PD(1)-PD(-1)
30699 VALD = (PD(2)-PD(-2))/2.D0
30709 IF(IPARID(NPAR).LT.0) THEN
30717 C optionally remove valence quarks
30718 IF(IPAVA(NPAR).EQ.0) THEN
30720 PD(I) = MIN(PD(-I),PD(I))
30725 C debug information
30726 IF(IDEB(37).GE.30) WRITE(LO,
30727 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30728 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30729 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30730 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30734 CDECK ID>, PHO_QPMPDF
30735 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30736 C***************************************************************
30738 C contribution to photon PDF from box graph
30739 C (Bethe-Heitler process)
30741 C input: IQ quark flavour
30742 C SCALE2 scale (GeV**2, positive)
30743 C PTREF reference scale (GeV, positive)
30744 C X parton momentum fraction
30745 C PVIRT photon virtuality (GeV**2, positive)
30746 C FXP x*f(x,Q**2), x times parton density
30748 C***************************************************************
30749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30752 C input/output channels
30754 COMMON /POINOU/ LI,LO
30755 C event debugging information
30757 PARAMETER (NMAXD=100)
30758 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30759 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30760 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30761 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30762 C internal rejection counters
30764 PARAMETER (NMXJ=60)
30765 CHARACTER*10 REJTIT
30767 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30769 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30770 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30771 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30774 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30779 * QM2 = MAX(QM(I),PTREF)**2
30780 * QM2 = MAX(QM2,PVIRT)
30781 * BBE = (1.D0-X)*SCALE2
30782 * IF(BBE.LE.0.D0) THEN
30783 * IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30784 * & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30787 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30788 * & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30789 C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30790 QM2 = MAX(QM(I),PTREF)**2
30791 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30792 IF(W2.GT.4.D0*QM2) THEN
30793 BE = SQRT(1.D0-4.D0*QM2/W2)
30794 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30795 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30796 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30797 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30798 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30799 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30800 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30801 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30803 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30804 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30808 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30809 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30812 CDECK ID>, PHO_SETPDF
30813 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30814 C***************************************************************
30816 C assigns PDF numbers to particles
30818 C input: IDPDG PDG number of particle
30819 C ITYP particle type
30820 C IPAR PDF paramertization
30821 C ISET number of set
30822 C IEXT library number for PDF calculation
30823 C IPAVAL (only output)
30824 C 1 PDF with valence quarks
30825 C 0 PDF without valence quarks
30826 C MODE -1 add entry to table
30827 C 1 read from table
30828 C 2 output of table
30830 C***************************************************************
30831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30834 C input/output channels
30836 COMMON /POINOU/ LI,LO
30837 C event debugging information
30839 PARAMETER (NMAXD=100)
30840 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30841 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30842 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30843 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30844 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30845 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30846 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30847 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30848 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30850 DIMENSION IPDFS(5,50)
30855 IF(IDPDG.EQ.81) THEN
30858 ELSE IF(IDPDG.EQ.82) THEN
30866 IF(IDCMP.EQ.IPDFS(1,I)) THEN
30871 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30872 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30876 IF(I.GT.IENTRY) THEN
30877 WRITE(LO,'(/1X,A,I7)')
30878 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
30882 ELSE IF(MODE.EQ.-1) THEN
30884 IF(IDPDG.EQ.IPDFS(1,I)) THEN
30885 WRITE(LO,'(/1X,A,5I6)')
30886 & 'PHO_SETPDF: overwrite old particle PDF',
30887 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30893 WRITE(LO,'(/1X,A,/1x,6I6)')
30894 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
30895 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30901 IF(IDPDG.EQ.990) THEN
30903 ELSE IF(IDPDG.EQ.22) THEN
30905 ELSE IF(ABS(IDPDG).LT.1000) THEN
30914 ELSE IF(MODE.EQ.-2) THEN
30915 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30917 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
30918 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30921 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30925 CDECK ID>, PHO_GETPDF
30926 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30927 C***************************************************************
30929 C get PDF information
30931 C input: NPAR 1 first PDF in /POPPDF/
30932 C 2 second PDF in /POPPDF/
30934 C output: PDFNA name of PDf parametrization
30935 C ALA QCD LAMBDA (4 flavours, in GeV)
30941 C***************************************************************
30942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30947 C input/output channels
30949 COMMON /POINOU/ LI,LO
30951 C PHOLIB 4.15 common
30952 COMMON /W50512/ QCDL4,QCDL5
30953 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30955 C PHOPDF version 2.0 common
30956 PARAMETER (MAXS=6,MAXP=10)
30958 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30959 & NSET(MAXP,2),NFL(MAXP)
30960 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30962 C currently activated parton density parametrizations
30964 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30965 DOUBLE PRECISION PDFLAM,PDFQ2M
30966 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30967 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30969 DIMENSION PARAM(20),VALUE(20)
30972 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30973 WRITE(LO,'(/1X,A,I6)')
30974 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30979 IF(IEXT(NPAR).EQ.0) THEN
30981 C internal parametrizations
30983 IF(ITYPE(NPAR).EQ.1) THEN
30985 IF(IGRP(NPAR).EQ.5) THEN
30986 IF(ISET(NPAR).EQ.3) THEN
30990 ELSE IF(ISET(NPAR).EQ.4) THEN
30994 ELSE IF(ISET(NPAR).EQ.5) THEN
30998 ELSE IF(ISET(NPAR).EQ.6) THEN
31002 ELSE IF(ISET(NPAR).EQ.7) THEN
31006 ELSE IF(ISET(NPAR).EQ.8) THEN
31010 ELSE IF(ISET(NPAR).EQ.9) THEN
31016 ELSE IF(ITYPE(NPAR).EQ.2) THEN
31018 IF(IGRP(NPAR).EQ.5) THEN
31019 IF(ISET(NPAR).EQ.1) THEN
31023 ELSE IF(ISET(NPAR).EQ.2) THEN
31029 ELSE IF(ITYPE(NPAR).EQ.3) THEN
31031 IF(IGRP(NPAR).EQ.5) THEN
31032 IF(ISET(NPAR).EQ.1) THEN
31036 ELSE IF(ISET(NPAR).EQ.2) THEN
31040 ELSE IF(ISET(NPAR).EQ.3) THEN
31045 ELSE IF(IGRP(NPAR).EQ.8) THEN
31046 IF(ISET(NPAR).EQ.1) THEN
31052 ELSE IF(ITYPE(NPAR).EQ.20) THEN
31054 IF(IGRP(NPAR).EQ.4) THEN
31055 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31063 C external parametrizations
31065 ELSE IF(IEXT(NPAR).EQ.1) THEN
31066 C PDFLIB call: old numbering
31069 VALUE(1) = IGRP(NPAR)
31070 CALL PDFSET(PARAM,VALUE)
31077 ELSE IF(IEXT(NPAR).EQ.2) THEN
31078 C PDFLIB call: new numbering
31079 PARAM(1) = 'NPTYPE'
31080 PARAM(2) = 'NGROUP'
31083 VALUE(1) = ITYPE(NPAR)
31084 VALUE(2) = IGRP(NPAR)
31085 VALUE(3) = ISET(NPAR)
31086 CALL PDFSET(PARAM,VALUE)
31093 ELSE IF(IEXT(NPAR).EQ.3) THEN
31095 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31097 PDFNA = CHPAR(IGRP(NPAR))
31099 C some special internal parametrizations
31101 ELSE IF(IEXT(NPAR).EQ.4) THEN
31102 C photon PDFs depending on virtualities
31103 IF(IGRP(NPAR).EQ.1) THEN
31104 C Schuler/Sjostrand parametrization
31106 IF(ISET(NPAR).EQ.1) THEN
31109 ELSE IF(ISET(NPAR).EQ.2) THEN
31112 ELSE IF(ISET(NPAR).EQ.3) THEN
31115 ELSE IF(ISET(NPAR).EQ.4) THEN
31119 ELSE IF(IGRP(NPAR).EQ.5) THEN
31120 C Gluck/Reya/Stratmann parametrization
31121 IF(ISET(NPAR).EQ.4) THEN
31127 ELSE IF(IEXT(NPAR).EQ.5) THEN
31128 C Schuler/Sjostrand anomalous only
31133 IF(ALA.LT.0.01D0) THEN
31134 WRITE(LO,'(/1X,2A,/10X,5I6)')
31135 & 'PHO_GETPDF:ERROR: ',
31136 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31137 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31143 CDECK ID>, PHO_ACTPDF
31144 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31145 C***************************************************************
31147 C activate PDF for QCD calculations
31149 C input: IDPDG PDG particle number
31150 C K 1 first PDF in /POPPDF/
31151 C 2 second PDF in /POPPDF/
31152 C -2 write current settings
31156 C***************************************************************
31157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31160 C input/output channels
31162 COMMON /POINOU/ LI,LO
31163 C event debugging information
31165 PARAMETER (NMAXD=100)
31166 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31167 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31168 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31169 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31170 C currently activated parton density parametrizations
31172 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31173 DOUBLE PRECISION PDFLAM,PDFQ2M
31174 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31175 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31179 C read PDF from table
31180 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31183 C get PDF parameters
31184 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31185 C initialize alpha_s calculation
31186 alam2 = PDFLAM(K)*PDFLAM(K)
31187 DUMMY = PHO_ALPHAS(alam2,-K)
31189 IF(IDEB(2).GE.20) THEN
31191 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31192 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31193 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31194 & IEXT(K),IPARID(K)
31198 ELSE IF(K.EQ.-2) THEN
31200 C write table of current PDFs
31202 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31203 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31204 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31206 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31207 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31212 WRITE(LO,'(/1X,A,2I4)')
31213 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31220 CDECK ID>, PHO_PDFTST
31221 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31222 C*********************************************************************
31224 C structure function test utility
31226 C input: IDPDG PDG ID of particle
31227 C SCALE2 squared scale (GeV**2)
31228 C P2MASS particle virtuality (pos, GeV**2)
31230 C output: tables of PDF, sum rule checking, table of F2
31232 C*********************************************************************
31233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31236 C input/output channels
31238 COMMON /POINOU/ LI,LO
31239 C currently activated parton density parametrizations
31241 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31242 DOUBLE PRECISION PDFLAM,PDFQ2M
31243 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31244 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31246 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31247 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31248 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31250 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31253 CALL PHO_ACTPDF(IDPDG,1)
31254 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31256 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31257 WRITE(LO,'(A)') ' ======================================='
31259 WRITE(LO,'(/,A,3I10)')
31260 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31261 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31262 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31263 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31264 WRITE(LO,'(/1X,A)') 'x times parton densities'
31265 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31267 & ' ============================================================'
31269 C logarithmic loop over x values
31278 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31282 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31283 IF(X.NE.XCONTR) THEN
31284 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31286 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31287 XFIRST=XFIRST+XDELTA
31290 IF(IDPDG.EQ.22) THEN
31291 WRITE(LO,'(/1X,A)')
31292 & 'comparison PDF to contribution due to box diagram'
31293 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31295 & ' ============================================================'
31297 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31300 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31302 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31304 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31305 XFIRST=XFIRST+XDELTA
31309 C check momentum sum rule
31311 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31318 XX=DBLE(I)/DBLE(ITER)
31319 IF(XX.EQ.1.D0) XX = 0.999999D0
31320 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31322 PDSUM(K) = PDSUM(K)+PD(K)/XX
31323 PDAVE(K) = PDAVE(K)+PD(K)
31327 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31330 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31331 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31332 XSUM = XSUM+PDAVE(I)
31333 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31335 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31337 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31339 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31340 WRITE(LO,'(A/)') ' ============================================='
31344 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31345 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31346 & '-----------------------------------------------------'
31349 XX=DBLE(I)/DBLE(ITER)
31350 IF(XX.EQ.1.D0) XX = 0.9999D0
31351 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31354 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31356 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31358 WRITE(LO,'(A/)') ' ============================================='
31361 CDECK ID>, PHO_REGPAR
31362 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31363 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31364 C**********************************************************************
31366 C registration of particle in /POEVT1/ and /POEVT2/
31368 C input: ISTH status code of particle
31369 C -2 initial parton hard scattering
31372 C 1 visible particle (no color)
31373 C 2 decayed particle
31374 C IDPDG PDG particle ID code
31375 C IDBAM CPC particle ID code
31376 C JM1,JM2 first and second mother index
31377 C P1..P4 four momentum
31378 C IPHIS1 extended history information
31379 C IPHIS1<100: JM1 from particle 1
31380 C IPHIS1>100: JM1 from particle 2
31382 C 2 valence diquark
31385 C (neg. for antipartons)
31386 C IPHIS2 extended history information
31387 C positive: JM2 from particle 1
31388 C negative: JM2 from particle 2
31390 C IC1,IC2 color labels for partons
31391 C IMODE 1 register given parton
31392 C 0 reset /POEVT1/ and /POEVT2/
31393 C 2 return data of entry IPOS
31395 C IPOS position of particle in /POEVT1/
31397 C**********************************************************************
31398 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31401 PARAMETER (DEPS = 1.D-20)
31403 C input/output channels
31405 COMMON /POINOU/ LI,LO
31406 C event debugging information
31408 PARAMETER (NMAXD=100)
31409 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31410 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31411 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31412 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31414 C standard particle data interface
31417 PARAMETER (NMXHEP=4000)
31419 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31420 DOUBLE PRECISION PHEP,VHEP
31421 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31422 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31424 C extension to standard particle data interface (PHOJET specific)
31425 INTEGER IMPART,IPHIST,ICOLOR
31426 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31428 IF(IMODE.EQ.1) THEN
31429 IF(IDEB(76).GE.26) THEN
31430 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31431 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31432 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31433 WRITE(LO,'(1X,A,/2X,6I6)')
31434 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31435 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31437 IF(NHEP.EQ.NMXHEP) THEN
31438 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31439 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31445 IF(ABS(ISTH).LE.2) THEN
31446 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31447 IDPDGI = ipho_id2pdg(IDBAM)
31448 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31449 IDBAMI = ipho_pdg2id(IDPDG)
31453 ISTHEP(NHEP) = ISTH
31454 IDHEP(NHEP) = IDPDGI
31455 JMOHEP(1,NHEP) = JM1
31456 JMOHEP(2,NHEP) = JM2
31457 C update of mother-daugther relations
31458 IF(ABS(ISTH).LE.1) THEN
31460 IF(JDAHEP(1,JM1).EQ.0) THEN
31461 JDAHEP(1,JM1) = NHEP
31464 JDAHEP(2,JM1) = NHEP
31466 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31467 IF(JDAHEP(1,JM2).EQ.0) THEN
31468 JDAHEP(1,JM2) = NHEP
31471 JDAHEP(2,JM2) = NHEP
31472 ELSE IF(JM2.LT.0) THEN
31473 DO 100 II=JM1+1,-JM2
31474 IF(JDAHEP(1,II).EQ.0) THEN
31475 JDAHEP(1,II) = NHEP
31478 JDAHEP(2,II) = NHEP
31486 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31487 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31488 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31490 PHEP(5,NHEP) = 0.D0
31494 C extended information
31495 IMPART(NHEP) = IDBAMI
31496 C extended history information
31497 IPHIST(1,NHEP) = IPHIS1
31498 IPHIST(2,NHEP) = IPHIS2
31499 C charge/baryon number or color labels
31501 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31502 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31504 ICOLOR(1,NHEP) = IC1
31505 ICOLOR(2,NHEP) = IC2
31509 IF(IDEB(76).GE.26) THEN
31510 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31511 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31512 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31513 & PHEP(5,NHEP),IPOS
31516 ELSE IF(IMODE.EQ.0) THEN
31518 ELSE IF(IMODE.EQ.2) THEN
31519 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31520 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31521 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31524 ISTH = ISTHEP(IPOS)
31525 IDPDG = IDHEP(IPOS)
31526 IDBAM = IMPART(IPOS)
31527 JM1 = JMOHEP(1,IPOS)
31528 JM2 = JMOHEP(2,IPOS)
31533 IPHIS1= IPHIST(1,IPOS)
31534 IPHIS2= IPHIST(2,IPOS)
31535 IC1 = ICOLOR(1,IPOS)
31536 IC2 = ICOLOR(2,IPOS)
31538 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31542 CDECK ID>, IPHO_CNV1
31543 INTEGER FUNCTION IPHO_CNV1(IPART)
31544 C*********************************************************************
31546 C conversion of quark numbering scheme to PARTICLE DATA GROUP
31549 C input: old internal particle code of hard scattering
31555 C valence quarks changed to standard numbering
31557 C output: standard particle codes
31559 C*********************************************************************
31560 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31564 C change gluon number
31567 C change valence quark
31568 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31569 IPHO_CNV1 = SIGN(II-6,IPART)
31575 CDECK ID>, PHO_HACODE
31576 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31577 C*********************************************************************
31579 C determination of hadron index from quarks
31581 C input: ID1,ID2 parton code according to PDG conventions
31583 C output: IDcpc1,2 CPC particle codes
31585 C*********************************************************************
31591 integer ID1,ID2,IDcpc1,IDcpc2
31593 C input/output channels
31595 COMMON /POINOU/ LI,LO
31596 C event debugging information
31598 PARAMETER (NMAXD=100)
31599 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31600 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31601 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31602 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31603 C general particle data
31604 double precision xm_list,tau_list,gam_list,
31605 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31606 & xm_bb82_list,xm_bb102_list
31607 integer ich3_list,iba3_list,iq_list,
31608 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31609 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31610 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31611 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31612 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31613 & ich3_list(300),iba3_list(300),iq_list(3,300),
31614 & id_psm_list(6,6),id_vem_list(6,6),
31615 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31618 integer ii,jj,kk,i1,i2
31623 if(ID1*ID2.lt.0) then
31632 IDcpc1 = ID_psm_list(ii,jj)
31633 IDcpc2 = ID_vem_list(ii,jj)
31641 jj = (i1-ii*1000)/100
31646 kk = (i2-jj*1000)/100
31648 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31649 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31655 CDECK ID>, PHO_ID2STR
31656 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31657 C*********************************************************************
31659 C conversion of quark numbering scheme
31661 C input: standard particle codes:
31665 C output: NOBAM CPC string code
31666 C quark codes (PDG convention):
31672 C NOBAM = -1 invalid flavour combinations
31674 C*********************************************************************
31675 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31678 C input/output channels
31680 COMMON /POINOU/ LI,LO
31685 C quark-antiquark string
31686 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31687 IF((ID1*ID2).GE.0) GOTO 100
31693 C quark-diquark string
31694 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31695 IF((ID1*ID2).LE.0) GOTO 100
31698 IBAM3 = (ID2-IBAM2*1000)/100
31701 C diquark-quark string
31702 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31703 IF((ID1*ID2).LE.0) GOTO 100
31705 IBAM2 = (ID1-IBAM1*1000)/100
31709 C gluon-gluon string
31710 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31716 C diquark-antidiquark string
31717 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31718 IF((ID1*ID2).GE.0) GOTO 100
31720 IBAM2 = (ID1-IBAM1*1000)/100
31722 IBAM4 = (ID2-IBAM3*1000)/100
31727 C invalid combination
31729 WRITE(LO,'(//1X,A,2I10)')
31730 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31735 CDECK ID>, PHO_MKSLTR
31736 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31737 C********************************************************************
31739 C calculate successive Lorentz boots for arbitrary Lorentz trans.
31741 C input: P1 initial 4 vector
31742 C GAM(3),GAMB(3) Lorentz boost parameters
31744 C output: P2 final 4 vector
31746 C********************************************************************
31747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31750 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31754 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31755 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31759 CDECK ID>, PHO_GETLTR
31760 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31761 C********************************************************************
31763 C calculate Lorentz boots for arbitrary Lorentz transformation
31765 C input: P1 initial 4 vector
31766 C P2 final 4 vector
31768 C output: GAM(3),GAMB(3)
31769 C DELE energy deviation
31773 C********************************************************************
31774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31777 PARAMETER ( DREL = 0.001D0 )
31779 C input/output channels
31781 COMMON /POINOU/ LI,LO
31783 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31790 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31793 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31794 IF(PP(4).LE.0.D0) RETURN
31795 PP(4) = SQRT(PP(4))
31796 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31797 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31798 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31799 GAMB(I) = GAMB(I)*GAM(I)
31806 C consistency check
31807 * IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31808 * PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31809 * WRITE(LO,'(/1X,A,2E12.5)')
31810 * & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31811 * WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31812 * WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31813 * WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31814 * WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31818 CDECK ID>, PHO_ALTRA
31819 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31820 C*********************************************************************
31822 C arbitrary Lorentz transformation
31824 C*********************************************************************
31825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31828 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31833 P=SQRT(PX*PX+PY*PY+PZ*PZ)
31838 CDECK ID>, PHO_LTRANS
31839 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31840 & PL,CXL,CYL,CZL,EL)
31841 C**********************************************************************
31843 C Lorentz transformation into lab - system
31845 C**********************************************************************
31846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31849 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31851 C input/output channels
31853 COMMON /POINOU/ LI,LO
31855 SID=SQRT(1.D0-COD*COD)
31859 PLZ=GAM*PCMZ+BGAM*ECM
31860 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31861 EL=GAM*ECM+BGAM*PCMZ
31863 C rotation into the original direction
31865 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31867 * CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31878 IF (ABS(CX)-TINY) 1,1,2
31879 1 IF (ABS(CY)-TINY) 3,3,2
31882 * WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31886 * WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31887 * WRITE(LO,*) CXL,CYL,CZL
31891 IF(AMAX.GT.TINY2) THEN
31894 A=AMAX*SQRT(1.D0+AR)
31896 * WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
31902 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31903 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31908 CDECK ID>, PHO_TRANS
31909 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31910 C**********************************************************************
31912 C rotation of coordinate frame (1) de rotation around y axis
31913 C (2) fe rotation around z axis
31914 C (inverse rotation to PHO_TRANI)
31916 C**********************************************************************
31917 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31920 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31921 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31922 Z=-SDE *XO +CDE *ZO
31926 CDECK ID>, PHO_TRANI
31927 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31928 C**********************************************************************
31930 C rotation of coordinate frame (1) -fe rotation around z axis
31931 C (2) -de rotation around y axis
31932 C (inverse rotation to PHO_TRANS)
31934 C**********************************************************************
31935 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31938 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31940 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31944 CDECK ID>, pho_cpcini
31945 SUBROUTINE pho_cpcini(Nrows,Number,List)
31946 C***********************************************************************
31948 C initialization of particle hash table
31950 C input: Number vector with Nrows entries according to PDG
31953 C output: List vector with hash table
31955 C (this code is based on the function initpns written by
31956 C Gerry Lynch, LBL, January 1990)
31958 C***********************************************************************
31964 C input/output channels
31966 COMMON /POINOU/ LI,LO
31968 integer Number(*),List(*),Nrows
31970 Integer Nin,Nout,Ip,I
31976 C Loop over all of the elements in the Number vector
31978 Do 500 Ip = 1,Nrows
31981 C Calculate a list number for this particle id number
31982 If(Nin.Gt.99999.or.Nin.Le.0) Then
31984 Else If(Nin.Le.577) Then
31987 Nout = Mod(Nin,577)
31993 C Count the bad entries
31994 WRITE(LO,'(1x,a,i10)')
31995 & 'pho_cpcini: invalid particle ID',Nin
31998 If(List(Nout).eq.0) Then
32001 If(Nin.eq.Number(List(Nout))) Then
32002 WRITE(LO,'(1x,a,i10)')
32003 & 'pho_cpcini: double particle ID',Nin
32006 If(Nout.Gt.577) Nout = Mod(Nout, 577)
32014 CDECK ID>, ipho_pdg2id
32015 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32016 C**********************************************************************
32018 C calculation internal particle code using the particle index i
32019 C according to the PDG proposal.
32021 C input: IDpdg PDG particle number
32022 C output: ipho_pdg2id internal particle code
32023 C (0 for invalid IDpdg)
32025 C the hash algorithm is based on a program by Gerry Lynch
32027 C**********************************************************************
32035 C input/output channels
32037 COMMON /POINOU/ LI,LO
32038 C event debugging information
32040 PARAMETER (NMAXD=100)
32041 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32042 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32043 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32044 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32045 C particle ID translation table
32046 integer ID_pdg_list,ID_list,ID_pdg_max
32047 character*12 name_list
32048 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32055 if((Nin.gt.99999).or.(Nin.eq.0)) then
32056 C invalid particle number
32057 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32058 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32061 else If(Nin.le.577) then
32065 C use hash algorithm
32066 Nout = mod(Nin,577)
32071 C particle not in table
32072 if(ID_list(Nout).Eq.0) then
32073 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32074 & 'ipho_pdg2id: particle not in table ',IDpdg
32079 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32080 C particle ID found
32081 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32084 C increment and try again
32086 If(Nout.gt.577) Nout = Mod(Nout,577)
32092 CDECK ID>, IPHO_ID2PDG
32093 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32094 C**********************************************************************
32096 C conversion of internal particle code to PDG standard
32098 C input: IDcpc internal particle number
32099 C output: ipho_id2pdg PDG particle number
32100 C (0 for invalid IDcpc)
32102 C**********************************************************************
32110 C input/output channels
32112 COMMON /POINOU/ LI,LO
32113 C event debugging information
32115 PARAMETER (NMAXD=100)
32116 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32117 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32118 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32119 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32120 C particle ID translation table
32121 integer ID_pdg_list,ID_list,ID_pdg_max
32122 character*12 name_list
32123 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32129 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32134 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32138 CDECK ID>, IPHO_LU2PDG
32139 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32140 C**********************************************************************
32142 C conversion of JETSET KF code to PDG code
32144 C**********************************************************************
32145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32147 PARAMETER (NTAB=10)
32148 DIMENSION LU2PD(2,NTAB)
32149 DATA LU2PD / 4232, 4322,
32161 IF(LU2PD(1,I).EQ.LUKF) THEN
32162 IPHO_LU2PDG=LU2PD(2,I)
32170 CDECK ID>, IPHO_PDG2LU
32171 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32172 C**********************************************************************
32174 C conversion of PDG code to JETSET code
32176 C**********************************************************************
32177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32180 DIMENSION LU2PD(2,NTAB)
32181 DATA LU2PD / 4232, 4322,
32191 IF(LU2PD(2,I).EQ.IPDG) THEN
32192 IPHO_PDG2LU=LU2PD(1,I)
32200 CDECK ID>, pho_pname
32201 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32202 C***********************************************************************
32204 C returns particle name for given ID number
32206 C input: ID particle ID number
32207 C mode 0: ID treated as compressed particle code
32208 C 1: ID treated as PDG number
32210 C***********************************************************************
32218 C input/output channels
32220 COMMON /POINOU/ LI,LO
32222 C standard particle data interface
32225 PARAMETER (NMXHEP=4000)
32227 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32228 DOUBLE PRECISION PHEP,VHEP
32229 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32230 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32232 C extension to standard particle data interface (PHOJET specific)
32233 INTEGER IMPART,IPHIST,ICOLOR
32234 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32236 C particle ID translation table
32237 integer ID_pdg_list,ID_list,ID_pdg_max
32238 character*12 name_list
32239 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32241 C general particle data
32242 double precision xm_list,tau_list,gam_list,
32243 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32244 & xm_bb82_list,xm_bb102_list
32245 integer ich3_list,iba3_list,iq_list,
32246 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32247 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32248 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32249 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32250 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32251 & ich3_list(300),iba3_list(300),iq_list(3,300),
32252 & id_psm_list(6,6),id_vem_list(6,6),
32253 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32255 C external functions
32256 integer ipho_id2pdg,ipho_pdg2id
32259 integer IDpdg,i,ii,k,l,ichar,i_anti
32262 pho_pname = '(?????????????)'
32266 IDpdg = ipho_id2pdg(ID)
32267 if(IDpdg.eq.0) return
32268 else if(mode.eq.1) then
32269 i = ipho_pdg2id(ID)
32272 else if(mode.eq.2) then
32273 if(ISTHEP(ID).gt.11) then
32274 if(ISTHEP(ID).eq.20) then
32275 pho_pname = 'hard ini. part.'
32276 else if(ISTHEP(ID).eq.21) then
32277 pho_pname = 'hard fin. part.'
32278 else if(ISTHEP(ID).eq.25) then
32279 pho_pname = 'hard scattering'
32280 else if(ISTHEP(ID).eq.30) then
32281 pho_pname = 'diff. diss. '
32282 else if(ISTHEP(ID).eq.35) then
32283 pho_pname = 'elastic scatt. '
32284 else if(ISTHEP(ID).eq.40) then
32285 pho_pname = 'central scatt. '
32292 WRITE(LO,'(1x,a,2i4)')
32293 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32298 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32300 name = name_list(ii)
32301 ichar = ich3_list(ii)*sign(1,i)
32302 if(mod(ichar,3).ne.0) then
32308 C find position of first blank character
32312 if(name(k:k).ne.' ') goto 100
32314 C append anti-particle sign
32318 i_anti = i_anti+iq_list(l,ii)
32320 if(iba3_list(ii).ne.0) then
32323 else if(((i_anti.ne.0).and.(ichar.eq.0))
32324 & .or.(IDpdg.eq.-12)
32325 & .or.(IDpdg.eq.-14)
32326 & .or.(IDpdg.eq.-16)) then
32332 C append charge sign
32333 if(ichar.eq.-2) then
32335 else if(ichar.eq.-1) then
32337 else if(ichar.eq.1) then
32339 else if(ichar.eq.2) then
32347 CDECK ID>, ipho_anti
32348 INTEGER FUNCTION ipho_anti(ID)
32349 C**********************************************************************
32351 C determine antiparticle for given ID
32353 C input: ID gives CPC particle number
32355 C output: ipho_anti antiparticle code
32357 C**********************************************************************
32365 C input/output channels
32367 COMMON /POINOU/ LI,LO
32368 C event debugging information
32370 PARAMETER (NMAXD=100)
32371 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32372 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32373 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32374 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32375 C particle ID translation table
32376 integer ID_pdg_list,ID_list,ID_pdg_max
32377 character*12 name_list
32378 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32380 C general particle data
32381 double precision xm_list,tau_list,gam_list,
32382 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32383 & xm_bb82_list,xm_bb102_list
32384 integer ich3_list,iba3_list,iq_list,
32385 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32386 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32387 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32388 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32389 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32390 & ich3_list(300),iba3_list(300),iq_list(3,300),
32391 & id_psm_list(6,6),id_vem_list(6,6),
32392 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32394 C standard particle data interface
32397 PARAMETER (NMXHEP=4000)
32399 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32400 DOUBLE PRECISION PHEP,VHEP
32401 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32402 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32404 C extension to standard particle data interface (PHOJET specific)
32405 INTEGER IMPART,IPHIST,ICOLOR
32406 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32408 C external functions
32409 integer ipho_id2pdg,ipho_pdg2id
32412 integer IDabs,IDpdg,i_anti,l
32418 if(iba3_list(IDabs).ne.0) return
32420 C charged particles
32421 if(ich3_list(IDabs).ne.0) return
32424 IDpdg = ipho_id2pdg(ID)
32425 if(IDpdg.eq.310) then
32426 ID = ipho_pdg2id(130)
32428 else if(IDpdg.eq.130) then
32429 ID = ipho_pdg2id(310)
32433 C neutral mesons with open strangeness, charm, or beauty
32436 i_anti = i_anti+iq_list(l,IDabs)
32438 if(i_anti.ne.0) return
32442 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32448 CDECK ID>, ipho_chr3
32449 INTEGER FUNCTION ipho_chr3(ID,mode)
32450 C**********************************************************************
32452 C output of three times the electric charge
32455 C 0 ID gives CPC particle number
32456 C 1 ID gives PDG particle number
32457 C 2 ID gives position of particle in /POEVT1/
32459 C**********************************************************************
32467 C input/output channels
32469 COMMON /POINOU/ LI,LO
32470 C event debugging information
32472 PARAMETER (NMAXD=100)
32473 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32474 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32475 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32476 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32478 C standard particle data interface
32481 PARAMETER (NMXHEP=4000)
32483 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32484 DOUBLE PRECISION PHEP,VHEP
32485 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32486 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32488 C extension to standard particle data interface (PHOJET specific)
32489 INTEGER IMPART,IPHIST,ICOLOR
32490 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32492 C particle ID translation table
32493 integer ID_pdg_list,ID_list,ID_pdg_max
32494 character*12 name_list
32495 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32497 C general particle data
32498 double precision xm_list,tau_list,gam_list,
32499 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32500 & xm_bb82_list,xm_bb102_list
32501 integer ich3_list,iba3_list,iq_list,
32502 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32503 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32504 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32505 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32506 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32507 & ich3_list(300),iba3_list(300),iq_list(3,300),
32508 & id_psm_list(6,6),id_vem_list(6,6),
32509 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32511 C external functions
32512 integer ipho_pdg2id
32521 else if(mode.eq.1) then
32522 i = ipho_pdg2id(ID)
32525 else if(mode.eq.2) then
32526 if(ISTHEP(ID).gt.11) return
32529 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32530 ipho_chr3 = ICOLOR(1,ID)
32534 WRITE(LO,'(1x,a,2i4)')
32535 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32539 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32540 WRITE(LO,'(1x,a,3i8)')
32541 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32542 ipho_chr3 = 1.D0/dble(i)
32547 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32551 CDECK ID>, ipho_bar3
32552 INTEGER FUNCTION ipho_bar3(ID,mode)
32553 C**********************************************************************
32555 C output of three times the baryon charge
32558 C 0 ID gives CPC particle number
32559 C 1 ID gives PDG particle number
32560 C 2 ID gives position of particle in /POEVT1/
32562 C**********************************************************************
32570 C input/output channels
32572 COMMON /POINOU/ LI,LO
32573 C event debugging information
32575 PARAMETER (NMAXD=100)
32576 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32577 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32578 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32579 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32581 C standard particle data interface
32584 PARAMETER (NMXHEP=4000)
32586 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32587 DOUBLE PRECISION PHEP,VHEP
32588 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32589 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32591 C extension to standard particle data interface (PHOJET specific)
32592 INTEGER IMPART,IPHIST,ICOLOR
32593 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32595 C particle ID translation table
32596 integer ID_pdg_list,ID_list,ID_pdg_max
32597 character*12 name_list
32598 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32600 C general particle data
32601 double precision xm_list,tau_list,gam_list,
32602 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32603 & xm_bb82_list,xm_bb102_list
32604 integer ich3_list,iba3_list,iq_list,
32605 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32606 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32607 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32608 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32609 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32610 & ich3_list(300),iba3_list(300),iq_list(3,300),
32611 & id_psm_list(6,6),id_vem_list(6,6),
32612 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32614 C external functions
32615 integer ipho_pdg2id
32624 else if(mode.eq.1) then
32625 i = ipho_pdg2id(ID)
32628 else if(mode.eq.2) then
32629 if(ISTHEP(ID).gt.11) return
32632 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32633 ipho_bar3 = ICOLOR(2,ID)
32637 WRITE(LO,'(1x,a,2i4)')
32638 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32642 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32643 WRITE(LO,'(1x,a,3i8)')
32644 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32645 ipho_bar3 = 1.D0/dble(i)
32649 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32653 CDECK ID>, pho_pmass
32654 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32655 C***********************************************************************
32659 C input: mode -1 initialization
32660 C 0 ID gives CPC particle number
32661 C 1 ID gives PDG particle number,
32662 C (for quarks current masses are returned)
32663 C 2 ID gives position of particle in /POEVT1/
32664 C 3 ID gives PDG parton number,
32665 C (for quarks constituent masses are returned)
32667 C output: average particle mass (in GeV)
32669 C***********************************************************************
32675 integer ID,mode,MSTJ24
32677 C input/output channels
32679 COMMON /POINOU/ LI,LO
32680 C event debugging information
32682 PARAMETER (NMAXD=100)
32683 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32684 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32685 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32686 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32687 C model switches and parameters
32689 INTEGER ISWMDL,IPAMDL
32690 DOUBLE PRECISION PARMDL
32691 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32693 C standard particle data interface
32696 PARAMETER (NMXHEP=4000)
32698 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32699 DOUBLE PRECISION PHEP,VHEP
32700 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32701 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32703 C extension to standard particle data interface (PHOJET specific)
32704 INTEGER IMPART,IPHIST,ICOLOR
32705 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32707 C particle ID translation table
32708 integer ID_pdg_list,ID_list,ID_pdg_max
32709 character*12 name_list
32710 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32712 C general particle data
32713 double precision xm_list,tau_list,gam_list,
32714 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32715 & xm_bb82_list,xm_bb102_list
32716 integer ich3_list,iba3_list,iq_list,
32717 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32718 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32719 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32720 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32721 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32722 & ich3_list(300),iba3_list(300),iq_list(3,300),
32723 & id_psm_list(6,6),id_vem_list(6,6),
32724 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32727 DOUBLE PRECISION PARU,PARJ
32728 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32730 C external functions
32731 integer ipho_pdg2id,ipho_id2pdg
32733 DOUBLE PRECISION PYMASS
32742 else if(mode.eq.1) then
32743 i = ipho_pdg2id(ID)
32745 else if(mode.eq.2) then
32746 if(ISTHEP(ID).gt.11) return
32749 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32750 pho_pmass = PHEP(5,ID)
32753 else if(mode.eq.3) then
32755 if((i.gt.0).and.(i.le.6)) then
32756 pho_pmass = PARMDL(150+i)
32759 i = ipho_pdg2id(ID)
32762 else if(mode.eq.-1) then
32763 C initialization: take masses for quarks and di-quarks from JETSET
32767 IDpdg = ipho_id2pdg(i)
32769 xm_list(i) = PYMASS(IDpdg)
32775 WRITE(LO,'(1x,a,2i4)')
32776 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32780 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32781 WRITE(LO,'(1x,a,2i8)')
32782 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32783 pho_pmass = 1.D0/dble(i)
32787 pho_pmass = xm_list(iabs(i))
32791 CDECK ID>, PHO_MEMASS
32792 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32793 C**********************************************************************
32795 C determine meson masses corresponding to the input flavours
32797 C input: I,J,K quark flavours (PDG convention)
32799 C output: AMPS pseudo scalar meson mass
32800 C AMPS2 next possible two particle configuration
32801 C (two pseudo scalar mesons)
32802 C AMVE vector meson mass
32803 C AMVE2 next possible two particle configuration
32804 C (two vector mesons)
32805 C IPS,IVE meson numbers in CPC
32807 C**********************************************************************
32813 integer I,J,IPS,IVE
32814 double precision AMPS,AMPS2,AMVE,AMVE2
32816 C input/output channels
32818 COMMON /POINOU/ LI,LO
32819 C event debugging information
32821 PARAMETER (NMAXD=100)
32822 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32823 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32824 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32825 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32826 C particle ID translation table
32827 integer ID_pdg_list,ID_list,ID_pdg_max
32828 character*12 name_list
32829 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32831 C general particle data
32832 double precision xm_list,tau_list,gam_list,
32833 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32834 & xm_bb82_list,xm_bb102_list
32835 integer ich3_list,iba3_list,iq_list,
32836 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32837 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32838 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32839 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32840 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32841 & ich3_list(300),iba3_list(300),iq_list(3,300),
32842 & id_psm_list(6,6),id_vem_list(6,6),
32843 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32857 IPS = id_psm_list(ii,jj)
32858 IVE = id_vem_list(ii,jj)
32861 AMPS = xm_list(iabs(IPS))
32866 AMVE = xm_list(iabs(IVE))
32871 C next possible two-particle configurations (add phase space)
32872 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32873 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32877 CDECK ID>, PHO_BAMASS
32878 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32879 C**********************************************************************
32881 C determine baryon masses corresponding to the input flavours
32883 C input: I,J,K quark flavours (PDG convention)
32885 C output: AM8 octett baryon mass
32886 C AM82 next possible two particle configuration
32887 C (octett baryon and meson)
32888 C AM10 decuplett baryon mass
32889 C AM102 next possible two particle configuration
32890 C (decuplett baryon and meson,
32891 C baryon built up from first two quarks)
32892 C I8,I10 internal baryon numbers
32894 C**********************************************************************
32900 integer I,J,K,I8,I10
32901 double precision AM8,AM82,AM10,AM102
32903 C input/output channels
32905 COMMON /POINOU/ LI,LO
32906 C event debugging information
32908 PARAMETER (NMAXD=100)
32909 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32910 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32911 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32912 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32913 C particle ID translation table
32914 integer ID_pdg_list,ID_list,ID_pdg_max
32915 character*12 name_list
32916 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32918 C general particle data
32919 double precision xm_list,tau_list,gam_list,
32920 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32921 & xm_bb82_list,xm_bb102_list
32922 integer ich3_list,iba3_list,iq_list,
32923 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32924 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32925 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32926 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32927 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32928 & ich3_list(300),iba3_list(300),iq_list(3,300),
32929 & id_psm_list(6,6),id_vem_list(6,6),
32930 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32935 C find particle ID's
32939 I8 = id_b8_list(ii,jj,kk)
32940 I10 = id_b10_list(ii,jj,kk)
32942 C masses (if combination possible)
32950 AM10 = xm_list(I10)
32956 C next possible two-particle configurations (add phase space)
32957 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32958 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32962 CDECK ID>, PHO_DQMASS
32963 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32964 C**********************************************************************
32966 C determine minimal masses corresponding to the input flavours
32967 C (diquark a-diquark string system)
32969 C input: I,J,K,L quark flavours (PDG convention)
32971 C output: AM82 mass of two octett baryons
32972 C AM102 mass of two decuplett baryons
32974 C**********************************************************************
32981 double precision AM82,AM102
32983 C input/output channels
32985 COMMON /POINOU/ LI,LO
32986 C event debugging information
32988 PARAMETER (NMAXD=100)
32989 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32990 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32991 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32992 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32993 C general particle data
32994 double precision xm_list,tau_list,gam_list,
32995 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32996 & xm_bb82_list,xm_bb102_list
32997 integer ich3_list,iba3_list,iq_list,
32998 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32999 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33000 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33001 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33002 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33003 & ich3_list(300),iba3_list(300),iq_list(3,300),
33004 & id_psm_list(6,6),id_vem_list(6,6),
33005 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33008 integer ii,jj,kk,ll
33015 AM82 = xm_bb82_list(ii,jj,kk,ll)
33016 AM102 = xm_bb102_list(ii,jj,kk,ll)
33020 CDECK ID>, PHO_CHECK
33021 SUBROUTINE PHO_CHECK(MD,IDEV)
33022 C**********************************************************************
33024 C check quantum numbers of entries in /POEVT1/ and /POEVT2/
33025 C (energy, momentum, charge, baryon number conservation)
33027 C input: MD -1 check overall momentum conservation
33028 C and perform detailed check only in case of
33030 C 1 test all branchings, mother-daughter
33033 C output: IDEV 0 no deviations
33034 C 1 deviations found
33036 C**********************************************************************
33037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33040 C input/output channels
33042 COMMON /POINOU/ LI,LO
33043 C event debugging information
33045 PARAMETER (NMAXD=100)
33046 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33047 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33048 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33049 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33050 C model switches and parameters
33052 INTEGER ISWMDL,IPAMDL
33053 DOUBLE PRECISION PARMDL
33054 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33055 C global event kinematics and particle IDs
33056 INTEGER IFPAP,IFPAB
33057 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33058 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33059 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33060 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33061 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33062 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33063 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33065 C standard particle data interface
33068 PARAMETER (NMXHEP=4000)
33070 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33071 DOUBLE PRECISION PHEP,VHEP
33072 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33073 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33075 C extension to standard particle data interface (PHOJET specific)
33076 INTEGER IMPART,IPHIST,ICOLOR
33077 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33079 C color string configurations including collapsed strings and hadrons
33081 PARAMETER (MSTR=500)
33082 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33083 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33084 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33085 & NNCH(MSTR),IBHAD(MSTR),ISTR
33087 C count number of errors to avoid disk overflow
33091 C conservation check suppressed
33092 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33094 IF(IPAMDL(13).GT.0) THEN
33096 C DPMJET call with x limitations
33098 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33104 C first two entries are considered as scattering particles
33105 EE1 = PHEP(4,1) + PHEP(4,2)
33106 PX1 = PHEP(1,1) + PHEP(1,2)
33107 PY1 = PHEP(2,1) + PHEP(2,2)
33108 PZ1 = PHEP(3,1) + PHEP(3,2)
33114 IF(MODE.EQ.-1) GOTO 500
33121 C recognize only decayed particles as mothers
33122 IF(ISTHEP(I).EQ.2) THEN
33123 C search for other mother particles
33126 IF(IPAMDL(178).NE.0)
33127 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33128 & 'entry marked as decayed but no dauther given:',I
33133 C sum over mother particles
33134 ICH1 = IPHO_CHR3(K1,2)
33135 IBA1 = IPHO_BAR3(K1,2)
33142 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33143 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33144 & 'inconsistent mother/daughter relation found',I,K1,K2
33145 CALL PHO_PREVNT(-1)
33148 IF(ABS(ISTHEP(II)).LE.2) THEN
33149 ICH1 = ICH1 + IPHO_CHR3(II,2)
33150 IBA1 = IBA1 + IPHO_BAR3(II,2)
33151 EE1 = EE1 + PHEP(4,II)
33152 PX1 = PX1 + PHEP(1,II)
33153 PY1 = PY1 + PHEP(2,II)
33154 PZ1 = PZ1 + PHEP(3,II)
33157 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33158 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33159 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33160 EE1 = EE1 + PHEP(4,K2)
33161 PX1 = PX1 + PHEP(1,K2)
33162 PY1 = PY1 + PHEP(2,K2)
33163 PZ1 = PZ1 + PHEP(3,K2)
33166 C sum over daughter particles
33173 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33174 IF(ABS(ISTHEP(II)).LE.2) THEN
33175 ICH2 = ICH2 + IPHO_CHR3(II,2)
33176 IBA2 = IBA2 + IPHO_BAR3(II,2)
33177 EE2 = EE2 + PHEP(4,II)
33178 PX2 = PX2 + PHEP(1,II)
33179 PY2 = PY2 + PHEP(2,II)
33180 PZ2 = PZ2 + PHEP(3,II)
33184 C conservation check
33185 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33186 IF(ABS(EE1-EE2).GT.ESC) THEN
33187 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33188 & 'PHO_CHECK: energy conservation violated for',
33189 & 'entry,initial,final:',I,EE1,EE2
33192 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33193 IF(ABS(PX1-PX2).GT.ESC) THEN
33194 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33195 & 'PHO_CHECK: x-momentum conservation violated for',
33196 & 'entry,initial,final:',I,PX1,PX2
33199 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33200 IF(ABS(PY1-PY2).GT.ESC) THEN
33201 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33202 & 'PHO_CHECK: y-momentum conservation violated for',
33203 & 'entry,initial,final:',I,PY1,PY2
33206 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33207 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33208 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33209 & 'PHO_CHECK: z-momentum conservation violated for',
33210 & 'entry,initial,final:',I,PZ1,PZ2
33213 IF(ICH1.NE.ICH2) THEN
33214 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33215 & 'PHO_CHECK: charge conservation violated for',
33216 & 'entry,initial,final:',I,ICH1,ICH2
33219 IF(IBA1.NE.IBA2) THEN
33220 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33221 & 'baryon charge conservation violated for',
33222 & 'entry,initial,final:',I,IBA1,IBA2
33225 IF(IDEB(20).GE.35) THEN
33227 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33228 & 'PHO_CHECK diagnostics:',
33229 & '(1.mother/l.mother,1.daughter/l.daughter):',
33230 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33231 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33232 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33233 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33238 IF(I.LE.NHEP) GOTO 100
33244 C write complete event in case of deviations
33245 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33250 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33255 C stop after too many errors
33256 IF(IERR.GT.IPAMDL(179)) THEN
33257 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33258 & 'too many inconsistencies found, program terminated',IERR
33264 C overall check only (less time consuming)
33276 C recognize only existing particles as possible daughters
33277 IF(ABS(ISTHEP(K)).EQ.1) THEN
33278 ICH2 = ICH2 + IPHO_CHR3(K,2)
33279 IBA2 = IBA2 + IPHO_BAR3(K,2)
33280 EE2 = EE2 + PHEP(4,K)
33281 PX2 = PX2 + PHEP(1,K)
33282 PY2 = PY2 + PHEP(2,K)
33283 PZ2 = PZ2 + PHEP(3,K)
33287 C check energy-momentum conservation
33290 IF(IPAMDL(13).GT.0) THEN
33292 C DPMJET call with x limitations
33293 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33294 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33295 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33296 & 'PHO_CHECK: c.m. energy conservation violated',
33297 & 'initial/final energy:',ECM1,ECM2
33304 IF(ABS(EE1-EE2).GT.ESC) THEN
33305 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33306 & 'PHO_CHECK: energy conservation violated',
33307 & 'initial/final energy:',EE1,EE2
33310 IF(ABS(PX1-PX2).GT.ESC) THEN
33311 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33312 & 'PHO_CHECK: x-momentum conservation violated',
33313 & 'initial/final x-momentum:',PX1,PX2
33316 IF(ABS(PY1-PY2).GT.ESC) THEN
33317 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33318 & 'PHO_CHECK: y-momentum conservation violated',
33319 & 'initial/final y-momentum:',PY1,PY2
33322 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33323 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33324 & 'PHO_CHECK: z-momentum conservation violated',
33325 & 'initial/final z-momentum:',PZ1,PZ2
33329 C check of quantum number conservation
33331 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33332 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33334 IF(ICH1.NE.ICH2) THEN
33335 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33336 & 'PHO_CHECK: charge conservation violated',
33337 & 'initial/final charge sum',ICH1,ICH2
33340 IF(IBA1.NE.IBA2) THEN
33341 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33342 & 'baryonic charge conservation violated',
33343 & 'initial/final baryonic charge sum',IBA1,IBA2
33349 C perform detailed checks in case of deviations
33350 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33351 IF(IPAMDL(13).GT.0) THEN
33356 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33357 & 'increasing precision of tests to',DDREL,DDABS
33364 CDECK ID>, PHO_ABORT
33365 SUBROUTINE PHO_ABORT
33366 C**********************************************************************
33368 C top MC event generation due to fatal error,
33369 C print all information of event generation and history
33371 C**********************************************************************
33372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33375 C input/output channels
33377 COMMON /POINOU/ LI,LO
33378 C event debugging information
33380 PARAMETER (NMAXD=100)
33381 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33382 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33383 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33384 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33385 C model switches and parameters
33387 INTEGER ISWMDL,IPAMDL
33388 DOUBLE PRECISION PARMDL
33389 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33391 C standard particle data interface
33394 PARAMETER (NMXHEP=4000)
33396 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33397 DOUBLE PRECISION PHEP,VHEP
33398 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33399 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33401 C extension to standard particle data interface (PHOJET specific)
33402 INTEGER IMPART,IPHIST,ICOLOR
33403 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33405 C color string configurations including collapsed strings and hadrons
33407 PARAMETER (MSTR=500)
33408 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33409 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33410 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33411 & NNCH(MSTR),IBHAD(MSTR),ISTR
33412 C light-cone x fractions and c.m. momenta of soft cut string ends
33414 PARAMETER ( MAXSOF = 50 )
33415 INTEGER IJSI2,IJSI1
33416 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33417 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33418 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33419 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33420 C hard scattering data
33422 PARAMETER ( MSCAHD = 50 )
33423 INTEGER LSCAHD,LSC1HD,LSIDX,
33424 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33425 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33426 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33427 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33428 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33429 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33430 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33431 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33432 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33434 WRITE(LO,'(//,1X,A,/,1X,A)')
33435 & 'PHO_ABORT: program execution stopped',
33436 & '===================================='
33437 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33439 CALL PHO_SETMDL(0,0,-2)
33440 CALL PHO_PREVNT(-1)
33441 CALL PHO_ACTPDF(0,-2)
33442 C print selected parton flavours
33443 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33445 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33447 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33450 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33451 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33452 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33454 C print selected parton momenta
33455 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33457 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33458 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33460 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33464 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33465 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33471 C fragmentation process
33476 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33481 WRITE(LO,'(////5X,A,///5X,A,///)')
33482 & 'PHO_ABORT: execution terminated due to fatal error',
33483 &'*** Simulating division by zero to get traceback information ***'
33484 ISTR = 100/IPAMDL(100)
33488 CDECK ID>, PHO_TRACE
33489 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33490 C**********************************************************************
33492 C trace program subroutines according to level,
33493 C original output levels will be saved
33495 C input: ISTART first event to trace
33496 C ISWI number of events to trace
33497 C 0 loop call, use old values
33498 C -1 restore original output levels
33499 C 1 store level and wait for event
33500 C LEVEL desired output level
33501 C 0 standard output
33502 C 3 internal rejections
33503 C 5 cross sections, slopes etc.
33504 C 10 parameter of subroutines and
33506 C 20 huge amount of debug output
33507 C 30 maximal possible output
33509 C**********************************************************************
33510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33513 C input/output channels
33515 COMMON /POINOU/ LI,LO
33516 C event debugging information
33518 PARAMETER (NMAXD=100)
33519 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33520 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33521 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33522 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33524 DIMENSION IMEM(NMAXD)
33530 IF(KEVENT.LT.ION) THEN
33532 ELSE IF(KEVENT.EQ.ION) THEN
33533 WRITE(LO,'(///,1X,A,///)')
33534 & 'PHO_TRACE: trace mode switched on'
33537 IDEB(I) = MAX(ILEVEL,IMEM(I))
33539 ELSE IF(KEVENT.EQ.IOFF) THEN
33540 WRITE(LO,'(//,1X,A,///)')
33541 & 'PHO_TRACE: trace mode switched off'
33546 ELSE IF(ISW.EQ.-1) THEN
33556 C check coincidence
33565 CDECK ID>, PHO_PRSTRG
33566 SUBROUTINE PHO_PRSTRG
33567 C**********************************************************************
33569 C print information of /POSTRG/
33571 C**********************************************************************
33572 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33575 C input/output channels
33577 COMMON /POINOU/ LI,LO
33578 C event debugging information
33580 PARAMETER (NMAXD=100)
33581 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33582 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33583 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33584 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33586 C standard particle data interface
33589 PARAMETER (NMXHEP=4000)
33591 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33592 DOUBLE PRECISION PHEP,VHEP
33593 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33594 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33596 C extension to standard particle data interface (PHOJET specific)
33597 INTEGER IMPART,IPHIST,ICOLOR
33598 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33600 C color string configurations including collapsed strings and hadrons
33602 PARAMETER (MSTR=500)
33603 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33604 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33605 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33606 & NNCH(MSTR),IBHAD(MSTR),ISTR
33608 WRITE(LO,'(/,1X,A,I5)')
33609 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33610 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33611 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33613 & ' ======================================================='
33615 WRITE(LO,'(1X,9I5,1P,E11.3)')
33616 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33617 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33622 CDECK ID>, PHO_PREVNT
33623 SUBROUTINE PHO_PREVNT(NPART)
33624 C**********************************************************************
33626 C print all information of event generation and history
33628 C input: NPART -1 minimal output: process IDs
33629 C 0 additional output of /POEVT1/
33630 C 1 additional output of /POSTRG/
33631 C 2 additional output of /HEPEVT/
33634 C**********************************************************************
33635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33638 C input/output channels
33640 COMMON /POINOU/ LI,LO
33641 C event debugging information
33643 PARAMETER (NMAXD=100)
33644 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33645 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33646 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33647 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33648 C model switches and parameters
33650 INTEGER ISWMDL,IPAMDL
33651 DOUBLE PRECISION PARMDL
33652 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33653 C global event kinematics and particle IDs
33654 INTEGER IFPAP,IFPAB
33655 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33656 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33657 C general process information
33658 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33659 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33661 C standard particle data interface
33664 PARAMETER (NMXHEP=4000)
33666 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33667 DOUBLE PRECISION PHEP,VHEP
33668 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33669 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33671 C extension to standard particle data interface (PHOJET specific)
33672 INTEGER IMPART,IPHIST,ICOLOR
33673 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33675 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33676 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33677 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33678 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33679 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33681 CHARACTER*15 PHO_PNAME
33683 IF(NPART.GE.0) WRITE(LO,'(/)')
33684 WRITE(LO,'(1X,A,1PE10.3)')
33685 & 'PHO_PREVNT: c.m. energy',ECM
33686 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33687 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33688 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33689 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33690 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33692 WRITE(LO,'(6X,A,I4,4I3)')
33693 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33696 IF(IPAMDL(13).GT.0) THEN
33697 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33698 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33699 & ECMN,PCMN,SECM,SPCM
33700 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33703 IF(NPART.LT.0) RETURN
33705 IF(NPART.GE.1) CALL PHO_PRSTRG
33707 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33712 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33713 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33714 & ' IH1 IH2 CO1 CO2',
33715 & '========================================================',
33716 & '===================='
33718 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33719 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33720 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33721 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33722 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33723 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33724 & ICOLOR(1,IH),ICOLOR(2,IH)
33725 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33726 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33727 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33729 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33730 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33734 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33735 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33743 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33744 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33745 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33746 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33748 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33749 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33751 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33752 PXS = PXS + PHEP(1,IN)
33753 PYS = PYS + PHEP(2,IN)
33754 PZS = PZS + PHEP(3,IN)
33755 P0S = P0S + PHEP(4,IN)
33758 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33759 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33760 IF(P0S.LT.99999.D0) THEN
33761 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33763 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33767 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33768 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33769 & 8H CHARGE ,8H BARYON ,/)
33770 6 FORMAT(7I8,2F8.3)
33771 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33772 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33773 & 2X,'-------------------------------',
33774 & '--------------------------------------------')
33775 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33776 9 FORMAT(I10,14X,5F10.3)
33777 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33778 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33779 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33781 IF(NPART.GE.2) CALL PYLIST(1)
33785 CDECK ID>, PHO_LTRHEP
33786 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33787 C*******************************************************************
33789 C Lorentz transformation of entries I1 to I2 in /POEVT1/
33791 C********************************************************************
33792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33795 PARAMETER ( DIFF = 0.001D0,
33798 C input/output channels
33800 COMMON /POINOU/ LI,LO
33801 C event debugging information
33803 PARAMETER (NMAXD=100)
33804 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33805 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33806 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33807 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33809 C standard particle data interface
33812 PARAMETER (NMXHEP=4000)
33814 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33815 DOUBLE PRECISION PHEP,VHEP
33816 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33817 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33819 C extension to standard particle data interface (PHOJET specific)
33820 INTEGER IMPART,IPHIST,ICOLOR
33821 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33823 DO 100 I=I1,MIN(I2,NHEP)
33824 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33825 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33828 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33829 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33830 ELSE IF(ISTHEP(I).EQ.20) THEN
33831 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33832 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33834 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33835 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33840 IF(IDEB(70).LT.1) RETURN
33841 DO 200 I=I1,MIN(NHEP,I2)
33842 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33843 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33844 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33845 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33846 WRITE(LO,'(1X,A,I5,2E13.4)')
33847 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33854 CDECK ID>, PHO_PECMS
33855 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33856 C*******************************************************************
33858 C calculation of cms momentum and energy of massive particle
33859 C (ID= 1 using PMASS1, 2 using PMASS2)
33861 C output: PP cms momentum
33862 C EE energy in CMS of particle ID
33864 C********************************************************************
33865 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33868 C input/output channels
33870 COMMON /POINOU/ LI,LO
33871 C event debugging information
33873 PARAMETER (NMAXD=100)
33874 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33875 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33876 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33877 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33879 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33880 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33881 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33884 PM1 = SIGN(PMASS1**2,PMASS1)
33885 PM2 = SIGN(PMASS2**2,PMASS2)
33886 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33887 & + PM1**2 + PM2**2)/(2.D0*ECM)
33890 EE = SQRT( PM1 + PP**2 )
33891 ELSE IF(ID.EQ.2) THEN
33892 EE = SQRT( PM2 + PP**2 )
33894 WRITE(LO,'(/1X,A,I3,/)')
33895 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33901 CDECK ID>, PHO_FRAINI
33902 SUBROUTINE PHO_FRAINI(IDEFAU)
33903 C***********************************************************************
33905 C initialization of fragmentation packages
33906 C (currently LUND JETSET)
33908 C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33909 C changed to work in PHOJET (R.E. 1/94)
33911 C input: IDEFAU 0 no hadronization at all
33912 C 1 do not touch any parameter of JETSET
33913 C 2 default parameters kept, decay length 10mm to
33914 C define stable particles
33915 C 3 load tuned parameters for JETSET 7.3
33916 C neg. value: prevent strange/charm hadrons from decaying
33918 C***********************************************************************
33919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33922 PARAMETER (EPS=1.D-10)
33924 C input/output channels
33926 COMMON /POINOU/ LI,LO
33929 DOUBLE PRECISION P,V
33930 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33933 DOUBLE PRECISION PARU,PARJ
33934 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33937 DOUBLE PRECISION PMAS,PARF,VCKM
33938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33940 INTEGER MDCY,MDME,KFDP
33941 DOUBLE PRECISION BRAT
33942 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
33946 IDEFAB = ABS(IDEFAU)
33948 IF(IDEFAB.EQ.0) THEN
33949 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33960 C declare stable particles
33961 IF(IDEFAB.GE.2) MSTJ(22) = 2
33963 C load optimized parameters
33964 IF(IDEFAB.GE.3) THEN
33973 C Lund sigma parameter in pt distribution
33978 C prevent particles decaying
33979 IF(IDEFAU.LT.0) THEN
34157 C *** Commented by Chiara
34158 C WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34159 C & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34160 C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34161 C & ' --------------------------------------------------',/,
34162 C & 5X,'parameter description default / current',/,
34163 C & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34164 C & 5X,'MSTJ(12) popcorn : ',2I7,/,
34165 C & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34166 C & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34167 C & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34168 C & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34172 CDECK ID>, PHO_SETPAR
34173 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34174 C**********************************************************************
34176 C assign a particle to either side 1 or 2
34177 C (including special treatment for remnants)
34179 C input: Iside 1,2 side selected for the particle
34180 C -2 output of current settings
34183 C 0 CPC determination in subroutine
34184 C -1 special particle remnant, IDPDG
34185 C is the particle number the remnant
34186 C corresponds to (see /POHDFL/)
34188 C**********************************************************************
34194 integer Iside,IDpdg,IDcpc
34195 double precision Pvir
34197 C input/output channels
34199 COMMON /POINOU/ LI,LO
34200 C event debugging information
34202 PARAMETER (NMAXD=100)
34203 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34204 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34205 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34206 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34207 C global event kinematics and particle IDs
34208 INTEGER IFPAP,IFPAB
34209 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34210 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34211 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34212 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34213 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34214 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34215 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34216 C particle ID translation table
34217 integer ID_pdg_list,ID_list,ID_pdg_max
34218 character*12 name_list
34219 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34221 C general particle data
34222 double precision xm_list,tau_list,gam_list,
34223 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34224 & xm_bb82_list,xm_bb102_list
34225 integer ich3_list,iba3_list,iq_list,
34226 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34227 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34228 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34229 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34230 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34231 & ich3_list(300),iba3_list(300),iq_list(3,300),
34232 & id_psm_list(6,6),id_vem_list(6,6),
34233 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34234 C particle decay data
34235 double precision wg_sec_list
34236 integer idec_list,isec_list
34237 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34240 C external functions
34241 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34242 double precision pho_pmass
34245 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34247 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34250 IF(IDcpc.EQ.-1) THEN
34251 IF(Iside.EQ.1) THEN
34256 IDcpcR = ipho_pdg2id(IDpdgR)
34257 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34258 IDEQP(Iside) = IDpdg
34259 C copy particle properties
34260 IDB = abs(IDEQB(Iside))
34261 xm_list(IDcpcR) = xm_list(IDB)
34262 tau_list(IDcpcR) = tau_list(IDB)
34263 gam_list(IDcpcR) = gam_list(IDB)
34264 IF(IHFLS(Iside).EQ.1) THEN
34265 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34266 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34268 ich3_list(IDcpcR) = 0
34269 iba3_list(IDcpcR) = 0
34272 IFL1 = IHFLD(Iside,1)
34273 IFL2 = IHFLD(Iside,2)
34275 IF(IHFLS(Iside).EQ.1) THEN
34276 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34277 IFL1 = IHFLD(Iside,1)/1000
34278 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34279 IFL3 = IHFLD(Iside,2)
34280 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34281 IFL1 = IHFLD(Iside,1)
34282 IFL2 = IHFLD(Iside,2)/1000
34283 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34286 iq_list(1,IDcpcR) = IFL1
34287 iq_list(2,IDcpcR) = IFL2
34288 iq_list(3,IDcpcR) = IFL3
34293 IF(IDEB(87).GE.5) THEN
34294 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34295 & 'pho_setpar: remnant assignment side',Iside,
34296 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34298 ELSE IF(IDcpc.EQ.0) THEN
34303 IDcpcN = ipho_pdg2id(IDpdg)
34307 C initialize /POGCMS/
34308 IFPAP(Iside) = IDpdgN
34309 IFPAB(Iside) = IDcpcN
34310 PMASS(Iside) = pho_pmass(IDcpcN,0)
34311 IF(IFPAP(Iside).EQ.22) THEN
34312 PVIRT(Iside) = ABS(PVIR)
34314 PVIRT(Iside) = 0.D0
34317 ELSE IF(Iside.EQ.-2) THEN
34318 C output of current settings
34320 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34321 & 'PHO_SETPAR: side',
34322 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34324 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34325 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34326 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34327 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34331 WRITE(LO,'(/1X,A,I8)')
34332 & 'pho_setpar: invalid argument (Iside)',Iside
34337 CDECK ID>, PHO_XLAM
34338 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34339 C**********************************************************************
34341 C auxiliary function for two/three particle decay mode
34342 C (standard LAMBDA**(1/2) function)
34344 C**********************************************************************
34345 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34349 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34350 IF(XLAM.LT.0.D0) XLAM=-XLAM
34351 PHO_XLAM=SQRT(XLAM)
34354 CDECK ID>, PHO_BESSJ0
34355 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34356 C**********************************************************************
34358 C CERN (KERN) LIB function C312
34360 C modified by R. Engel (03/02/93)
34362 C**********************************************************************
34363 DOUBLE PRECISION DX
34364 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34365 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34369 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34371 DATA C1( 0) /+0.15772 79714 7489D0/
34372 DATA C1( 1) /-0.00872 34423 5285D0/
34373 DATA C1( 2) /+0.26517 86132 0334D0/
34374 DATA C1( 3) /-0.37009 49938 7265D0/
34375 DATA C1( 4) /+0.15806 71023 3210D0/
34376 DATA C1( 5) /-0.03489 37694 1141D0/
34377 DATA C1( 6) /+0.00481 91800 6947D0/
34378 DATA C1( 7) /-0.00046 06261 6621D0/
34379 DATA C1( 8) /+0.00003 24603 2882D0/
34380 DATA C1( 9) /-0.00000 17619 4691D0/
34381 DATA C1(10) /+0.00000 00760 8164D0/
34382 DATA C1(11) /-0.00000 00026 7925D0/
34383 DATA C1(12) /+0.00000 00000 7849D0/
34384 DATA C1(13) /-0.00000 00000 0194D0/
34385 DATA C1(14) /+0.00000 00000 0004D0/
34387 DATA C2( 0) /+0.99946 03493 4752D0/
34388 DATA C2( 1) /-0.00053 65220 4681D0/
34389 DATA C2( 2) /+0.00000 30751 8479D0/
34390 DATA C2( 3) /-0.00000 00517 0595D0/
34391 DATA C2( 4) /+0.00000 00016 3065D0/
34392 DATA C2( 5) /-0.00000 00000 7864D0/
34393 DATA C2( 6) /+0.00000 00000 0517D0/
34394 DATA C2( 7) /-0.00000 00000 0043D0/
34395 DATA C2( 8) /+0.00000 00000 0004D0/
34396 DATA C2( 9) /-0.00000 00000 0001D0/
34398 DATA C3( 0) /-0.01555 58546 05337D0/
34399 DATA C3( 1) /+0.00006 83851 99426D0/
34400 DATA C3( 2) /-0.00000 07414 49841D0/
34401 DATA C3( 3) /+0.00000 00179 72457D0/
34402 DATA C3( 4) /-0.00000 00007 27192D0/
34403 DATA C3( 5) /+0.00000 00000 42201D0/
34404 DATA C3( 6) /-0.00000 00000 03207D0/
34405 DATA C3( 7) /+0.00000 00000 00301D0/
34406 DATA C3( 8) /-0.00000 00000 00033D0/
34407 DATA C3( 9) /+0.00000 00000 00004D0/
34408 DATA C3(10) /-0.00000 00000 00001D0/
34412 IF(V .LT. EIGHT) THEN
34419 B0=C1(I)-ALFA*B1-B2
34431 B0=C2(I)-ALFA*B1-B2
34438 B0=C3(I)-ALFA*B1-B2
34443 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34449 CDECK ID>, PHO_BESSI0
34450 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34451 C**********************************************************************
34453 C Bessel Function I0
34455 C**********************************************************************
34456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34460 IF (AX .LT. 3.75D0) THEN
34463 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34464 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34468 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34469 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34470 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34471 & +Y*0.392377D-2))))))))
34476 CDECK ID>, PHO_BESSI1
34477 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34478 C**********************************************************************
34480 C Bessel Function I1
34482 C**********************************************************************
34483 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34488 IF (AX .LT. 3.75D0) THEN
34491 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34492 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34496 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34499 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34500 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34501 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34503 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34505 PHO_BESSI1 = BESLI1
34509 CDECK ID>, PHO_BESSK0
34510 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34511 C**********************************************************************
34513 C Modified Bessel Function K0
34515 C**********************************************************************
34516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34519 IF (X .LT. 2.D0) THEN
34522 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34523 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34524 & +Y*(0.10750D-3+Y*0.740D-5))))))
34528 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34529 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34530 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34535 CDECK ID>, PHO_BESSK1
34536 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34537 C**********************************************************************
34539 C Modified Bessel Function K1
34541 C**********************************************************************
34542 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34545 IF (X .LT. 2.D0) THEN
34548 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34549 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34550 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34554 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34555 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34556 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34561 CDECK ID>, PHO_GAUSET
34562 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34563 C********************************************************************
34565 C N-point gauss zeros and weights for the interval (AX,BX) are
34566 C stored in arrays Z and W respectively.
34568 C*********************************************************************
34569 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34572 COMMON /POGDAT/A(273),X(273),KTAB(96)
34573 DIMENSION Z(NX),W(NX)
34586 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34587 IF(N.EQ.20) GO TO 2
34588 IF(N.EQ.24) GO TO 2
34589 IF(N.EQ.32) GO TO 2
34590 IF(N.EQ.40) GO TO 2
34591 IF(N.EQ.48) GO TO 2
34592 IF(N.EQ.64) GO TO 2
34593 IF(N.EQ.80) GO TO 2
34594 IF(N.EQ.96) GO TO 2
34596 C the extended Gauss cases:
34597 IF((N/96)*96.EQ.N) GO TO 3
34599 C jump to center of intervall intrgration:
34602 C get Gauss point array
34605 C extract real points
34609 C extract values from big array
34613 C store them backward
34616 C store them forward
34621 C store central point (odd N)
34622 IF((N-M-M).EQ.0) RETURN
34625 W(M+1)=BETA*A(JMID)
34628 C get ND96 times chained 96 Gauss point array
34631 C print out message
34632 C -extract real points
34636 C extract values from big array
34642 DO 32 JD96=0,ND96-1
34643 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34644 C store them backward
34645 Z(J+JD96*96)=ZCNTR-DELTA
34647 C store them forward
34649 Z(JP+JD96*96)=ZCNTR+DELTA
34650 W(JP+JD96*96)=WTEMP
34655 C the center of intervall cases:
34657 C put in constant weight and equally spaced central points
34660 WIN=(BX-AX)/FLOAT(N)
34661 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34666 CDECK ID>, PHO_GAUDAT
34667 SUBROUTINE PHO_GAUDAT
34668 C*********************************************************************
34670 C store big arrays needed for Gauss integral, CERNLIB D106BD
34671 C (arrays A,X,ITAB copied on B,Y,LTAB)
34673 C*********************************************************************
34674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34677 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34678 DIMENSION A(273),X(273),KTAB(96)
34680 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34717 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34720 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34722 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34723 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34725 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34726 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34728 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34729 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34730 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34732 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34733 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34734 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34736 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34737 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34738 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34739 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34741 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34742 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34743 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34744 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34746 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34747 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34748 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34749 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34750 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34752 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34753 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34754 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34755 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34756 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34758 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34759 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34760 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34761 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34762 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34763 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34765 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34766 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34767 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34768 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34769 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34770 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34772 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34773 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34774 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34775 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34776 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34777 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34778 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34780 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34781 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34782 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34783 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34784 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34785 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34786 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34788 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34789 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34790 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34791 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34792 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34793 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34794 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34795 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34797 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34798 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34799 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34800 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34801 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34802 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34803 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34804 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34806 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34807 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34808 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34809 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34810 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34811 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34812 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34813 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34814 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34815 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34817 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34818 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34819 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34820 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34821 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34822 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34823 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34824 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34825 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34826 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34827 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34828 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34830 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34831 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34832 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34833 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34834 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34835 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34836 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34837 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34838 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34839 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34840 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34841 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34842 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34843 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34844 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34845 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34847 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34848 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34849 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34850 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34851 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34852 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34853 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34854 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34855 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34856 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34857 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34858 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34859 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34860 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34861 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34862 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34863 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34864 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34865 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34866 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34868 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34869 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34870 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34871 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34872 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34873 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34874 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34875 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34876 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34877 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34878 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34879 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34880 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34881 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34882 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34883 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34884 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34885 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34886 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34887 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34888 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34889 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34890 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34891 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34893 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34894 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34895 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34896 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34897 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34898 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34899 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34900 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34901 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34902 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34903 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34904 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34905 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34906 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34907 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34908 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34909 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34910 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34911 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34912 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34913 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34914 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34915 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34916 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34917 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34918 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34919 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34920 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34921 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34922 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34923 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34924 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34926 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34927 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34928 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34929 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34930 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34931 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34932 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34933 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34934 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34935 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34936 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34937 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34938 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34939 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34940 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34941 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34942 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34943 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34944 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34945 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34946 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34947 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34948 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34949 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34950 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34951 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34952 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34953 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34954 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34955 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34956 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34957 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34958 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34959 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34960 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34961 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34962 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34963 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34964 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34965 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34967 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34968 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34969 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34970 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34971 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34972 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34973 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34974 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34975 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34976 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34977 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34978 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34979 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34980 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34981 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34982 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34983 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34984 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34985 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34986 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34987 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34988 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34989 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34990 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34991 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34992 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34993 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34994 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34995 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34996 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34997 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34998 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34999 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
35000 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35001 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35002 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35003 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35004 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35005 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35006 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35007 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35008 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35009 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35010 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35011 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35012 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35013 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35014 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35016 IF(IBD.NE.0) RETURN
35027 CDECK ID>, PHO_DZEROX
35028 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35029 C**********************************************************************
35033 C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35034 C Guaranteed Convergence for Finding a Zero of a Function,
35035 C ACM Trans. Math. Software 1 (1975) 330-345.
35037 C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
35041 C***********************************************************************
35042 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35045 C input/output channels
35047 COMMON /POINOU/ LI,LO
35050 PARAMETER (NAME = 'PHO_DZEROX')
35052 DIMENSION IM1(2),IM2(2),LMT(2)
35055 PARAMETER (Z1 = 1, HALF = Z1/2)
35057 DATA IM1 /2,3/, IM2 /-1,3/
35059 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35061 WRITE(LO,100) NAME,MODE
35066 IF(FA*FB .GT. 0) THEN
35079 3 IF(ABS(FC) .LT. ABS(FB)) THEN
35094 IF(ABS(HB) .GT. TOL) THEN
35095 IF(IE .GT. IM1(MODE)) THEN
35098 TOL=TOL*SIGN(Z1,HB)
35114 IF(IE .EQ. IM2(MODE)) P=P+P
35115 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35117 ELSEIF(P .LT. HB*Q) THEN
35129 IF(MF .GT. MAXF) THEN
35134 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35135 IF(W .EQ. HB) GO TO 2
35142 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35143 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35144 102 FORMAT(1X,A,': too many function calls')
35148 CDECK ID>, PHO_EXPINT
35149 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35150 C***********************************************************************
35152 C function to calculate E_i(x) = -E_1(-x)
35154 C based on CERNLIB C337 (changed by R.Engel 10/1993)
35156 C***********************************************************************
35157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35160 C input/output channels
35162 COMMON /POINOU/ LI,LO
35164 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35165 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35166 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35168 DATA X0 /0.37250 74107 8137D0/
35169 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35171 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35172 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35173 3 -4.34981 43832 952D+2/
35175 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35176 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35177 3 +7.53585 64359 843D+2/
35179 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35180 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35181 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35182 4 +4.65627 10797 510D-7/
35184 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35185 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35186 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35187 4 +1.00000 00000 000D+0/
35189 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35190 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35191 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35193 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35194 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35195 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35197 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35198 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35199 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35200 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35202 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35203 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35204 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35205 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35207 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35208 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35209 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35210 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35212 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35213 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35214 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35215 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35217 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35218 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35219 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35220 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35222 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35223 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35224 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35225 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35227 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35228 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35229 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35231 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35232 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35233 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35235 C conversion to E_i function
35238 IF(X .LE. XL(1)) THEN
35241 1 AP=A3(I)-X+B3(I)/AP
35242 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35243 ELSEIF(X .LE. XL(2)) THEN
35246 2 AP=A2(I)-X+B2(I)/AP
35247 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35248 ELSEIF(X .LE. XL(3)) THEN
35251 3 AP=A1(I)-X+B1(I)/AP
35252 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35253 ELSEIF(X .LT. XL(4)) THEN
35254 V=-2.D0*(X/3.D0+1.D0)
35266 14 DQ=Q4(I)-AQ+V*BQ
35267 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35268 ELSEIF(X .EQ. XL(4)) THEN
35269 * CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35271 * IF(LGFILE .EQ. 0) THEN
35272 * WRITE(LO,100) ENAME
35274 * WRITE(LGFILE,100) ENAME
35277 * IF(.NOT.RFLAG) CALL ABEND
35280 ELSEIF(X .LT. XL(5)) THEN
35287 ELSEIF(X .LE. XL(6)) THEN
35302 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35304 C sign conversion to E_i
35309 CDECK ID>, PHO_RNDBET
35310 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35311 C********************************************************************
35313 C RANDOM NUMBER GENERATION FROM BETA
35314 C DISTRIBUTION IN REGION 0 < X < 1.
35315 C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35318 C********************************************************************
35319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35322 Y = PHO_RNDGAM(1.D0,GAM)
35323 Z = PHO_RNDGAM(1.D0,ETA)
35325 PHO_RNDBET = Y/(Y+Z)
35329 CDECK ID>, PHO_RNDGAM
35330 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35331 C********************************************************************
35333 C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35334 C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35336 C********************************************************************
35337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35343 IF(F.EQ.0.D0) GOTO 20
35344 10 R = DT_RNDM(ETA)
35346 IF (NCOU.GE.11) GOTO 20
35347 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35348 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35349 IF(ABS(YYY).GT.50.D0) GOTO 20
35351 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35355 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35356 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35357 40 IF(N.EQ.0) GOTO 70
35360 60 Z = Z*DT_RNDM(Y)
35361 Y = Y-LOG(Z+1.0D-9)
35362 70 PHO_RNDGAM = Y/ALAM
35366 CDECK ID>, PHO_SFECFE
35367 SUBROUTINE PHO_SFECFE(SFE,CFE)
35368 C**********************************************************************
35370 C fast random SIN(X) COS(X) selection
35372 C**********************************************************************
35373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35382 IF(XY.GT.1.D0) GOTO 1
35385 IF(DT_RNDM(XY).LT.0.5D0) THEN
35390 CDECK ID>, PHO_SWAPD
35391 SUBROUTINE PHO_SWAPD(D1,D2)
35392 C********************************************************************
35394 C exchange of argument values (double precision)
35396 C********************************************************************
35397 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35403 CDECK ID>, PHO_SWAPI
35404 SUBROUTINE PHO_SWAPI(I1,I2)
35405 C********************************************************************
35407 C exchange of argument values (integer)
35409 C********************************************************************
35410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35416 CDECK ID>, PHO_HADCSL
35417 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35418 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35419 C***********************************************************************
35421 C low-energy cross section parametrizations
35423 C input: ID1,ID2 PDG IDs of particles (meson first)
35424 C ECM c.m. energy (GeV)
35425 C PLAB lab. momentum (second particle at rest)
35426 C IMODE 1 ECM given, PLAB ignored
35427 C 2 PLAB given, ECM ignored
35429 C output: SIGTOT total cross section (mb)
35430 C SIGEL elastic cross section (mb)
35431 C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35432 C SLOPE forward elastic slope (GeV**-2)
35433 C RHO real/imaginary part of elastic amplitude
35437 C - low-energy data interpolation uses PDG fits from 1992 issue
35438 C - high-energy extrapolation by Donnachie-Landshoff like fit made
35440 C - analytic extension of amplitude to calculate rho
35442 C***********************************************************************
35448 INTEGER ID1,ID2,IMODE
35449 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35451 C input/output channels
35453 COMMON /POINOU/ LI,LO
35455 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35456 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35457 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35458 C model switches and parameters
35460 INTEGER ISWMDL,IPAMDL
35461 DOUBLE PRECISION PARMDL
35462 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35465 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35466 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35468 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35471 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35472 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35473 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35474 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35475 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35476 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35477 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35478 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35479 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35480 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35481 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35482 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35485 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35486 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35487 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35488 & 77.15D0,21.05D0,0.46D0,0.9D0,
35489 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35490 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35491 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35492 & 31.85D0,4.05D0,0.45D0,0.9D0,
35493 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35494 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35495 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35496 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35499 & 11.13D0, -6.21D0, 0.30D0,
35500 & 11.13D0, 7.23D0, 0.30D0,
35501 & 9.11D0, -0.73D0, 0.28D0,
35502 & 9.11D0, 0.65D0, 0.28D0,
35503 & 8.55D0, -5.98D0, 0.28D0,
35504 & 8.55D0, 1.60D0, 0.28D0 /
35507 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35510 IF(ID2.NE.2212) THEN
35512 ELSE IF(ID1.EQ.2212) THEN
35514 ELSE IF(ID1.EQ.-2212) THEN
35516 ELSE IF(ID1.EQ.211) THEN
35518 ELSE IF(ID1.EQ.-211) THEN
35520 ELSE IF(ID1.EQ.321) THEN
35522 ELSE IF(ID1.EQ.-321) THEN
35528 C calculate lab momentum
35529 IF(IMODE.EQ.1) THEN
35531 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35532 PL = SQRT(E1*E1-XMA(K)**2)
35533 ELSE IF(IMODE.EQ.2) THEN
35535 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35538 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35543 C check against lower limit
35544 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35546 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35547 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35548 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35550 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35551 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35552 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35553 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35555 C select energy range and interpolation method
35556 IF(PL.LT.TPDG96(1,K)) THEN
35557 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35558 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35559 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35560 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35561 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35562 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35563 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35564 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35565 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35567 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35568 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35570 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35571 SIGEL = SIGEL2*X2 + SIGEL1*X1
35574 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35577 C no parametrization of diffraction implemented
35585 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35586 & 'invalid particle combination: ',ID1,ID2
35590 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35591 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35595 CDECK ID>, PHO_CSDIFF
35596 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35597 & sig_sd1,sig_sd2,sig_dd)
35598 C***********************************************************************
35600 C cross section for diffraction dissociation according to
35601 C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35603 C in addition rescaling for different particles is applied using
35604 C internal rescaling tables (not implemented yet)
35606 C input: Id1/2 PDG ID's of incoming particles
35607 C SS squared c.m. energy (GeV**2)
35608 C Xi_min min. diff mass (squared) = Xi_min*SS
35609 C Xi_max max. diff mass (squared) = Xi_max*SS
35611 C output: sig_sd1 cross section for diss. of particle 1 (mb)
35612 C sig_sd2 cross section for diss. of particle 2 (mb)
35613 C sig_dd cross section for diss. of both particles
35615 C***********************************************************************
35622 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35624 C input/output channels
35626 COMMON /POINOU/ LI,LO
35628 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35629 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35630 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35632 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35633 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35634 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35635 & xms_1,xms_2,CSdiff
35637 INTEGER Ngau1,Ngau2,i1,i2
35641 DATA delta / 0.104d0 /
35642 DATA alphap / 0.25d0 /
35643 DATA beta0 / 6.56d0 /
35644 DATA gpom0 / 1.21d0 /
35645 DATA xm_p / 0.938d0 /
35646 DATA x_rad2 / 0.71d0 /
35648 C integration precision
35657 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35659 xm4_p2 = 4.D0*xm_p**2
35660 fac = beta0**2/(16.D0*PI)
35664 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35665 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35667 C flux renormalization and cross section
35671 xil = log(1.5d0/SS)
35674 IF(xiu.LE.xil) goto 1000
35676 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35677 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35681 xi = exp(xpos1(i1))
35686 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35688 alpha_t = 1.D0+delta+alphap*tt
35689 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35692 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35707 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35708 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35710 C single diffraction diss. cross section
35714 IF(XIU.LE.XIL) goto 2000
35716 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35717 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35721 xi = exp(xpos1(i1))
35722 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35726 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35728 alpha_t = 1.D0+delta+alphap*tt
35729 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35732 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35737 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35739 * WRITE(LO,'(1x,1p,4e14.3)')
35740 * & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35747 C double diffraction dissociation cross section
35751 xil = log(1.5d0/SS)
35752 xiu = log(Xi_max/1.5d0)
35754 IF(xiu.LE.xil) goto 3000
35756 fac = (beta0*gpom0*SS**delta
35757 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35760 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35764 xi = exp(xpos1(i1))
35767 xiu = log(Xi_max/(xi*SS))
35769 if(xil.lt.xiu) then
35771 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35775 xms_2 = exp(xpos2(i2))*SS
35777 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35778 & *xwgh1(i1)*xwgh2(i2)
35786 sig_dd = CSdiff*fac*GEV2MB
35792 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35793 & 'invalid particle combination (Id1/2)',Id1,Id2
35799 CDECK ID>, PHO_ALLM97
35800 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35801 C**********************************************************************
35803 C ALLM97 parametrization for gamma*-p cross section
35804 C (for F2 see comments, code adapted from V. Shekelyan, H1)
35806 C**********************************************************************
35812 C input/output channels
35814 COMMON /POINOU/ LI,LO
35816 DOUBLE PRECISION Q2,W
35817 DOUBLE PRECISION M02,M12,LAM2,M22
35818 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35819 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35820 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35821 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35822 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35853 Q02 = 0.46017D0 +LAM2
35857 T=LOG((Q2+Q02)/LAM2)
35859 IF(Q2.GT.0.D0) S=LOG(T/T0)
35862 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35864 IF(S.LT.0.01D0) THEN
35868 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35874 F2P=SP*XP**AP*Z**BP
35878 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35884 F2R=SR*XR**AR*Z**BR
35890 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35892 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35894 BP=B11**2+B12**2*S**B13
35896 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35898 F2P=SP*XP**AP*Z**BP
35902 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35905 BR=B21**2+B22**2*S**B23
35908 F2R=SR*XR**AR*Z**BR
35912 * F2 = (F2P+F2R)*Q2/(Q2+M02)
35914 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35915 PHO_ALLM97 = CIN*(F2P+F2R)
35919 CDECK ID>, PHO_DOR98LO
35920 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35921 C***********************************************************************
35923 C GRV98 parton densities, leading order set
35925 C For a detailed explanation see
35926 C M. Glueck, E. Reya, A. Vogt :
35927 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35928 C (To appear in Eur. Phys. J. C)
35930 C interpolation routine based on the original GRV98PA routine,
35931 C adapted to define interpolation table as DATA statements
35936 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35937 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35939 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35940 C DS = d(bar), SS = s = s(bar), GL = gluon.
35941 C Always x times the distribution is returned.
35943 C******************************************************i****************
35944 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35947 C input/output channels
35949 COMMON /POINOU/ LI,LO
35951 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35952 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35953 1 XSF(NX,NQ), XGF(NX,NQ),
35954 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35956 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35957 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35959 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35960 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35961 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35962 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35963 EQUIVALENCE (XSF(1,1),XSF_L(1))
35964 EQUIVALENCE (XGF(1,1),XGF_L(1))
35966 DATA (ARRF(K),K= 1, 95) /
35967 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35968 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35969 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35970 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35971 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35972 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35973 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35974 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35975 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35976 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35977 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35978 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35979 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35980 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35981 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35982 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35983 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35984 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35985 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35986 DATA (XUVF_L(K),K= 1, 114) /
35987 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35988 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35989 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35990 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35991 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35992 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35993 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35994 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35995 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35996 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35997 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35998 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35999 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
36000 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36001 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36002 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36003 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36004 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36005 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36006 DATA (XUVF_L(K),K= 115, 228) /
36007 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36008 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36009 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36010 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36011 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36012 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36013 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36014 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36015 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36016 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36017 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36018 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36019 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36020 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36021 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36022 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36023 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36024 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36025 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36026 DATA (XUVF_L(K),K= 229, 342) /
36027 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36028 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36029 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36030 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36031 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36032 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36033 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36034 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36035 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36036 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36037 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36038 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36039 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36040 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36041 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36042 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36043 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36044 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36045 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36046 DATA (XUVF_L(K),K= 343, 456) /
36047 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36048 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36049 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36050 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36051 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36052 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36053 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36054 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36055 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36056 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36057 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36058 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36059 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36060 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36061 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36062 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36063 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36064 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36065 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36066 DATA (XUVF_L(K),K= 457, 570) /
36067 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36068 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36069 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36070 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36071 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36072 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36073 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36074 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36075 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36076 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36077 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36078 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36079 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36080 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36081 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36082 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36083 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36084 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36085 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36086 DATA (XUVF_L(K),K= 571, 684) /
36087 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36088 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36089 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36090 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36091 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36092 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36093 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36094 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36095 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36096 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36097 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36098 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36099 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36100 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36101 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36102 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36103 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36104 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36105 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36106 DATA (XUVF_L(K),K= 685, 798) /
36107 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36108 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36109 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36110 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36111 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36112 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36113 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36114 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36115 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36116 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36117 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36118 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36119 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36120 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36121 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36122 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36123 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36124 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36125 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36126 DATA (XUVF_L(K),K= 799, 912) /
36127 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36128 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36129 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36130 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36131 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36132 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36133 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36134 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36135 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36136 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36137 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36138 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36139 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36140 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36141 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36142 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36143 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36144 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36145 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36146 DATA (XUVF_L(K),K= 913, 1026) /
36147 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36148 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36149 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36150 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36151 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36152 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36153 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36154 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36155 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36156 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36157 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36158 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36159 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36160 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36161 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36162 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36163 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36164 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36165 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36166 DATA (XUVF_L(K),K= 1027, 1140) /
36167 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36168 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36169 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36170 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36171 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36172 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36173 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36174 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36175 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36176 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36177 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36178 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36179 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36180 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36181 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36182 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36183 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36184 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36185 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36186 DATA (XUVF_L(K),K= 1141, 1254) /
36187 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36188 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36189 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36190 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36191 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36192 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36193 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36194 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36195 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36196 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36197 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36198 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36199 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36200 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36201 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36202 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36203 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36204 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36205 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36206 DATA (XUVF_L(K),K= 1255, 1368) /
36207 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36208 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36209 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36210 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36211 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36212 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36213 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36214 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36215 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36216 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36217 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36218 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36219 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36220 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36221 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36222 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36223 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36224 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36225 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36226 DATA (XUVF_L(K),K= 1369, 1482) /
36227 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36228 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36229 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36230 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36231 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36232 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36233 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36234 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36235 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36236 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36237 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36238 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36239 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36240 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36241 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36242 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36243 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36244 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36245 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36246 DATA (XUVF_L(K),K= 1483, 1596) /
36247 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36248 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36249 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36250 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36251 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36252 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36253 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36254 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36255 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36256 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36257 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36258 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36259 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36260 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36261 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36262 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36263 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36264 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36265 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36266 DATA (XUVF_L(K),K= 1597, 1710) /
36267 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36268 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36269 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36270 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36271 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36272 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36273 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36274 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36275 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36276 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36277 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36278 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36279 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36280 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36281 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36282 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36283 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36284 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36285 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36286 DATA (XUVF_L(K),K= 1711, 1824) /
36287 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36288 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36289 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36290 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36291 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36292 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36293 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36294 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36295 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36296 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36297 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36298 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36299 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36300 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36301 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36302 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36303 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36304 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36305 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36306 DATA (XUVF_L(K),K= 1825, 1836) /
36307 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36308 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36309 DATA (XDVF_L(K),K= 1, 114) /
36310 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36311 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36312 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36313 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36314 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36315 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36316 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36317 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36318 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36319 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36320 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36321 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36322 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36323 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36324 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36325 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36326 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36327 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36328 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36329 DATA (XDVF_L(K),K= 115, 228) /
36330 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36331 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36332 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36333 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36334 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36335 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36336 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36337 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36338 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36339 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36340 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36341 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36342 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36343 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36344 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36345 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36346 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36347 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36348 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36349 DATA (XDVF_L(K),K= 229, 342) /
36350 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36351 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36352 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36353 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36354 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36355 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36356 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36357 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36358 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36359 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36360 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36361 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36362 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36363 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36364 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36365 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36366 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36367 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36368 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36369 DATA (XDVF_L(K),K= 343, 456) /
36370 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36371 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36372 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36373 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36374 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36375 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36376 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36377 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36378 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36379 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36380 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36381 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36382 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36383 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36384 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36385 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36386 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36387 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36388 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36389 DATA (XDVF_L(K),K= 457, 570) /
36390 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36391 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36392 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36393 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36394 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36395 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36396 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36397 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36398 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36399 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36400 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36401 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36402 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36403 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36404 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36405 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36406 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36407 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36408 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36409 DATA (XDVF_L(K),K= 571, 684) /
36410 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36411 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36412 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36413 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36414 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36415 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36416 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36417 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36418 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36419 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36420 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36421 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36422 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36423 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36424 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36425 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36426 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36427 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36428 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36429 DATA (XDVF_L(K),K= 685, 798) /
36430 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36431 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36432 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36433 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36434 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36435 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36436 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36437 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36438 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36439 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36440 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36441 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36442 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36443 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36444 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36445 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36446 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36447 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36448 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36449 DATA (XDVF_L(K),K= 799, 912) /
36450 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36451 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36452 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36453 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36454 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36455 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36456 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36457 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36458 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36459 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36460 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36461 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36462 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36463 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36464 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36465 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36466 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36467 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36468 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36469 DATA (XDVF_L(K),K= 913, 1026) /
36470 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36471 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36472 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36473 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36474 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36475 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36476 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36477 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36478 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36479 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36480 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36481 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36482 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36483 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36484 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36485 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36486 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36487 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36488 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36489 DATA (XDVF_L(K),K= 1027, 1140) /
36490 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36491 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36492 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36493 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36494 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36495 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36496 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36497 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36498 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36499 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36500 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36501 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36502 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36503 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36504 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36505 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36506 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36507 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36508 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36509 DATA (XDVF_L(K),K= 1141, 1254) /
36510 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36511 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36512 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36513 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36514 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36515 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36516 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36517 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36518 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36519 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36520 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36521 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36522 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36523 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36524 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36525 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36526 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36527 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36528 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36529 DATA (XDVF_L(K),K= 1255, 1368) /
36530 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36531 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36532 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36533 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36534 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36535 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36536 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36537 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36538 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36539 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36540 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36541 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36542 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36543 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36544 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36545 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36546 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36547 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36548 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36549 DATA (XDVF_L(K),K= 1369, 1482) /
36550 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36551 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36552 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36553 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36554 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36555 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36556 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36557 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36558 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36559 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36560 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36561 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36562 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36563 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36564 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36565 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36566 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36567 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36568 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36569 DATA (XDVF_L(K),K= 1483, 1596) /
36570 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36571 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36572 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36573 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36574 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36575 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36576 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36577 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36578 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36579 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36580 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36581 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36582 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36583 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36584 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36585 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36586 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36587 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36588 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36589 DATA (XDVF_L(K),K= 1597, 1710) /
36590 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36591 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36592 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36593 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36594 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36595 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36596 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36597 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36598 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36599 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36600 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36601 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36602 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36603 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36604 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36605 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36606 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36607 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36608 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36609 DATA (XDVF_L(K),K= 1711, 1824) /
36610 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36611 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36612 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36613 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36614 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36615 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36616 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36617 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36618 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36619 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36620 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36621 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36622 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36623 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36624 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36625 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36626 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36627 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36628 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36629 DATA (XDVF_L(K),K= 1825, 1836) /
36630 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36631 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36632 DATA (XDEF_L(K),K= 1, 114) /
36633 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36634 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36635 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36636 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36637 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36638 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36639 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36640 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36641 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36642 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36643 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36644 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36645 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36646 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36647 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36648 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36649 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36650 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36651 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36652 DATA (XDEF_L(K),K= 115, 228) /
36653 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36654 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36655 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36656 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36657 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36658 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36659 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36660 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36661 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36662 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36663 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36664 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36665 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36666 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36667 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36668 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36669 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36670 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36671 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36672 DATA (XDEF_L(K),K= 229, 342) /
36673 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36674 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36675 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36676 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36677 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36678 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36679 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36680 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36681 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36682 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36683 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36684 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36685 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36686 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36687 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36688 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36689 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36690 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36691 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36692 DATA (XDEF_L(K),K= 343, 456) /
36693 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36694 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36695 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36696 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36697 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36698 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36699 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36700 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36701 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36702 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36703 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36704 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36705 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36706 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36707 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36708 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36709 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36710 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36711 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36712 DATA (XDEF_L(K),K= 457, 570) /
36713 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36714 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36715 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36716 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36717 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36718 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36719 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36720 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36721 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36722 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36723 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36724 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36725 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36726 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36727 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36728 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36729 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36730 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36731 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36732 DATA (XDEF_L(K),K= 571, 684) /
36733 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36734 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36735 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36736 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36737 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36738 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36739 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36740 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36741 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36742 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36743 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36744 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36745 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36746 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36747 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36748 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36749 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36750 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36751 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36752 DATA (XDEF_L(K),K= 685, 798) /
36753 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36754 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36755 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36756 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36757 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36758 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36759 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36760 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36761 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36762 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36763 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36764 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36765 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36766 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36767 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36768 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36769 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36770 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36771 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36772 DATA (XDEF_L(K),K= 799, 912) /
36773 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36774 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36775 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36776 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36777 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36778 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36779 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36780 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36781 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36782 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36783 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36784 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36785 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36786 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36787 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36788 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36789 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36790 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36791 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36792 DATA (XDEF_L(K),K= 913, 1026) /
36793 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36794 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36795 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36796 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36797 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36798 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36799 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36800 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36801 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36802 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36803 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36804 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36805 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36806 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36807 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36808 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36809 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36810 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36811 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36812 DATA (XDEF_L(K),K= 1027, 1140) /
36813 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36814 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36815 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36816 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36817 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36818 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36819 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36820 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36821 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36822 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36823 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36824 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36825 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36826 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36827 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36828 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36829 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36830 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36831 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36832 DATA (XDEF_L(K),K= 1141, 1254) /
36833 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36834 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36835 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36836 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36837 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36838 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36839 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36840 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36841 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36842 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36843 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36844 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36845 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36846 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36847 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36848 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36849 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36850 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36851 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36852 DATA (XDEF_L(K),K= 1255, 1368) /
36853 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36854 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36855 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36856 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36857 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36858 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36859 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36860 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36861 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36862 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36863 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36864 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36865 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36866 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36867 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36868 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36869 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36870 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36871 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36872 DATA (XDEF_L(K),K= 1369, 1482) /
36873 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36874 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36875 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36876 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36877 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36878 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36879 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36880 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36881 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36882 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36883 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36884 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36885 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36886 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36887 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36888 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36889 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36890 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36891 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36892 DATA (XDEF_L(K),K= 1483, 1596) /
36893 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36894 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36895 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36896 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36897 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36898 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36899 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36900 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36901 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36902 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36903 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36904 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36905 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36906 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36907 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36908 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36909 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36910 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36911 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36912 DATA (XDEF_L(K),K= 1597, 1710) /
36913 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36914 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36915 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36916 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36917 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36918 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36919 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36920 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36921 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36922 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36923 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36924 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36925 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36926 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36927 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36928 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36929 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36930 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36931 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36932 DATA (XDEF_L(K),K= 1711, 1824) /
36933 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36934 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36935 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36936 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36937 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36938 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36939 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36940 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36941 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36942 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36943 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36944 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36945 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36946 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36947 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36948 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36949 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36950 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36951 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36952 DATA (XDEF_L(K),K= 1825, 1836) /
36953 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36954 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36955 DATA (XUDF_L(K),K= 1, 114) /
36956 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36957 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36958 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36959 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36960 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36961 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36962 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36963 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36964 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36965 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36966 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36967 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36968 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36969 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36970 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36971 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36972 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36973 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36974 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36975 DATA (XUDF_L(K),K= 115, 228) /
36976 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36977 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36978 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36979 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36980 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36981 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36982 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36983 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36984 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36985 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36986 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36987 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36988 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36989 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36990 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36991 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36992 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36993 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36994 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36995 DATA (XUDF_L(K),K= 229, 342) /
36996 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36997 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36998 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36999 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
37000 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37001 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37002 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37003 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37004 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37005 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37006 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37007 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37008 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37009 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37010 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37011 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37012 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37013 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37014 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37015 DATA (XUDF_L(K),K= 343, 456) /
37016 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37017 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37018 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37019 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37020 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37021 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37022 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37023 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37024 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37025 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37026 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37027 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37028 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37029 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37030 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37031 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37032 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37033 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37034 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37035 DATA (XUDF_L(K),K= 457, 570) /
37036 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37037 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37038 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37039 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37040 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37041 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37042 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37043 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37044 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37045 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37046 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37047 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37048 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37049 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37050 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37051 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37052 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37053 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37054 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37055 DATA (XUDF_L(K),K= 571, 684) /
37056 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37057 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37058 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37059 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37060 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37061 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37062 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37063 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37064 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37065 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37066 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37067 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37068 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37069 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37070 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37071 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37072 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37073 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37074 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37075 DATA (XUDF_L(K),K= 685, 798) /
37076 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37077 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37078 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37079 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37080 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37081 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37082 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37083 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37084 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37085 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37086 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37087 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37088 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37089 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37090 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37091 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37092 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37093 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37094 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37095 DATA (XUDF_L(K),K= 799, 912) /
37096 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37097 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37098 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37099 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37100 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37101 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37102 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37103 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37104 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37105 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37106 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37107 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37108 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37109 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37110 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37111 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37112 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37113 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37114 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37115 DATA (XUDF_L(K),K= 913, 1026) /
37116 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37117 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37118 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37119 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37120 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37121 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37122 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37123 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37124 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37125 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37126 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37127 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37128 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37129 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37130 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37131 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37132 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37133 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37134 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37135 DATA (XUDF_L(K),K= 1027, 1140) /
37136 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37137 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37138 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37139 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37140 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37141 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37142 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37143 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37144 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37145 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37146 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37147 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37148 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37149 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37150 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37151 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37152 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37153 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37154 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37155 DATA (XUDF_L(K),K= 1141, 1254) /
37156 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37157 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37158 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37159 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37160 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37161 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37162 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37163 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37164 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37165 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37166 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37167 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37168 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37169 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37170 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37171 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37172 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37173 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37174 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37175 DATA (XUDF_L(K),K= 1255, 1368) /
37176 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37177 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37178 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37179 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37180 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37181 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37182 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37183 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37184 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37185 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37186 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37187 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37188 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37189 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37190 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37191 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37192 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37193 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37194 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37195 DATA (XUDF_L(K),K= 1369, 1482) /
37196 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37197 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37198 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37199 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37200 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37201 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37202 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37203 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37204 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37205 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37206 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37207 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37208 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37209 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37210 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37211 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37212 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37213 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37214 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37215 DATA (XUDF_L(K),K= 1483, 1596) /
37216 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37217 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37218 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37219 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37220 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37221 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37222 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37223 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37224 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37225 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37226 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37227 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37228 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37229 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37230 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37231 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37232 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37233 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37234 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37235 DATA (XUDF_L(K),K= 1597, 1710) /
37236 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37237 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37238 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37239 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37240 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37241 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37242 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37243 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37244 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37245 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37246 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37247 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37248 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37249 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37250 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37251 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37252 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37253 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37254 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37255 DATA (XUDF_L(K),K= 1711, 1824) /
37256 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37257 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37258 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37259 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37260 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37261 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37262 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37263 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37264 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37265 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37266 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37267 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37268 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37269 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37270 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37271 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37272 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37273 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37274 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37275 DATA (XUDF_L(K),K= 1825, 1836) /
37276 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37277 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37278 DATA (XSF_L(K),K= 1, 114) /
37279 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37280 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37281 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37282 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37283 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37284 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37285 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37286 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37287 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37288 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37289 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37290 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37291 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37292 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37293 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37294 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37295 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37296 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37297 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37298 DATA (XSF_L(K),K= 115, 228) /
37299 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37300 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37301 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37302 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37303 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37304 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37305 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37306 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37307 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37308 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37309 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37310 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37311 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37312 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37313 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37314 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37315 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37316 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37317 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37318 DATA (XSF_L(K),K= 229, 342) /
37319 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37320 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37321 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37322 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37323 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37324 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37325 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37326 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37327 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37328 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37329 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37330 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37331 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37332 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37333 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37334 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37335 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37336 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37337 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37338 DATA (XSF_L(K),K= 343, 456) /
37339 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37340 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37341 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37342 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37343 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37344 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37345 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37346 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37347 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37348 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37349 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37350 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37351 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37352 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37353 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37354 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37355 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37356 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37357 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37358 DATA (XSF_L(K),K= 457, 570) /
37359 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37360 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37361 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37362 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37363 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37364 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37365 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37366 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37367 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37368 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37369 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37370 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37371 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37372 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37373 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37374 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37375 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37376 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37377 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37378 DATA (XSF_L(K),K= 571, 684) /
37379 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37380 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37381 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37382 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37383 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37384 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37385 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37386 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37387 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37388 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37389 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37390 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37391 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37392 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37393 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37394 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37395 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37396 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37397 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37398 DATA (XSF_L(K),K= 685, 798) /
37399 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37400 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37401 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37402 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37403 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37404 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37405 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37406 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37407 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37408 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37409 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37410 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37411 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37412 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37413 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37414 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37415 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37416 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37417 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37418 DATA (XSF_L(K),K= 799, 912) /
37419 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37420 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37421 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37422 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37423 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37424 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37425 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37426 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37427 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37428 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37429 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37430 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37431 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37432 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37433 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37434 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37435 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37436 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37437 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37438 DATA (XSF_L(K),K= 913, 1026) /
37439 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37440 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37441 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37442 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37443 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37444 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37445 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37446 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37447 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37448 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37449 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37450 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37451 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37452 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37453 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37454 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37455 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37456 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37457 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37458 DATA (XSF_L(K),K= 1027, 1140) /
37459 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37460 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37461 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37462 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37463 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37464 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37465 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37466 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37467 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37468 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37469 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37470 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37471 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37472 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37473 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37474 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37475 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37476 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37477 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37478 DATA (XSF_L(K),K= 1141, 1254) /
37479 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37480 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37481 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37482 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37483 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37484 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37485 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37486 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37487 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37488 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37489 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37490 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37491 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37492 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37493 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37494 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37495 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37496 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37497 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37498 DATA (XSF_L(K),K= 1255, 1368) /
37499 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37500 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37501 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37502 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37503 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37504 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37505 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37506 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37507 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37508 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37509 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37510 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37511 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37512 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37513 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37514 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37515 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37516 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37517 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37518 DATA (XSF_L(K),K= 1369, 1482) /
37519 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37520 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37521 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37522 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37523 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37524 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37525 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37526 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37527 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37528 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37529 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37530 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37531 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37532 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37533 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37534 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37535 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37536 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37537 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37538 DATA (XSF_L(K),K= 1483, 1596) /
37539 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37540 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37541 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37542 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37543 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37544 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37545 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37546 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37547 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37548 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37549 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37550 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37551 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37552 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37553 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37554 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37555 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37556 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37557 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37558 DATA (XSF_L(K),K= 1597, 1710) /
37559 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37560 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37561 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37562 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37563 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37564 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37565 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37566 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37567 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37568 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37569 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37570 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37571 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37572 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37573 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37574 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37575 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37576 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37577 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37578 DATA (XSF_L(K),K= 1711, 1824) /
37579 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37580 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37581 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37582 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37583 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37584 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37585 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37586 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37587 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37588 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37589 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37590 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37591 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37592 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37593 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37594 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37595 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37596 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37597 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37598 DATA (XSF_L(K),K= 1825, 1836) /
37599 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37600 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37601 DATA (XGF_L(K),K= 1, 114) /
37602 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37603 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37604 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37605 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37606 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37607 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37608 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37609 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37610 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37611 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37612 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37613 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37614 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37615 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37616 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37617 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37618 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37619 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37620 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37621 DATA (XGF_L(K),K= 115, 228) /
37622 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37623 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37624 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37625 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37626 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37627 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37628 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37629 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37630 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37631 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37632 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37633 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37634 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37635 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37636 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37637 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37638 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37639 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37640 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37641 DATA (XGF_L(K),K= 229, 342) /
37642 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37643 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37644 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37645 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37646 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37647 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37648 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37649 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37650 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37651 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37652 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37653 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37654 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37655 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37656 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37657 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37658 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37659 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37660 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37661 DATA (XGF_L(K),K= 343, 456) /
37662 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37663 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37664 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37665 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37666 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37667 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37668 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37669 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37670 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37671 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37672 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37673 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37674 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37675 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37676 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37677 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37678 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37679 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37680 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37681 DATA (XGF_L(K),K= 457, 570) /
37682 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37683 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37684 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37685 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37686 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37687 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37688 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37689 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37690 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37691 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37692 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37693 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37694 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37695 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37696 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37697 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37698 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37699 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37700 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37701 DATA (XGF_L(K),K= 571, 684) /
37702 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37703 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37704 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37705 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37706 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37707 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37708 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37709 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37710 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37711 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37712 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37713 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37714 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37715 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37716 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37717 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37718 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37719 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37720 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37721 DATA (XGF_L(K),K= 685, 798) /
37722 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37723 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37724 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37725 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37726 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37727 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37728 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37729 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37730 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37731 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37732 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37733 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37734 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37735 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37736 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37737 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37738 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37739 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37740 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37741 DATA (XGF_L(K),K= 799, 912) /
37742 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37743 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37744 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37745 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37746 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37747 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37748 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37749 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37750 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37751 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37752 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37753 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37754 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37755 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37756 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37757 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37758 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37759 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37760 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37761 DATA (XGF_L(K),K= 913, 1026) /
37762 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37763 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37764 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37765 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37766 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37767 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37768 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37769 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37770 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37771 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37772 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37773 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37774 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37775 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37776 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37777 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37778 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37779 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37780 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37781 DATA (XGF_L(K),K= 1027, 1140) /
37782 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37783 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37784 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37785 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37786 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37787 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37788 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37789 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37790 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37791 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37792 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37793 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37794 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37795 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37796 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37797 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37798 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37799 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37800 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37801 DATA (XGF_L(K),K= 1141, 1254) /
37802 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37803 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37804 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37805 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37806 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37807 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37808 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37809 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37810 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37811 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37812 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37813 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37814 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37815 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37816 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37817 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37818 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37819 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37820 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37821 DATA (XGF_L(K),K= 1255, 1368) /
37822 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37823 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37824 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37825 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37826 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37827 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37828 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37829 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37830 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37831 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37832 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37833 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37834 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37835 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37836 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37837 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37838 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37839 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37840 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37841 DATA (XGF_L(K),K= 1369, 1482) /
37842 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37843 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37844 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37845 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37846 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37847 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37848 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37849 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37850 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37851 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37852 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37853 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37854 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37855 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37856 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37857 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37858 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37859 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37860 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37861 DATA (XGF_L(K),K= 1483, 1596) /
37862 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37863 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37864 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37865 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37866 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37867 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37868 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37869 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37870 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37871 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37872 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37873 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37874 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37875 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37876 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37877 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37878 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37879 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37880 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37881 DATA (XGF_L(K),K= 1597, 1710) /
37882 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37883 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37884 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37885 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37886 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37887 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37888 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37889 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37890 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37891 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37892 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37893 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37894 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37895 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37896 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37897 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37898 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37899 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37900 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37901 DATA (XGF_L(K),K= 1711, 1824) /
37902 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37903 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37904 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37905 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37906 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37907 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37908 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37909 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37910 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37911 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37912 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37913 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37914 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37915 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37916 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37917 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37918 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37919 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37920 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37921 DATA (XGF_L(K),K= 1825, 1836) /
37922 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37923 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37927 *...CHECK OF X AND Q2 VALUES :
37928 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37930 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37936 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37938 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37944 *...INTERPOLATION :
37952 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37953 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37954 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37955 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37956 US = 0.5 * (UD - DE)
37957 DS = 0.5 * (UD + DE)
37958 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37959 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37963 CDECK ID>, PHO_DOR98SC
37964 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37965 C***********************************************************************
37967 C GRV98 parton densities, leading order set
37969 C For a detailed explanation see
37970 C M. Glueck, E. Reya, A. Vogt :
37971 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37972 C (To appear in Eur. Phys. J. C)
37974 C interpolation routine based on the original GRV98PA routine,
37975 C adapted to define interpolation table as DATA statements
37979 C CAUTION: this is a version with gluon shadowing corrections
37983 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37984 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37986 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37987 C DS = d(bar), SS = s = s(bar), GL = gluon.
37988 C Always x times the distribution is returned.
37990 C******************************************************i****************
37991 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37994 C input/output channels
37996 COMMON /POINOU/ LI,LO
37998 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37999 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
38000 1 XSF(NX,NQ), XGF(NX,NQ),
38001 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
38003 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38004 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38006 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38007 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38008 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38009 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38010 EQUIVALENCE (XSF(1,1),XSF_L(1))
38011 EQUIVALENCE (XGF(1,1),XGF_L(1))
38013 *#################### data statements for shadowed LO PDF ##############
38015 *#######################################################################
38018 *...CHECK OF X AND Q2 VALUES :
38019 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38021 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38027 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38029 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38035 *...INTERPOLATION :
38043 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38044 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38045 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38046 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38047 US = 0.5 * (UD - DE)
38048 DS = 0.5 * (UD + DE)
38049 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38050 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38054 CDECK ID>, PHO_DOR94LO
38055 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38057 * G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
38061 * FOR A DETAILED EXPLANATION SEE *
38062 * M. GLUECK, E.REYA, A.VOGT : *
38063 * DO-TH 94/24 = DESY 94-206 *
38064 * (TO APPEAR IN Z. PHYS. C) *
38066 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
38067 * Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
38068 * X BETWEEN 1.E-5 AND 1. *
38069 * LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
38070 * IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
38072 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
38073 * M(C) = 1.5, M(B) = 4.5 *
38074 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
38075 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38076 * LAMBDA(5) = 0.153, *
38077 * NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38078 * LAMBDA(5) = 0.131. *
38079 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
38080 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
38081 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
38082 * IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38083 * GRV PARAMETRIZATION. *
38085 * NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38086 * (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38087 * THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38089 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38091 *...INPUT PARAMETERS :
38093 * X = MOMENTUM FRACTION
38094 * Q2 = SCALE Q**2 IN GEV**2
38096 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38098 * UV = U(VAL) = U - U(BAR)
38099 * DV = D(VAL) = D - D(BAR)
38100 * DEL = D(BAR) - U(BAR)
38101 * UDB = U(BAR) + D(BAR)
38105 *...LO PARAMETRIZATION :
38107 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38108 IMPLICIT DOUBLE PRECISION (A - Z)
38112 LAM2 = 0.2322 * 0.2322
38113 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38118 NU = 2.284 + 0.802 * S + 0.055 * S2
38119 AKU = 0.590 - 0.024 * S
38120 BKU = 0.131 + 0.063 * S
38121 AU = -0.449 - 0.138 * S - 0.076 * S2
38122 BU = 0.213 + 2.669 * S - 0.728 * S2
38123 CU = 8.854 - 9.135 * S + 1.979 * S2
38124 DU = 2.997 + 0.753 * S - 0.076 * S2
38125 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38127 ND = 0.371 + 0.083 * S + 0.039 * S2
38129 BKD = 0.486 + 0.062 * S
38130 AD = -0.509 + 3.310 * S - 1.248 * S2
38131 BD = 12.41 - 10.52 * S + 2.267 * S2
38132 CD = 6.373 - 6.208 * S + 1.418 * S2
38133 DD = 3.691 + 0.799 * S - 0.071 * S2
38134 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38136 NE = 0.082 + 0.014 * S + 0.008 * S2
38137 AKE = 0.409 - 0.005 * S
38138 BKE = 0.799 + 0.071 * S
38139 AE = -38.07 + 36.13 * S - 0.656 * S2
38140 BE = 90.31 - 74.15 * S + 7.645 * S2
38142 DE = 7.486 + 1.217 * S - 0.159 * S2
38143 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38147 AKX = 0.410 - 0.232 * S
38148 BKX = 0.534 - 0.457 * S
38149 AGX = 0.890 - 0.140 * S
38151 CX = 0.320 + 0.683 * S
38152 DX = 4.752 + 1.164 * S + 0.286 * S2
38153 EX = 4.119 + 1.713 * S
38154 ESX = 0.682 + 2.978 * S
38155 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38159 AKS = 1.798 - 0.596 * S
38160 AS = -5.548 + 3.669 * DS - 0.616 * S
38161 BS = 18.92 - 16.73 * DS + 5.168 * S
38162 DST = 6.379 - 0.350 * S + 0.142 * S2
38163 EST = 3.981 + 1.638 * S
38165 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38169 AKG = 1.742 - 0.930 * S
38171 AG = 7.486 - 2.185 * S
38172 BG = 16.69 - 22.74 * S + 5.779 * S2
38173 CG = -25.59 + 29.71 * S - 7.296 * S2
38174 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38175 EG = 0.807 + 2.005 * S
38176 ESG = 3.841 + 0.316 * S
38177 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38182 *...NLO PARAMETRIZATION (MS(BAR)) :
38184 CDECK ID>, PHO_DOR94HO
38185 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38186 IMPLICIT DOUBLE PRECISION (A - Z)
38190 LAM2 = 0.248 * 0.248
38191 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38196 NU = 1.304 + 0.863 * S
38197 AKU = 0.558 - 0.020 * S
38199 AU = -0.113 + 0.283 * S - 0.321 * S2
38200 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38201 CU = 7.771 - 10.09 * S + 2.630 * S2
38202 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38203 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38205 ND = 0.102 - 0.017 * S + 0.005 * S2
38206 AKD = 0.270 - 0.019 * S
38208 AD = 2.393 + 6.228 * S - 0.881 * S2
38209 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38210 CD = 17.83 - 53.47 * S + 21.24 * S2
38211 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38212 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38214 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38215 AKE = 0.409 - 0.007 * S
38216 BKE = 0.782 + 0.082 * S
38217 AE = -29.65 + 26.49 * S + 5.429 * S2
38218 BE = 90.20 - 74.97 * S + 4.526 * S2
38220 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38221 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38228 BGX = 3.210 - 1.866 * S
38230 DX = 9.010 + 0.896 * DS + 0.222 * S2
38231 EX = 3.077 + 1.446 * S
38232 ESX = 3.173 - 2.445 * DS + 2.207 * S
38233 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38237 AKS = 1.690 + 0.650 * DS - 0.922 * S
38238 AS = -4.329 + 1.131 * S
38239 BS = 9.568 - 1.744 * S
38240 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38241 EST = 3.031 + 1.639 * S
38242 ESS = 5.837 + 0.815 * S
38243 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38247 AKG = 1.724 + 0.157 * S
38248 BKG = 0.800 + 1.016 * S
38249 AG = 7.517 - 2.547 * S
38250 BG = 34.09 - 52.21 * DS + 17.47 * S
38251 CG = 4.039 + 1.491 * S
38252 DG = 3.404 + 0.830 * S
38253 EG = -1.112 + 3.438 * S - 0.302 * S2
38254 ESG = 3.256 - 0.436 * S
38255 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38259 CDECK ID>, PHO_DOR94DI
38261 *...NLO PARAMETRIZATION (DIS) :
38263 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38264 IMPLICIT DOUBLE PRECISION (A - Z)
38268 LAM2 = 0.248 * 0.248
38269 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38274 NU = 2.484 + 0.116 * S + 0.093 * S2
38275 AKU = 0.563 - 0.025 * S
38276 BKU = 0.054 + 0.154 * S
38277 AU = -0.326 - 0.058 * S - 0.135 * S2
38278 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38279 CU = 11.52 - 12.99 * S + 3.161 * S2
38280 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38281 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38283 ND = 0.156 - 0.017 * S
38284 AKD = 0.299 - 0.022 * S
38285 BKD = 0.259 - 0.015 * S
38286 AD = 3.445 + 1.278 * S + 0.326 * S2
38287 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38288 CD = 55.45 - 69.92 * S + 20.78 * S2
38289 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38290 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38292 NE = 0.099 + 0.019 * S + 0.002 * S2
38293 AKE = 0.419 - 0.013 * S
38294 BKE = 1.064 - 0.038 * S
38295 AE = -44.00 + 98.70 * S - 14.79 * S2
38296 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38297 CE = 84.57 - 108.8 * S + 31.52 * S2
38298 DE = 7.469 + 2.480 * S - 0.866 * S2
38299 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38303 AKX = 0.326 + 0.150 * S
38304 BKX = 0.956 + 0.405 * S
38306 BGX = 3.794 - 2.359 * DS
38308 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38309 EX = 3.049 + 1.597 * S
38310 ESX = 4.396 - 4.594 * DS + 3.268 * S
38311 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38315 AKS = 1.415 - 0.641 * DS
38316 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38317 BS = 5.617 + 5.709 * DS - 3.972 * S
38318 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38319 EST = 4.546 + 0.372 * S2
38320 ESS = 5.053 - 1.070 * S + 0.805 * S2
38321 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38326 BKG = 2.427 + 1.311 * S - 0.153 * S2
38327 AG = 25.09 - 7.935 * S
38328 BG = -14.84 - 124.3 * DS + 72.18 * S
38329 CG = 590.3 - 173.8 * S
38330 DG = 5.196 + 1.857 * S
38331 EG = -1.648 + 3.988 * S - 0.432 * S2
38332 ESG = 3.232 - 0.542 * S
38333 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38338 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38340 CDECK ID>, PHO_DOR94FV
38341 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38342 IMPLICIT DOUBLE PRECISION (A - Z)
38346 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38350 CDECK ID>, PHO_DOR94FW
38351 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38353 IMPLICIT DOUBLE PRECISION (A - Z)
38357 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38358 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38362 CDECK ID>, PHO_DOR94FS
38363 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38364 IMPLICIT DOUBLE PRECISION (A - Z)
38369 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38370 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38374 CDECK ID>, PHO_DOR92LO
38377 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38379 * G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
38381 * FOR A DETAILED EXPLANATION SEE : *
38382 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38384 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38385 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38386 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38387 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38388 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38390 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38391 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38393 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38394 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38395 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38396 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38397 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38399 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38401 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38403 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38404 IMPLICIT DOUBLE PRECISION (A - Z)
38408 LAM2 = 0.232 * 0.232
38409 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38412 C...X * (UV + DV) :
38413 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38415 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38416 BUD = 24.4 - 20.7 * S + 4.08 * S2
38417 DUD = 2.86 + 0.70 * S - 0.02 * S2
38418 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38420 ND = 0.579 + 0.283 * S + 0.047 * S2
38421 AKD = 0.523 - 0.015 * S
38422 AGD = 2.22 - 0.59 * S - 0.27 * S2
38423 BD = 5.95 - 6.19 * S + 1.55 * S2
38424 DD = 3.57 + 0.94 * S - 0.16 * S2
38425 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38429 AKG = 1.00 - 0.17 * S
38431 AGG = 0.0 + 4.879 * S - 1.383 * S2
38432 BGG = 25.92 - 28.97 * S + 5.596 * S2
38433 CG = -25.69 + 23.68 * S - 1.975 * S2
38434 DG = 2.537 + 1.718 * S + 0.353 * S2
38435 EG = 0.595 + 2.138 * S
38437 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38438 C...X * UBAR = X * DBAR :
38441 AKU = 0.412 - 0.171 * S
38442 BKU = 0.566 - 0.496 * S
38445 CU = 1.029 + 1.785 * S - 0.459 * S2
38446 DU = 4.696 + 2.109 * S
38447 EU = 3.838 + 1.944 * S
38449 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38450 C...X * SBAR = X * S :
38454 AKS = 2.082 - 0.577 * S
38455 AGS = -3.055 + 1.024 * S ** 0.67
38456 BS = 27.4 - 20.0 * S ** 0.154
38458 EST = 4.33 + 1.408 * S
38459 ESS = 8.27 - 0.437 * S
38460 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38461 C...X * CBAR = X * C :
38467 BC = 4.24 - 0.804 * S
38468 DC = 3.46 + 1.076 * S
38469 EC = 4.61 + 1.490 * S
38470 ESC = 2.555 + 1.961 * S
38471 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38472 C...X * BBAR = X * B :
38479 DB = 2.929 + 1.396 * S
38480 EB = 4.71 + 1.514 * S
38481 ESB = 4.02 + 1.239 * S
38482 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38486 CDECK ID>, PHO_DOR92HO
38487 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38488 IMPLICIT DOUBLE PRECISION (A - Z)
38492 LAM2 = 0.248 * 0.248
38493 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38497 C...X * (UV + DV) :
38498 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38500 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38501 BUD = 56.7 - 53.6 * S + 11.21 * S2
38502 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38503 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38505 ND = 0.459 + 0.315 * DS + 0.515 * S
38506 AKD = 0.624 - 0.031 * S
38507 AGD = 8.13 - 6.77 * DS + 0.46 * S
38508 BD = 6.59 - 12.83 * DS + 5.65 * S
38509 DD = 3.98 + 1.04 * S - 0.34 * S2
38510 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38514 AKG = 0.323 + 1.653 * S
38515 BKG = 0.811 + 2.044 * S
38516 AGG = 0.0 + 1.963 * S - 0.519 * S2
38517 BGG = 0.078 + 6.24 * S
38518 CG = 30.77 - 24.19 * S
38519 DG = 3.188 + 0.720 * S
38520 EG = -0.881 + 2.687 * S
38522 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38523 C...X * UBAR = X * DBAR :
38526 AKU = 0.636 - 0.084 * S
38528 AGU = 1.121 - 0.193 * S
38529 BGU = 0.751 - 0.785 * S
38530 CU = 8.57 - 1.763 * S
38531 DU = 10.22 + 0.668 * S
38532 EU = 3.784 + 1.280 * S
38533 ESU = 1.808 + 0.980 * S
38534 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38535 C...X * SBAR = X * S :
38539 AKS = 2.942 - 1.016 * S
38540 AGS = -4.60 + 1.167 * S
38541 BS = 9.31 - 1.324 * S
38542 DS = 11.49 - 1.198 * S + 0.053 * S2
38543 EST = 2.630 + 1.729 * S
38545 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38546 C...X * CBAR = X * C :
38550 AKC = -0.625 - 0.523 * S
38552 BC = 1.896 + 1.616 * S
38553 DC = 4.12 + 0.683 * S
38554 EC = 4.36 + 1.328 * S
38555 ESC = 0.677 + 0.679 * S
38556 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38557 C...X * BBAR = X * B :
38561 AKB = 0.0 - 0.193 * S
38564 DB = 3.447 + 0.927 * S
38565 EB = 4.68 + 1.259 * S
38566 ESB = 1.892 + 2.199 * S
38567 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38571 CDECK ID>, PHO_DOR92FV
38572 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38573 IMPLICIT DOUBLE PRECISION (A - Z)
38576 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38580 CDECK ID>, PHO_DOR92FW
38581 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38582 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38583 IMPLICIT DOUBLE PRECISION (A - Z)
38586 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38587 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38591 CDECK ID>, PHO_DOR92FS
38592 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38593 IMPLICIT DOUBLE PRECISION (A - Z)
38598 IF (S .LE. ST) THEN
38601 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38602 1 * EXP (-E + SQRT (ES * S**BE * LX))
38607 CDECK ID>, PHO_DORPLO
38609 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38611 * G R V - P I O N - P A R A M E T R I Z A T I O N S *
38613 * FOR A DETAILED EXPLANATION SEE : *
38614 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38616 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38617 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38618 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38619 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38620 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38622 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38623 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38625 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38626 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38627 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38628 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38629 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38631 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38633 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38635 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38636 IMPLICIT DOUBLE PRECISION (A - Z)
38640 LAM2 = 0.232 * 0.232
38641 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38645 NV = 0.519 + 0.180 * S - 0.011 * S2
38646 AKV = 0.499 - 0.027 * S
38647 AGV = 0.381 - 0.419 * S
38648 DV = 0.367 + 0.563 * S
38649 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38653 AKG = 0.482 + 0.341 * DS
38655 AGG = 0.678 + 0.877 * S - 0.175 * S2
38656 BGG = 0.338 - 1.597 * S
38657 CG = 0.0 - 0.233 * S + 0.406 * S2
38658 DG = 0.390 + 1.053 * S
38659 EG = 0.618 + 2.070 * S
38661 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38662 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38666 AKS = 2.538 - 0.763 * S
38668 BS = 0.313 + 0.935 * S
38670 EST = 4.433 + 1.301 * S
38671 ESS = 9.30 - 0.887 * S
38672 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38673 C...X * CBAR = X * C :
38680 DC = 1.208 + 0.771 * S
38681 EC = 4.40 + 1.493 * S
38682 ESC = 2.032 + 1.901 * S
38683 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38684 C...X * BBAR = X * B :
38691 DB = 0.697 + 0.855 * S
38692 EB = 4.51 + 1.490 * S
38693 ESB = 3.056 + 1.694 * S
38694 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38698 CDECK ID>, PHO_DORPHO
38699 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38700 IMPLICIT DOUBLE PRECISION (A - Z)
38704 LAM2 = 0.248 * 0.248
38705 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38709 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38710 AKV = 0.505 - 0.033 * S
38711 AGV = 0.748 - 0.669 * DS - 0.133 * S
38712 DV = 0.365 + 0.197 * DS + 0.394 * S
38713 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38717 AKG = 0.437 - 0.689 * DS
38719 AGG = 1.324 - 0.441 * DS - 0.130 * S
38720 BGG = -0.955 + 0.259 * S
38721 CG = 1.075 - 0.302 * S
38722 DG = 1.158 + 1.229 * S
38723 EG = 0.0 + 2.510 * S
38724 ESG = 2.604 + 0.165 * S
38725 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38726 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38730 AKS = -0.350 + 0.806 * S
38733 DS = 2.273 + 1.438 * S
38734 EST = 3.214 + 1.545 * S
38735 ESS = 1.341 + 1.938 * S
38736 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38737 C...X * CBAR = X * C :
38741 AKC = 0.0 - 0.457 * S
38743 BC = -1.00 + 1.40 * S
38744 DC = 1.318 + 0.584 * S
38745 EC = 4.45 + 1.235 * S
38746 ESC = 1.496 + 1.010 * S
38747 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38748 C...X * BBAR = X * B :
38752 AKB = 0.0 - 0.172 * S
38755 DB = 1.447 + 0.485 * S
38756 EB = 4.79 + 1.164 * S
38757 ESB = 1.724 + 2.121 * S
38758 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38762 CDECK ID>, PHO_DORFVP
38763 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38764 IMPLICIT DOUBLE PRECISION (A - Z)
38768 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38772 CDECK ID>, PHO_DORFGP
38773 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38775 IMPLICIT DOUBLE PRECISION (A - Z)
38780 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38781 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38785 CDECK ID>, PHO_DORFQP
38786 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38787 IMPLICIT DOUBLE PRECISION (A - Z)
38792 IF (S .LE. ST) THEN
38795 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38796 1 * EXP (-E + SQRT (ES * S**BE * LX))
38801 CDECK ID>, PHO_DORGLO
38802 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38804 * G R V - P H O T O N - P A R A M E T R I Z A T I O N S *
38806 * FOR A DETAILED EXPLANATION SEE : *
38807 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38809 * THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38811 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38812 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38813 * / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38815 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38816 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38818 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38819 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38820 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38821 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38822 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38824 * HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38825 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38827 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38829 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38830 IMPLICIT DOUBLE PRECISION (A - Z)
38834 LAM2 = 0.232 * 0.232
38835 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38838 C...X * U = X * UBAR :
38841 AK = 0.500 - 0.176 * S
38842 BK = 15.00 - 5.687 * SS - 0.552 * S2
38843 AG = 0.235 + 0.046 * SS
38844 BG = 0.082 - 0.051 * S + 0.168 * S2
38845 C = 0.0 + 0.459 * S
38846 D = 0.354 - 0.061 * S
38847 E = 4.899 + 1.678 * S
38848 ES = 2.046 + 1.389 * S
38849 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38850 C...X * D = X * DBAR :
38853 AK = 0.496 + 0.026 * S
38854 BK = 0.685 - 0.580 * SS + 0.608 * S2
38855 AG = 0.233 + 0.302 * S
38856 BG = 0.0 - 0.818 * S + 0.198 * S2
38857 C = 0.114 + 0.154 * S
38858 D = 0.405 - 0.195 * S + 0.046 * S2
38859 E = 4.807 + 1.226 * S
38860 ES = 2.166 + 0.664 * S
38861 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38865 AK = 0.462 - 0.524 * SS
38866 BK = 5.451 - 0.804 * S2
38867 AG = 0.535 - 0.504 * SS + 0.288 * S2
38868 BG = 0.364 - 0.520 * S
38869 C = -0.323 + 0.115 * S2
38870 D = 0.233 + 0.790 * S - 0.139 * S2
38871 E = 0.893 + 1.968 * S
38872 ES = 3.432 + 0.392 * S
38873 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38874 C...X * S = X * SBAR :
38878 AK = 0.470 - 0.099 * S2
38880 AG = 0.121 - 0.068 * SS
38881 BG = -0.090 + 0.074 * S
38882 C = 0.062 + 0.034 * S
38883 D = 0.0 + 0.226 * S - 0.060 * S2
38884 E = 4.288 + 1.707 * S
38885 ES = 2.122 + 0.656 * S
38886 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38887 C...X * C = X * CBAR :
38891 AK = 1.254 - 0.251 * S
38892 BK = 3.932 - 0.327 * S2
38893 AG = 0.658 + 0.202 * S
38896 D = 0.0 + 0.141 * S - 0.027 * S2
38897 E = 4.911 + 0.969 * S
38898 ES = 2.796 + 0.952 * S
38899 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38900 C...X * B = X * BBAR :
38904 AK = 1.961 - 0.370 * S
38905 BK = 0.923 + 0.119 * S
38906 AG = 0.815 + 0.207 * S
38909 D = -0.223 + 0.173 * S
38910 E = 5.426 + 0.623 * S
38911 ES = 3.819 + 0.901 * S
38912 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38916 CDECK ID>, PHO_DORGHO
38917 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38918 IMPLICIT DOUBLE PRECISION (A - Z)
38922 LAM2 = 0.248 * 0.248
38923 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38926 C...X * U = X * UBAR :
38929 AK = 0.449 - 0.025 * S - 0.071 * S2
38930 BK = 5.060 - 1.116 * SS
38932 BG = 0.319 + 0.422 * S
38933 C = 1.508 + 4.792 * S - 1.963 * S2
38934 D = 1.075 + 0.222 * SS - 0.193 * S2
38935 E = 4.147 + 1.131 * S
38936 ES = 1.661 + 0.874 * S
38937 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38938 C...X * D = X * DBAR :
38941 AK = 0.442 - 0.132 * S - 0.058 * S2
38942 BK = 5.437 - 1.916 * SS
38944 BG = 0.311 - 0.059 * S
38945 C = 0.800 + 0.078 * S - 0.100 * S2
38946 D = 0.862 + 0.294 * SS - 0.184 * S2
38947 E = 4.202 + 1.352 * S
38948 ES = 1.841 + 0.990 * S
38949 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38953 AK = 0.530 - 0.742 * SS + 0.025 * S2
38955 AG = 0.533 - 0.281 * SS + 0.218 * S2
38956 BG = 0.025 - 0.518 * S + 0.156 * S2
38957 C = -0.282 + 0.209 * S2
38958 D = 0.107 + 1.058 * S - 0.218 * S2
38959 E = 0.0 + 2.704 * S
38960 ES = 3.071 - 0.378 * S
38961 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38962 C...X * S = X * SBAR :
38966 AK = 1.770 - 0.735 * SS - 0.079 * S2
38968 AG = 0.084 - 0.023 * S
38970 C = 2.119 - 0.942 * S + 0.063 * S2
38971 D = 1.271 + 0.076 * S - 0.190 * S2
38972 E = 4.604 + 0.737 * S
38973 ES = 1.641 + 0.976 * S
38974 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38975 C...X * C = X * CBAR :
38979 AK = 1.142 - 0.175 * S
38981 AG = 0.504 + 0.317 * S
38984 D = 0.398 + 0.326 * S - 0.107 * S2
38985 E = 5.493 + 0.408 * S
38986 ES = 2.426 + 1.277 * S
38987 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38988 C...X * B = X * BBAR :
38992 AK = 1.953 - 0.391 * S
38993 BK = 1.657 - 0.161 * S
38994 AG = 1.076 + 0.034 * S
38997 D = 0.353 + 0.016 * S
38998 E = 5.713 + 0.249 * S
38999 ES = 3.456 + 0.673 * S
39000 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39004 CDECK ID>, PHO_DORGH0
39005 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39006 IMPLICIT DOUBLE PRECISION (A - Z)
39010 LAM2 = 0.248 * 0.248
39011 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39014 C...X * U = X * UBAR :
39017 AK = 0.527 + 0.200 * S - 0.107 * S2
39018 BK = 7.106 - 0.310 * SS - 0.786 * S2
39019 AG = 0.197 + 0.533 * S
39020 BG = 0.062 - 0.398 * S + 0.109 * S2
39021 C = 0.755 * S - 0.112 * S2
39022 D = 0.318 - 0.059 * S
39023 E = 4.225 + 1.708 * S
39024 ES = 1.752 + 0.866 * S
39025 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39026 C...X * D = X * DBAR :
39029 AK = 0.500 + 0.067 * SS - 0.055 * S2
39030 BK = 0.376 - 0.453 * SS + 0.405 * S2
39031 AG = 0.156 + 0.184 * S
39032 BG = 0.0 - 0.528 * S + 0.146 * S2
39033 C = 0.121 + 0.092 * S
39034 D = 0.379 - 0.301 * S + 0.081 * S2
39035 E = 4.346 + 1.638 * S
39036 ES = 1.645 + 1.016 * S
39037 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39041 AK = 0.537 - 0.600 * SS
39042 BK = 6.389 - 0.953 * S2
39043 AG = 0.558 - 0.383 * SS + 0.261 * S2
39044 BG = 0.0 - 0.305 * S
39045 C = -0.222 + 0.078 * S2
39046 D = 0.153 + 0.978 * S - 0.209 * S2
39047 E = 1.429 + 1.772 * S
39048 ES = 3.331 + 0.806 * S
39049 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39050 C...X * S = X * SBAR :
39054 AK = 0.622 + 0.332 * S - 0.300 * S2
39056 AG = 0.211 - 0.064 * SS - 0.018 * S2
39057 BG = -0.215 + 0.122 * S
39059 D = 0.0 + 0.253 * S - 0.081 * S2
39060 E = 3.990 + 2.014 * S
39061 ES = 1.720 + 0.986 * S
39062 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39063 C...X * C = X * CBAR :
39067 AK = 1.228 - 0.231 * S
39068 BK = 3.806 - 0.337 * S2
39069 AG = 0.932 + 0.150 * S
39072 D = 0.0 + 0.138 * S - 0.028 * S2
39073 E = 5.588 + 0.628 * S
39074 ES = 2.665 + 1.054 * S
39075 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39076 C...X * B = X * BBAR :
39080 AK = 1.719 - 0.292 * S
39081 BK = 0.928 + 0.096 * S
39082 AG = 0.845 + 0.178 * S
39085 D = -0.191 + 0.151 * S
39086 E = 6.089 + 0.282 * S
39087 ES = 3.379 + 1.062 * S
39088 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39092 CDECK ID>, PHO_DORGF
39093 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39095 IMPLICIT DOUBLE PRECISION (A - Z)
39100 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39101 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39105 CDECK ID>, PHO_DORGFS
39106 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39108 IMPLICIT DOUBLE PRECISION (A - Z)
39111 IF (S .LE. SF) THEN
39117 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39118 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39123 CDECK ID>, PHO_DORGLV
39124 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39126 * G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39128 * FOR A DETAILED EXPLANATION SEE *
39129 * M. GLUECK, E.REYA, M. STRATMANN : *
39130 * PHYS. REV. D51 (1995) 3220 *
39132 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39133 * Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39134 * AND (!) Q**2 > 5 P**2 *
39135 * P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39136 * P**2 = 0 <=> REAL PHOTON *
39137 * X BETWEEN 1.E-4 AND 1. *
39139 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39140 * M(C) = 1.5, M(B) = 4.5 *
39141 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39142 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39143 * LAMBDA(5) = 0.153, *
39144 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39145 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39146 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39148 * PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39149 * Marco.Stratmann@durham.ac.uk *
39150 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39152 *...INPUT PARAMETERS :
39154 * X = MOMENTUM FRACTION
39155 * Q2 = SCALE Q**2 IN GEV**2
39156 * P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39158 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39160 ********************************************************
39161 * subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39162 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39163 implicit double precision (a-z)
39166 C input/output channels
39168 COMMON /POINOU/ LI,LO
39175 if(x.lt.0.0001d0) check=1
39176 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39177 if(q2.lt.5.d0*p2) check=1
39179 c calculate distributions
39181 if(check.eq.0) then
39182 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39184 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39185 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39190 CDECK ID>, PHO_grscalc
39191 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39192 implicit double precision (a-z)
39195 dimension u1(40),ds1(40),g1(40)
39196 dimension ud2(20),s2(20),g2(20)
39197 dimension up0(20),dsp0(20),gp0(20)
39198 save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39200 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39201 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39202 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39203 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39204 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39205 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39206 & 0.622d0,0.227d0,-0.184d0/
39207 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39208 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39209 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39210 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39211 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39212 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39213 & 0.245d0,-0.171d0/
39214 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39215 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39216 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39217 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39218 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39219 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39220 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39221 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39222 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39223 & -0.614d0,3.548d0/
39224 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39225 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39226 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39228 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39229 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39230 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39232 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39233 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39234 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39236 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39237 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39238 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39239 & 0.814d0,1.531d0,0.124d0/
39240 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39241 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39242 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39243 & 2.264d0,0.2675d0/
39246 lam2=0.232d0*0.232d0
39248 if(p2.le.0.25d0) then
39249 s=log(log(q2/lam2)/log(mu2/lam2))
39253 s=log(log(q2/lam2)/log(p2/lam2))
39254 lp1=log(p2/mu2)*log(p2/mu2)
39255 lp2=log(p2/mu2+log(p2/mu2))
39258 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39259 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39260 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39261 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39262 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39263 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39264 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39265 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39266 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39267 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39268 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39269 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39270 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39271 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39272 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39273 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39274 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39275 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39276 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39277 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39278 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39280 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39281 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39282 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39283 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39284 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39285 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39286 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39287 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39288 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39289 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39290 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39291 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39292 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39293 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39294 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39295 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39296 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39297 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39298 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39299 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39300 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39302 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39303 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39304 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39305 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39306 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39307 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39308 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39309 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39310 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39311 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39312 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39313 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39314 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39315 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39316 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39317 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39318 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39319 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39320 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39321 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39322 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39324 s=log(log(q2/lam2)/log(mu2/lam2))
39325 suppr=1.d0/(1.d0+p2/0.59d0)**2
39330 ga=ud2(5)+ud2(6)*s**0.5
39332 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39333 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39334 gd=ud2(15)+ud2(16)*s
39335 ge=ud2(17)+ud2(18)*s
39336 gep=ud2(19)+ud2(20)*s
39337 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39342 ga=s2(5)+s2(6)*s**0.5
39344 b=s2(9)+s2(10)*s+s2(11)*s**2
39345 gb=s2(12)+s2(13)*s+s2(14)*s**2
39348 gep=s2(19)+s2(20)*s
39349 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39353 a=g2(3)+g2(4)*s**0.5
39356 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39357 gc=g2(12)+g2(13)*s**2
39358 gd=g2(14)+g2(15)*s+g2(16)*s**2
39360 gep=g2(19)+g2(20)*s
39361 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39363 ugam=upart1+udpart2
39364 dgam=dspart1+udpart2
39365 sgam=dspart1+spart2
39370 CDECK ID>, PHO_grsf1
39371 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39373 implicit double precision (a-z)
39376 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39377 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39382 CDECK ID>, PHO_grsf2
39383 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39385 implicit double precision (a-z)
39388 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39389 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39394 CDECK ID>, PHO_CKMTPA
39395 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39396 C**********************************************************************
39398 C PDF based on Regge theory, evolved with .... by ....
39400 C input: IPAR 2212 proton (not installed)
39403 C output: parameters of parametrization
39405 C**********************************************************************
39406 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39411 C input/output channels
39413 COMMON /POINOU/ LI,LO
39415 REAL PROP(40),POMP(40)
39417 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39418 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39419 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39420 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39421 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39422 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39423 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39424 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39426 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39427 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39428 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39429 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39430 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39431 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39432 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39433 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39435 IF(IPA.EQ.2212) THEN
39440 ELSE IF(IPA.EQ.990) THEN
39446 WRITE(LO,'(1X,A,I7)')
39447 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39454 CDECK ID>, PHO_CKMTPD
39455 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39456 C**********************************************************************
39458 C PDF based on Regge theory, evolved with .... by ....
39460 C input: IPAR 2212 proton (not installed)
39463 C output: PD(-6:6) x*f(x) parton distribution functions
39464 C (PDFLIB convention: d = PD(1), u = PD(2) )
39466 C**********************************************************************
39469 C input/output channels
39471 COMMON /POINOU/ LI,LO
39473 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39479 C QCD lambda for evolution
39482 C Q0**2 for evolution
39486 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39487 C q(6)=x*charm, q(7)=x*gluon
39491 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39493 IF(IPAR.EQ.2212) THEN
39494 * CALL PHO_CKMTPR(XX,SB,QQ
39495 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39498 CALL PHO_CKMTPO(XX,SB,QQ)
39503 PD(-4) = DBLE(QQ(6))
39504 PD(-3) = DBLE(QQ(3))
39505 PD(-2) = DBLE(QQ(4))
39506 PD(-1) = DBLE(QQ(5))
39507 PD(0) = DBLE(QQ(7))
39508 PD(1) = DBLE(QQ(2))
39509 PD(2) = DBLE(QQ(1))
39510 PD(3) = DBLE(QQ(3))
39511 PD(4) = DBLE(QQ(6))
39514 IF(IPAR.EQ.990) THEN
39515 CDN = (PD(1)-PD(-1))/2.D0
39516 CUP = (PD(2)-PD(-2))/2.D0
39517 PD(-1) = PD(-1) + CDN
39518 PD(-2) = PD(-2) + CUP
39524 CDECK ID>, PHO_CKMTPO
39525 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39526 C**********************************************************************
39528 C calculation partons in Pomeron
39530 C**********************************************************************
39535 C input/output channels
39537 COMMON /POINOU/ LI,LO
39539 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39540 EQUIVALENCE (GF(1,1,1),DL(1))
39544 C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39545 C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39546 DATA (DL(K),K= 1, 85) /
39547 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39548 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39549 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39550 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39551 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39552 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39553 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39554 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39555 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39556 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39557 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39558 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39559 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39560 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39561 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39562 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39563 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39564 DATA (DL(K),K= 86, 170) /
39565 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39566 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39567 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39568 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39569 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39570 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39571 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39572 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39573 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39574 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39575 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39576 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39577 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39578 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39579 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39580 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39581 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39582 DATA (DL(K),K= 171, 255) /
39583 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39584 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39585 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39586 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39587 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39588 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39589 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39590 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39591 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39592 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39593 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39594 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39595 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39596 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39597 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39598 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39599 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39600 DATA (DL(K),K= 256, 340) /
39601 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39602 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39603 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39604 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39605 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39606 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39607 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39608 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39609 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39610 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39611 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39612 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39613 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39614 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39615 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39616 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39617 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39618 DATA (DL(K),K= 341, 425) /
39619 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39620 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39621 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39622 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39623 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39624 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39625 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39626 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39627 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39628 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39629 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39630 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39631 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39632 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39633 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39634 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39635 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39636 DATA (DL(K),K= 426, 510) /
39637 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39638 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39639 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39640 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39641 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39642 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39643 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39644 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39645 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39646 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39647 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39648 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39649 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39650 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39651 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39652 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39653 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39654 DATA (DL(K),K= 511, 595) /
39655 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39656 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39657 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39658 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39659 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39660 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39661 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39662 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39663 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39664 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39665 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39666 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39667 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39668 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39669 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39670 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39671 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39672 DATA (DL(K),K= 596, 680) /
39673 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39674 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39675 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39676 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39677 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39678 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39679 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39680 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39681 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39682 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39683 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39684 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39685 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39686 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39687 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39688 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39689 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39690 DATA (DL(K),K= 681, 765) /
39691 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39692 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39693 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39694 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39695 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39696 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39697 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39698 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39699 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39700 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39701 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39702 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39703 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39704 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39705 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39706 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39707 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39708 DATA (DL(K),K= 766, 850) /
39709 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39710 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39711 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39712 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39713 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39714 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39715 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39716 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39717 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39718 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39719 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39720 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39721 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39722 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39723 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39724 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39725 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39726 DATA (DL(K),K= 851, 935) /
39727 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39728 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39729 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39730 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39731 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39732 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39733 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39734 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39735 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39736 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39737 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39738 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39739 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39740 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39741 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39742 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39743 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39744 DATA (DL(K),K= 936, 1020) /
39745 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39746 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39747 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39748 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39749 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39750 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39751 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39752 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39753 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39754 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39755 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39756 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39757 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39758 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39759 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39760 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39761 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39762 DATA (DL(K),K= 1021, 1105) /
39763 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39764 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39765 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39766 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39767 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39768 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39769 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39770 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39771 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39772 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39773 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39774 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39775 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39776 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39777 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39778 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39779 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39780 DATA (DL(K),K= 1106, 1190) /
39781 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39782 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39783 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39784 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39785 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39786 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39787 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39788 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39789 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39790 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39791 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39792 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39793 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39794 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39795 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39796 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39797 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39798 DATA (DL(K),K= 1191, 1275) /
39799 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39800 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39801 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39802 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39803 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39804 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39805 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39806 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39807 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39808 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39809 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39810 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39811 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39812 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39813 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39814 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39815 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39816 DATA (DL(K),K= 1276, 1360) /
39817 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39818 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39819 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39820 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39821 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39822 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39823 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39824 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39825 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39826 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39827 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39828 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39829 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39830 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39831 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39832 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39833 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39834 DATA (DL(K),K= 1361, 1445) /
39835 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39836 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39837 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39838 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39839 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39840 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39841 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39842 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39843 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39844 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39845 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39846 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39847 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39848 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39849 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39850 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39851 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39852 DATA (DL(K),K= 1446, 1530) /
39853 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39854 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39855 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39856 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39857 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39858 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39859 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39860 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39861 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39862 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39863 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39864 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39865 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39866 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39867 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39868 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39869 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39870 DATA (DL(K),K= 1531, 1615) /
39871 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39872 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39873 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39874 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39875 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39876 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39877 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39878 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39879 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39880 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39881 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39882 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39883 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39884 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39885 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39886 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39887 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39888 DATA (DL(K),K= 1616, 1700) /
39889 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39890 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39891 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39892 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39893 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39894 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39895 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39896 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39897 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39898 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39899 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39900 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39901 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39902 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39903 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39904 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39905 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39906 DATA (DL(K),K= 1701, 1785) /
39907 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39908 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39909 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39910 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39911 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39912 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39913 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39914 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39915 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39916 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39917 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39918 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39919 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39920 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39921 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39922 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39923 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39924 DATA (DL(K),K= 1786, 1870) /
39925 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39926 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39927 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39928 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39929 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39930 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39931 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39932 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39933 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39934 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39935 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39936 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39937 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39938 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39939 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39940 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39941 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39942 DATA (DL(K),K= 1871, 1955) /
39943 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39944 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39945 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39946 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39947 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39948 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39949 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39950 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39951 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39952 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39953 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39954 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39955 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39956 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39957 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39958 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39959 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39960 DATA (DL(K),K= 1956, 2040) /
39961 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39962 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39963 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39964 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39965 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39966 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39967 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39968 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39969 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39970 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39971 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39972 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39973 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39974 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39975 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39976 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39977 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39978 DATA (DL(K),K= 2041, 2125) /
39979 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39980 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39981 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39982 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39983 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39984 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39985 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39986 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39987 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39988 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39989 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39990 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39991 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39992 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39993 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39994 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39995 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39996 DATA (DL(K),K= 2126, 2210) /
39997 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39998 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39999 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
40000 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40001 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40002 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40003 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40004 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40005 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40006 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40007 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40008 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40009 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40010 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40011 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40012 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40013 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40014 DATA (DL(K),K= 2211, 2295) /
40015 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40016 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40017 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40018 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40019 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40020 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40021 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40022 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40023 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40024 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40025 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40026 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40027 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40028 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40029 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40030 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40031 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40032 DATA (DL(K),K= 2296, 2380) /
40033 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40034 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40035 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40036 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40037 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40038 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40039 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40040 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40041 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40042 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40043 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40044 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40045 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40046 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40047 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40048 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40049 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40050 DATA (DL(K),K= 2381, 2465) /
40051 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40052 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40053 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40054 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40055 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40056 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40057 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40058 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40059 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40060 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40061 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40062 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40063 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40064 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40065 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40066 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40067 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40068 DATA (DL(K),K= 2466, 2550) /
40069 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40070 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40071 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40072 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40073 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40074 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40075 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40076 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40077 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40078 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40079 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40080 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40081 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40082 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40083 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40084 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40085 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40086 DATA (DL(K),K= 2551, 2635) /
40087 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40088 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40089 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40090 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40091 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40092 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40093 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40094 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40095 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40096 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40097 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40098 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40099 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40100 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40101 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40102 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40103 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40104 DATA (DL(K),K= 2636, 2720) /
40105 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40106 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40107 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40108 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40109 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40110 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40111 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40112 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40113 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40114 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40115 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40116 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40117 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40118 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40119 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40120 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40121 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40122 DATA (DL(K),K= 2721, 2805) /
40123 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40124 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40125 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40126 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40127 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40128 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40129 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40130 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40131 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40132 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40133 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40134 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40135 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40136 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40137 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40138 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40139 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40140 DATA (DL(K),K= 2806, 2890) /
40141 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40142 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40143 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40144 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40145 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40146 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40147 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40148 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40149 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40150 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40151 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40152 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40153 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40154 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40155 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40156 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40157 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40158 DATA (DL(K),K= 2891, 2975) /
40159 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40160 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40161 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40162 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40163 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40164 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40165 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40166 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40167 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40168 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40169 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40170 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40171 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40172 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40173 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40174 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40175 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40176 DATA (DL(K),K= 2976, 3060) /
40177 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40178 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40179 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40180 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40181 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40182 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40183 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40184 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40185 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40186 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40187 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40188 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40189 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40190 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40191 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40192 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40193 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40194 DATA (DL(K),K= 3061, 3145) /
40195 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40196 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40197 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40198 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40199 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40200 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40201 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40202 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40203 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40204 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40205 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40206 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40207 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40208 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40209 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40210 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40211 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40212 DATA (DL(K),K= 3146, 3230) /
40213 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40214 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40215 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40216 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40217 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40218 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40219 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40220 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40221 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40222 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40223 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40224 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40225 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40226 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40227 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40228 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40229 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40230 DATA (DL(K),K= 3231, 3315) /
40231 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40232 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40233 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40234 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40235 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40236 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40237 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40238 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40239 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40240 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40241 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40242 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40243 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40244 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40245 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40246 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40247 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40248 DATA (DL(K),K= 3316, 3400) /
40249 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40250 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40251 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40252 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40253 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40254 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40255 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40256 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40257 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40258 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40259 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40260 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40261 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40262 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40263 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40264 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40265 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40266 DATA (DL(K),K= 3401, 3485) /
40267 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40268 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40269 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40270 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40271 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40272 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40273 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40274 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40275 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40276 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40277 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40278 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40279 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40280 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40281 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40282 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40283 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40284 DATA (DL(K),K= 3486, 3570) /
40285 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40286 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40287 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40288 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40289 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40290 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40291 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40292 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40293 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40294 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40295 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40296 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40297 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40298 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40299 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40300 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40301 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40302 DATA (DL(K),K= 3571, 3655) /
40303 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40304 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40305 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40306 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40307 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40308 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40309 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40310 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40311 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40312 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40313 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40314 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40315 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40316 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40317 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40318 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40319 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40320 DATA (DL(K),K= 3656, 3740) /
40321 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40322 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40323 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40324 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40325 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40326 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40327 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40328 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40329 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40330 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40331 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40332 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40333 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40334 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40335 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40336 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40337 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40338 DATA (DL(K),K= 3741, 3825) /
40339 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40340 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40341 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40342 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40343 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40344 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40345 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40346 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40347 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40348 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40349 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40350 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40351 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40352 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40353 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40354 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40355 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40356 DATA (DL(K),K= 3826, 3910) /
40357 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40358 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40359 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40360 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40361 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40362 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40363 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40364 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40365 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40366 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40367 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40368 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40369 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40370 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40371 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40372 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40373 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40374 DATA (DL(K),K= 3911, 3995) /
40375 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40376 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40377 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40378 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40379 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40380 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40381 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40382 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40383 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40384 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40385 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40386 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40387 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40388 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40389 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40390 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40391 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40392 DATA (DL(K),K= 3996, 4000) /
40393 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40398 IF(X.GT.0.9985) RETURN
40404 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40405 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40412 A1 = PHO_CKMTFV(X,F1)
40413 A2 = PHO_CKMTFV(X,F2)
40414 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40420 CDECK ID>, PHO_CKMTFV
40421 REAL FUNCTION PHO_CKMTFV(X,FVL)
40422 C**********************************************************************
40424 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40425 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40426 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40429 C**********************************************************************
40432 DIMENSION FVL(25),XGRID(25)
40434 C input/output channels
40436 COMMON /POINOU/ LI,LO
40438 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40439 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40443 IF(X.LT.XGRID(I)) GO TO 2
40448 ELSE IF(I.GT.23) THEN
40454 BXI=LOG(1.-XGRID(I))
40456 BXJ=LOG(1.-XGRID(J))
40458 BXK=LOG(1.-XGRID(K))
40459 FI=LOG(ABS(FVL(I)) +1.E-15)
40460 FJ=LOG(ABS(FVL(J)) +1.E-16)
40461 FK=LOG(ABS(FVL(K)) +1.E-17)
40462 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40463 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40465 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40466 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40467 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40469 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40470 C WRITE(LO,2001) X,FVL
40471 C 2001 FORMAT(8E12.4)
40472 C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40474 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40478 CDECK ID>, PHO_SASGAM
40479 C***********************************************************************
40480 C...SaSgam version 2 - parton distributions of the photon
40481 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40482 C...For further information see Z. Phys. C68 (1995) 607
40483 C...and Phys. Lett. B376 (1996) 193.
40485 C...18 January 1996: original code.
40486 C...22 July 1996: calculation of BETA moved in SASBEH.
40488 C!!!Note that one further call parameter - IP2 - has been added
40489 C!!!to the SASGAM argument list compared with version 1.
40491 C...The user should only need to call the SASGAM routine,
40492 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40493 C...SASBEH and SASDIR. The package is self-contained.
40495 C...One particular aspect of these parametrizations is that F2 for
40496 C...the photon is not obtained just as the charge-squared-weighted
40497 C...sum of quark distributions, but differ in the treatment of
40498 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40499 C...the kinematics range of heavy-flavour production, but the same
40500 C...kinematics is not relevant e.g. for jet production) and, for the
40501 C...'MSbar' fits, in the addition of a Cgamma term related to the
40502 C...separation of direct processes. Schematically:
40503 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40504 C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40505 C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40506 C...The J/psi and Upsilon states have not been included in the VMD sum,
40507 C...but low c and b masses in the other components should compensate
40508 C...for this in a duality sense.
40510 C...The calling sequence is the following:
40511 C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40512 C...with the following declaration statement:
40513 C DIMENSION XPDFGM(-6:6)
40514 C...and, optionally, further information in:
40515 C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40517 C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40518 C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40519 C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40520 C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40521 C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40524 C P2 : P2 value; should be = 0. for an on-shell photon.
40525 C IP2 : scheme used to evaluate off-shell anomalous component.
40526 C = 0 : recommended default, see = 7.
40527 C = 1 : dipole dampening by integration; very time-consuming.
40528 C = 2 : P_0^2 = max( Q_0^2, P^2 )
40529 C = 3 : P_0^2 = Q_0^2 + P^2.
40530 C = 4 : P_{eff} that preserves momentum sum.
40531 C = 5 : P_{int} that preserves momentum and average
40533 C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40534 C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40535 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40536 C XPFDGM : x times parton distribution functions of the photon,
40537 C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40538 C 6 = t (always empty!), - for antiquarks (result is same).
40539 C...The breakdown by component is stored in the commonblock SASCOM,
40540 C with elements as above.
40541 C XPVMD : rho, omega, phi VMD part only of output.
40542 C XPANL : d, u, s anomalous part only of output.
40543 C XPANH : c, b anomalous part only of output.
40544 C XPBEH : c, b Bethe-Heitler part only of output.
40545 C XPDIR : Cgamma (direct contribution) part only of output.
40546 C...The above arrays do not distinguish valence and sea contributions,
40547 C...although this information is available internally. The additional
40548 C...commonblock SASVAL provides the valence part only of the above
40549 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40550 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40551 C...and therefore not given doubly. VXPDGM gives the sum of valence
40552 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40553 C...and so on, gives the sea part only.
40554 C***********************************************************************
40556 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40557 C...Purpose: to construct the F2 and parton distributions of the photon
40558 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40559 C...For F2, c and b are included by the Bethe-Heitler formula;
40560 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40562 DIMENSION XPDFGM(-6:6)
40564 C input/output channels
40566 COMMON /POINOU/ LI,LO
40568 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40570 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40571 SAVE /SASCOM/,/SASVAL/
40573 C...Temporary array.
40574 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40575 C...Charm and bottom masses (low to compensate for J/psi etc.).
40576 DATA PMC/1.3/, PMB/4.6/
40577 C...alpha_em and alpha_em/(2*pi).
40578 DATA AEM/0.007297/, AEM2PI/0.0011614/
40579 C...Lambda value for 4 flavours.
40581 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40583 C...VMD couplings f_V**2/(4*pi).
40584 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40585 C...Masses for rho (=omega) and phi.
40586 DATA PMRHO/0.770/, PMPHI/1.020/
40587 C...Number of points in integration for IP2=1.
40605 C...Check that input sensible.
40606 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40607 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40608 WRITE(LO,*) ' ISET = ',ISET
40611 IF(X.LE.0..OR.X.GT.1.) THEN
40612 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40613 WRITE(LO,*) ' X = ',X
40617 C...Set Q0 cut-off parameter as function of set used.
40625 C...Scale choice for off-shell photon; common factors.
40630 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40631 FACNOR=LOG(Q2/Q02)/NSTEP
40632 ELSEIF(IP2.EQ.2) THEN
40634 ELSEIF(IP2.EQ.3) THEN
40636 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40637 ELSEIF(IP2.EQ.4) THEN
40638 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40639 & ((Q2+P2)*(Q02+P2)))
40640 ELSEIF(IP2.EQ.5) THEN
40641 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40642 & ((Q2+P2)*(Q02+P2)))
40643 P2MX=Q0*SQRT(P2MXA)
40644 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40645 ELSEIF(IP2.EQ.6) THEN
40646 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40647 & ((Q2+P2)*(Q02+P2)))
40648 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40650 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40651 & ((Q2+P2)*(Q02+P2)))
40652 P2MX=Q0*SQRT(P2MXA)
40654 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40655 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40656 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40659 C...Call VMD parametrization for d quark and use to give rho, omega,
40660 C...phi. Note dipole dampening for off-shell photon.
40661 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40665 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40666 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40668 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40670 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40671 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40672 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40673 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40674 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40675 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40676 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40677 VXPVMD(2)=FRACU*FACUD*XFVAL
40678 VXPVMD(3)=FACS*XFVAL
40679 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40680 VXPVMD(-2)=FRACU*FACUD*XFVAL
40681 VXPVMD(-3)=FACS*XFVAL
40684 C...Anomalous parametrizations for different strategies
40685 C...for off-shell photons; except full integration.
40687 C...Call anomalous parametrization for d + u + s.
40688 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40690 XPANL(KFL)=FACNOR*XPGA(KFL)
40691 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40694 C...Call anomalous parametrization for c and b.
40695 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40697 XPANH(KFL)=FACNOR*XPGA(KFL)
40698 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40700 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40702 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40703 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40707 C...Special option: loop over flavours and integrate over k2.
40709 DO 160 ISTEP=1,NSTEP
40710 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40711 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40712 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40713 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40714 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40715 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40716 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40718 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40719 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40720 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40721 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40727 C...Call Bethe-Heitler term expression for charm and bottom.
40728 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40731 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40735 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40736 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40737 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40739 XPDIR(KFL)=XPGA(KFL)
40743 C...Store result in output array.
40746 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40747 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40748 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40749 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40750 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40756 C*********************************************************************
40758 CDECK ID>, PHO_SASVMD
40759 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40760 C...Purpose: to evaluate the VMD parton distributions of a photon,
40761 C...evolved homogeneously from an initial scale P2 to Q2.
40762 C...Does not include dipole suppression factor.
40763 C...ISET is parton distribution set, see above;
40764 C...additionally ISET=0 is used for the evolution of an anomalous photon
40765 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40766 C...ALAM is the 4-flavour Lambda, which is automatically converted
40767 C...to 3- and 5-flavour equivalents as needed.
40769 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40771 C input/output channels
40773 COMMON /POINOU/ LI,LO
40775 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40784 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40785 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40786 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40787 P2EFF=MAX(P2,1.2*ALAM3**2)
40788 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40789 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40790 Q2EFF=MAX(Q2,P2EFF)
40792 C...Find number of flavours at lower and upper scale.
40794 IF(P2EFF.LT.PMC**2) NFP=3
40795 IF(P2EFF.GT.PMB**2) NFP=5
40797 IF(Q2EFF.LT.PMC**2) NFQ=3
40798 IF(Q2EFF.GT.PMB**2) NFQ=5
40800 C...Find s as sum of 3-, 4- and 5-flavour parts.
40804 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40805 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40807 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40809 IF(NFP.EQ.3) P2DIV=PMC**2
40811 IF(NFQ.EQ.5) Q2DIV=PMB**2
40812 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40816 IF(NFP.EQ.5) P2DIV=P2EFF
40817 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40820 C...Calculate frequent combinations of x and s.
40827 C...Evaluate homogeneous anomalous parton distributions below or
40828 C...above threshold.
40830 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40831 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40832 XVAL = X * 1.5 * (X**2+X1**2)
40836 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40837 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40838 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40839 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40840 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40841 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40842 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40843 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40844 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40845 & (2.*X-1.)*X*XL**2)
40848 C...Evaluate set 1D parton distributions below or above threshold.
40849 ELSEIF(ISET.EQ.1) THEN
40850 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40851 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40852 XVAL = 1.294 * X**0.80 * X1**0.76
40853 XGLU = 1.273 * X**0.40 * X1**1.76
40854 XSEA = 0.100 * X1**3.76
40856 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40857 & X1**(0.76+0.667*S) * XL**(2.*S)
40858 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40859 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40860 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40861 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40862 & X**(-7.32*S2/(1.+10.3*S2)) *
40863 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40864 XSEA0 = 0.100 * X1**3.76
40867 C...Evaluate set 1M parton distributions below or above threshold.
40868 ELSEIF(ISET.EQ.2) THEN
40869 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40870 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40871 XVAL = 0.8477 * X**0.51 * X1**1.37
40872 XGLU = 3.42 * X**0.255 * X1**2.37
40875 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40876 & * X1**1.37 * XL**(2.667*S)
40877 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40878 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40879 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40881 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40882 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40887 C...Evaluate set 2D parton distributions below or above threshold.
40888 ELSEIF(ISET.EQ.3) THEN
40889 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40890 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40891 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40892 XGLU = 1.925 * X1**2
40893 XSEA = 0.242 * X1**4
40895 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40896 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40897 & (0.76+0.4*S) * X * X1**(2.667*S)
40898 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40899 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40900 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40901 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40902 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40903 XSEA0 = 0.242 * X1**4
40906 C...Evaluate set 2M parton distributions below or above threshold.
40907 ELSEIF(ISET.EQ.4) THEN
40908 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40909 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40910 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40911 XGLU = 1.808 * X1**2
40912 XSEA = 0.209 * X1**4
40914 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40915 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40916 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40917 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40918 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40919 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40920 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40921 & XL**(10.9*S/(1.+2.5*S))
40922 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40923 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40924 & X1**(4.+S) * XL**(0.45*S)
40925 XSEA0 = 0.209 * X1**4
40929 C...Threshold factors for c and b sea.
40930 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40932 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40933 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40935 XCHM=XSEA*(1.-(SCH/SLL)**2)
40937 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40941 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40942 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40944 XBOT=XSEA*(1.-(SBT/SLL)**2)
40946 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40950 C...Fill parton distributions.
40957 XPGA(KFA)=XPGA(KFA)+XVAL
40959 XPGA(-KFL)=XPGA(KFL)
40967 C*********************************************************************
40969 CDECK ID>, PHO_SASANO
40970 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40971 C...Purpose: to evaluate the parton distributions of the anomalous
40972 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40974 C...KF=0 gives the sum over (up to) 5 flavours,
40975 C...KF<0 limits to flavours up to abs(KF),
40976 C...KF>0 is for flavour KF only.
40977 C...ALAM is the 4-flavour Lambda, which is automatically converted
40978 C...to 3- and 5-flavour equivalents as needed.
40981 C input/output channels
40983 COMMON /POINOU/ LI,LO
40985 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40986 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40993 IF(Q2.LE.P2) RETURN
40996 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40997 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40999 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
41000 P2EFF=MAX(P2,1.2*ALAMSQ(3))
41001 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41002 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41003 Q2EFF=MAX(Q2,P2EFF)
41006 C...Find number of flavours at lower and upper scale.
41008 IF(P2EFF.LT.PMC**2) NFP=3
41009 IF(P2EFF.GT.PMB**2) NFP=5
41011 IF(Q2EFF.LT.PMC**2) NFQ=3
41012 IF(Q2EFF.GT.PMB**2) NFQ=5
41014 C...Define range of flavour loop.
41018 ELSEIF(KF.LT.0) THEN
41026 C...Loop over flavours the photon can branch into.
41027 DO 110 KFL=KFLMN,KFLMX
41029 C...Light flavours: calculate t range and (approximate) s range.
41030 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41031 TDIFF=LOG(Q2EFF/P2EFF)
41032 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41033 & LOG(P2EFF/ALAMSQ(NFQ)))
41034 IF(NFQ.GT.NFP) THEN
41036 IF(NFQ.EQ.4) Q2DIV=PMC**2
41037 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41038 & LOG(P2EFF/ALAMSQ(NFQ)))
41039 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41040 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41041 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41043 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41045 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41046 & LOG(P2EFF/ALAMSQ(4)))
41047 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41048 & LOG(P2EFF/ALAMSQ(3)))
41049 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41052 C...u and s quark do not need a separate treatment when d has been done.
41053 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41055 C...Charm: as above, but only include range above c threshold.
41056 ELSEIF(KFL.EQ.4) THEN
41057 IF(Q2.LE.PMC**2) GOTO 110
41058 P2EFF=MAX(P2EFF,PMC**2)
41059 Q2EFF=MAX(Q2EFF,P2EFF)
41060 TDIFF=LOG(Q2EFF/P2EFF)
41061 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41062 & LOG(P2EFF/ALAMSQ(NFQ)))
41063 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41065 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41066 & LOG(P2EFF/ALAMSQ(NFQ)))
41067 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41068 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41069 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41072 C...Bottom: as above, but only include range above b threshold.
41073 ELSEIF(KFL.EQ.5) THEN
41074 IF(Q2.LE.PMB**2) GOTO 110
41075 P2EFF=MAX(P2EFF,PMB**2)
41076 Q2EFF=MAX(Q2,P2EFF)
41077 TDIFF=LOG(Q2EFF/P2EFF)
41078 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41079 & LOG(P2EFF/ALAMSQ(NFQ)))
41082 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41084 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41085 FAC=AEM2PI*2.*CHSQ*TDIFF
41087 C...Evaluate parton distributions (normalized to unit momentum sum).
41088 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41089 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41090 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41091 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41092 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41093 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41094 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41095 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41096 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41097 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41098 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41099 & (2.*X-1.)*X*XL**2)
41101 C...Threshold factors for c and b sea.
41102 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41104 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41105 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41106 XCHM=XSEA*(1.-(SCH/SLL)**3)
41109 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41110 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41111 XBOT=XSEA*(1.-(SBT/SLL)**3)
41115 C...Add contribution of each valence flavour.
41116 XPGA(0)=XPGA(0)+FAC*XGLU
41117 XPGA(1)=XPGA(1)+FAC*XSEA
41118 XPGA(2)=XPGA(2)+FAC*XSEA
41119 XPGA(3)=XPGA(3)+FAC*XSEA
41120 XPGA(4)=XPGA(4)+FAC*XCHM
41121 XPGA(5)=XPGA(5)+FAC*XBOT
41122 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41123 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41126 XPGA(-KFL)=XPGA(KFL)
41127 VXPGA(-KFL)=VXPGA(KFL)
41132 C*********************************************************************
41134 CDECK ID>, PHO_SASBEH
41135 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41136 C...Purpose: to evaluate the Bethe-Heitler cross section for
41137 C...heavy flavour production.
41139 DATA AEM2PI/0.0011614/
41145 C...Check kinematics limits.
41146 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41149 IF(BETA2.LT.1E-10) RETURN
41153 C...Simple case: P2 = 0.
41154 IF(P2.LT.1E-4) THEN
41155 IF(BETA.LT.0.99) THEN
41156 XBL=LOG((1.+BETA)/(1.-BETA))
41158 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41160 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41161 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41163 C...Complicated case: P2 > 0, based on approximation of
41164 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41166 RPQ=1.-4.*X**2*P2/Q2
41167 IF(RPQ.GT.1E-10) THEN
41168 RPBE=SQRT(RPQ*BETA2)
41169 IF(RPBE.LT.0.99) THEN
41170 XBL=LOG((1.+RPBE)/(1.-RPBE))
41171 XBI=2.*RPBE/(1.-RPBE**2)
41173 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41174 XBL=LOG((1.+RPBE)**2/RPBESN)
41177 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41178 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41179 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41183 C...Multiply by charge-squared etc. to get parton distribution.
41185 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41186 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41190 C*********************************************************************
41192 CDECK ID>, PHO_SASDIR
41193 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41194 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41195 C...as needed in MSbar parametrizations.
41197 DIMENSION XPGA(-6:6)
41198 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41205 C...Evaluate common x-dependent expression.
41206 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41207 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41209 C...d, u, s part by simple charge factor.
41210 XPGA(1)=(1./9.)*CGAM
41211 XPGA(2)=(4./9.)*CGAM
41212 XPGA(3)=(1./9.)*CGAM
41214 C...Also fill for antiquarks.
41221 CDECK ID>, PHO_PHGAL
41222 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41223 C***********************************************************************
41225 C photon parton densities with built-in momentum sum rule and
41226 C Regge-based low-x behaviour
41228 C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41229 C e-Print Archive: hep-ph/9711355
41231 C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41233 C***********************************************************************
41234 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41237 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41239 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41240 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41246 C...100 x values; in (D-4,.77) log spaced (78 points)
41247 C... in (.78,.995) lineary spaced (22 points)
41248 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41250 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41251 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41252 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41253 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41254 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41255 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41256 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41257 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41258 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41259 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41260 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41261 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41262 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41263 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41264 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41265 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41266 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41268 C...place for DATA blocks
41269 DATA (XPV(I,1,0),I=1,100)/
41270 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41271 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41272 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41273 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41274 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41275 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41276 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41277 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41278 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41279 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41280 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41281 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41282 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41283 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41284 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41285 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41286 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41287 DATA (XPV(I,1,1),I=1,100)/
41288 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41289 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41290 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41291 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41292 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41293 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41294 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41295 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41296 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41297 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41298 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41299 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41300 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41301 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41302 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41303 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41304 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41305 DATA (XPV(I,1,2),I=1,100)/
41306 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41307 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41308 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41309 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41310 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41311 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41312 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41313 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41314 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41315 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41316 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41317 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41318 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41319 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41320 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41321 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41322 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41323 DATA (XPV(I,1,3),I=1,100)/
41324 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41325 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41326 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41327 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41328 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41329 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41330 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41331 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41332 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41333 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41334 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41335 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41336 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41337 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41338 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41339 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41340 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41341 DATA (XPV(I,1,4),I=1,100)/
41342 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41343 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41344 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41345 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41346 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41347 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41348 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41349 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41350 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41351 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41352 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41353 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41354 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41355 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41356 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41357 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41358 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41359 DATA (XPV(I,2,0),I=1,100)/
41360 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41361 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41362 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41363 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41364 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41365 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41366 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41367 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41368 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41369 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41370 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41371 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41372 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41373 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41374 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41375 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41376 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41377 DATA (XPV(I,2,1),I=1,100)/
41378 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41379 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41380 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41381 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41382 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41383 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41384 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41385 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41386 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41387 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41388 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41389 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41390 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41391 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41392 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41393 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41394 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41395 DATA (XPV(I,2,2),I=1,100)/
41396 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41397 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41398 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41399 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41400 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41401 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41402 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41403 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41404 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41405 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41406 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41407 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41408 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41409 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41410 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41411 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41412 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41413 DATA (XPV(I,2,3),I=1,100)/
41414 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41415 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41416 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41417 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41418 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41419 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41420 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41421 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41422 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41423 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41424 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41425 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41426 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41427 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41428 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41429 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41430 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41431 DATA (XPV(I,2,4),I=1,100)/
41432 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41433 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41434 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41435 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41436 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41437 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41438 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41439 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41440 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41441 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41442 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41443 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41444 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41445 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41446 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41447 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41448 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41449 DATA (XPV(I,3,0),I=1,100)/
41450 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41451 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41452 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41453 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41454 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41455 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41456 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41457 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41458 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41459 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41460 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41461 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41462 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41463 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41464 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41465 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41466 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41467 DATA (XPV(I,3,1),I=1,100)/
41468 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41469 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41470 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41471 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41472 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41473 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41474 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41475 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41476 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41477 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41478 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41479 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41480 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41481 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41482 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41483 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41484 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41485 DATA (XPV(I,3,2),I=1,100)/
41486 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41487 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41488 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41489 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41490 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41491 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41492 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41493 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41494 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41495 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41496 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41497 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41498 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41499 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41500 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41501 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41502 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41503 DATA (XPV(I,3,3),I=1,100)/
41504 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41505 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41506 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41507 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41508 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41509 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41510 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41511 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41512 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41513 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41514 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41515 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41516 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41517 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41518 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41519 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41520 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41521 DATA (XPV(I,3,4),I=1,100)/
41522 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41523 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41524 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41525 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41526 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41527 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41528 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41529 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41530 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41531 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41532 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41533 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41534 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41535 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41536 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41537 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41538 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41539 DATA (XPV(I,4,0),I=1,100)/
41540 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41541 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41542 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41543 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41544 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41545 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41546 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41547 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41548 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41549 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41550 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41551 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41552 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41553 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41554 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41555 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41556 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41557 DATA (XPV(I,4,1),I=1,100)/
41558 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41559 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41560 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41561 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41562 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41563 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41564 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41565 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41566 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41567 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41568 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41569 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41570 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41571 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41572 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41573 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41574 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41575 DATA (XPV(I,4,2),I=1,100)/
41576 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41577 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41578 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41579 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41580 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41581 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41582 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41583 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41584 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41585 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41586 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41587 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41588 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41589 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41590 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41591 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41592 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41593 DATA (XPV(I,4,3),I=1,100)/
41594 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41595 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41596 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41597 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41598 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41599 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41600 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41601 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41602 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41603 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41604 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41605 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41606 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41607 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41608 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41609 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41610 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41611 DATA (XPV(I,4,4),I=1,100)/
41612 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41613 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41614 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41615 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41616 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41617 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41618 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41619 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41620 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41621 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41622 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41623 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41624 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41625 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41626 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41627 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41628 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41629 DATA (XPV(I,5,0),I=1,100)/
41630 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41631 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41632 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41633 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41634 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41635 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41636 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41637 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41638 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41639 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41640 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41641 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41642 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41643 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41644 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41645 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41646 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41647 DATA (XPV(I,5,1),I=1,100)/
41648 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41649 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41650 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41651 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41652 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41653 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41654 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41655 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41656 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41657 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41658 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41659 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41660 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41661 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41662 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41663 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41664 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41665 DATA (XPV(I,5,2),I=1,100)/
41666 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41667 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41668 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41669 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41670 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41671 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41672 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41673 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41674 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41675 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41676 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41677 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41678 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41679 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41680 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41681 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41682 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41683 DATA (XPV(I,5,3),I=1,100)/
41684 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41685 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41686 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41687 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41688 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41689 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41690 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41691 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41692 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41693 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41694 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41695 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41696 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41697 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41698 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41699 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41700 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41701 DATA (XPV(I,5,4),I=1,100)/
41702 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41703 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41704 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41705 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41706 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41707 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41708 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41709 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41710 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41711 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41712 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41713 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41714 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41715 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41716 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41717 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41718 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41719 DATA (XPV(I,6,0),I=1,100)/
41720 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41721 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41722 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41723 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41724 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41725 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41726 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41727 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41728 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41729 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41730 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41731 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41732 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41733 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41734 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41735 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41736 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41737 DATA (XPV(I,6,1),I=1,100)/
41738 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41739 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41740 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41741 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41742 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41743 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41744 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41745 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41746 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41747 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41748 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41749 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41750 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41751 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41752 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41753 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41754 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41755 DATA (XPV(I,6,2),I=1,100)/
41756 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41757 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41758 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41759 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41760 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41761 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41762 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41763 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41764 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41765 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41766 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41767 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41768 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41769 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41770 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41771 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41772 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41773 DATA (XPV(I,6,3),I=1,100)/
41774 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41775 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41776 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41777 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41778 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41779 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41780 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41781 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41782 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41783 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41784 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41785 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41786 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41787 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41788 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41789 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41790 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41791 DATA (XPV(I,6,4),I=1,100)/
41792 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41793 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41794 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41795 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41796 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41797 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41798 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41799 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41800 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41801 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41802 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41803 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41804 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41805 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41806 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41807 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41808 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41809 DATA (XPV(I,7,0),I=1,100)/
41810 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41811 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41812 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41813 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41814 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41815 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41816 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41817 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41818 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41819 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41820 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41821 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41822 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41823 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41824 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41825 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41826 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41827 DATA (XPV(I,7,1),I=1,100)/
41828 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41829 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41830 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41831 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41832 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41833 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41834 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41835 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41836 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41837 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41838 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41839 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41840 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41841 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41842 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41843 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41844 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41845 DATA (XPV(I,7,2),I=1,100)/
41846 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41847 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41848 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41849 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41850 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41851 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41852 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41853 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41854 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41855 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41856 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41857 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41858 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41859 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41860 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41861 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41862 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41863 DATA (XPV(I,7,3),I=1,100)/
41864 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41865 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41866 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41867 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41868 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41869 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41870 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41871 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41872 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41873 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41874 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41875 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41876 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41877 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41878 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41879 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41880 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41881 DATA (XPV(I,7,4),I=1,100)/
41882 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41883 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41884 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41885 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41886 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41887 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41888 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41889 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41890 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41891 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41892 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41893 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41894 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41895 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41896 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41897 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41898 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41905 ENT(I)=LOG10(XT(I))
41910 ENT(IX+I)=LOG10(Q2T(I))
41914 C..various flavours (u-->2,d-->1)
41915 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41916 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41917 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41918 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41919 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41926 CDECK ID>, PHO_DBFINT
41927 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41928 C***********************************************************************
41930 C routine based on CERN library E104
41932 C multi-dimensional interpolation routine, needed for PHOJET
41933 C internal cross section tables and several PDF sets (GRV98 and AGL)
41935 C changed to avoid recursive function calls (R.Engel, 09/98)
41937 C***********************************************************************
41938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41941 INTEGER NA(NARG), INDEX(32)
41942 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41949 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41962 IF(NDIM .GT. 2) GOTO 10
41963 IF(NDIM .EQ. 1) GOTO 100
41965 IF(H .EQ. ZEROD) GOTO 90
41967 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41969 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41972 11 LOCC = (LOCA+LOCB) / 2
41973 IF(X-ENT(LOCC)) 12, 20, 13
41977 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41978 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41979 ISHIFT = (LOCA - LMIN) * ISTEP
41980 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41982 20 ISHIFT = (LOCC - LMIN) * ISTEP
41983 21 DO 22 K = 1, KNOTS
41984 INDEX(K) = INDEX(K) + ISHIFT
41987 30 DO 31 K = 1, KNOTS
41988 INDEX(K) = INDEX(K) + ISHIFT
41989 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41990 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41991 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41994 90 ISTEP = ISTEP * NDIM
41996 DO 200 K = 1, KNOTS
41998 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
42001 PHO_DBFINT = DBFINT
42006 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42007 C**********************************************************************
42009 C dummy subroutine, remove to link PHOLIB
42011 C**********************************************************************
42012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)